Add HsSyn prettyprinter tests
authorAlan Zimmerman <alan.zimm@gmail.com>
Tue, 8 Nov 2016 19:37:48 +0000 (21:37 +0200)
committerAlan Zimmerman <alan.zimm@gmail.com>
Wed, 7 Dec 2016 19:31:13 +0000 (21:31 +0200)
Summary:
Add prettyprinter tests, which take a file, parse it, pretty print it,
re-parse the pretty printed version and then compare the original and
new ASTs (ignoring locations)

Updates haddock submodule to match the AST changes.

There are three issues outstanding

1. Extra parens around a context are not reproduced. This will require an
   AST change and will be done in a separate patch.

2. Currently if an `HsTickPragma` is found, this is not pretty-printed,
   to prevent noise in the output.

   I am not sure what the desired behaviour in this case is, so have left
   it as before. Test Ppr047 is marked as expected fail for this.

3. Apart from in a context, the ParsedSource AST keeps all the parens from
   the original source.  Something is happening in the renamer to remove the
   parens around visible type application, causing T12530 to fail, as the
   dumped splice decl is after the renamer.

   This needs to be fixed by keeping the parens, but I do not know where they
   are being removed.  I have amended the test to pass, by removing the parens
   in the expected output.

Test Plan: ./validate

Reviewers: goldfire, mpickering, simonpj, bgamari, austin

Reviewed By: simonpj, bgamari

Subscribers: simonpj, goldfire, thomie, mpickering

Differential Revision: https://phabricator.haskell.org/D2752

GHC Trac Issues: #3384

261 files changed:
compiler/basicTypes/BasicTypes.hs
compiler/basicTypes/DataCon.hs
compiler/basicTypes/MkId.hs
compiler/basicTypes/Var.hs
compiler/coreSyn/PprCore.hs
compiler/deSugar/Coverage.hs
compiler/deSugar/DsArrows.hs
compiler/deSugar/DsCCall.hs
compiler/deSugar/DsForeign.hs
compiler/deSugar/DsMeta.hs
compiler/deSugar/MatchLit.hs
compiler/hsSyn/Convert.hs
compiler/hsSyn/HsBinds.hs
compiler/hsSyn/HsDecls.hs
compiler/hsSyn/HsExpr.hs
compiler/hsSyn/HsExpr.hs-boot
compiler/hsSyn/HsImpExp.hs
compiler/hsSyn/HsLit.hs
compiler/hsSyn/HsPat.hs
compiler/hsSyn/HsPat.hs-boot
compiler/hsSyn/HsSyn.hs
compiler/hsSyn/HsTypes.hs
compiler/hsSyn/HsUtils.hs
compiler/hsSyn/PlaceHolder.hs
compiler/iface/BuildTyCl.hs
compiler/iface/LoadIface.hs
compiler/iface/TcIface.hs
compiler/main/HeaderInfo.hs
compiler/parser/Lexer.x
compiler/parser/Parser.y
compiler/parser/RdrHsSyn.hs
compiler/prelude/ForeignCall.hs
compiler/prelude/PrimOp.hs
compiler/prelude/TysWiredIn.hs
compiler/rename/RnEnv.hs
compiler/rename/RnExpr.hs
compiler/rename/RnPat.hs
compiler/rename/RnSplice.hs
compiler/rename/RnTypes.hs
compiler/stranal/WorkWrap.hs
compiler/typecheck/Inst.hs
compiler/typecheck/TcAnnotations.hs
compiler/typecheck/TcArrows.hs
compiler/typecheck/TcBinds.hs
compiler/typecheck/TcEnv.hs
compiler/typecheck/TcGenDeriv.hs
compiler/typecheck/TcGenFunctor.hs
compiler/typecheck/TcGenGenerics.hs
compiler/typecheck/TcHsSyn.hs
compiler/typecheck/TcHsType.hs
compiler/typecheck/TcInstDcls.hs
compiler/typecheck/TcPat.hs
compiler/typecheck/TcPatSyn.hs
compiler/typecheck/TcSplice.hs
compiler/typecheck/TcTyClsDecls.hs
compiler/typecheck/TcTyDecls.hs
compiler/typecheck/TcTypeable.hs
compiler/utils/Binary.hs
compiler/utils/BooleanFormula.hs
compiler/utils/Outputable.hs
compiler/vectorise/Vectorise/Generic/PData.hs
ghc.mk
testsuite/mk/boilerplate.mk
testsuite/tests/ado/ado002.stderr
testsuite/tests/ado/ado003.stderr
testsuite/tests/ado/ado005.stderr
testsuite/tests/arrows/should_fail/arrowfail004.stderr
testsuite/tests/boxy/Base1.stderr
testsuite/tests/dependent/should_fail/PromotedClass.stderr
testsuite/tests/dependent/should_fail/RAE_T32a.stderr
testsuite/tests/dependent/should_fail/T11334b.stderr
testsuite/tests/ffi/should_fail/T10461.stderr
testsuite/tests/ffi/should_fail/T3066.stderr
testsuite/tests/ffi/should_fail/T7506.stderr
testsuite/tests/ffi/should_fail/capi_value_function.stderr
testsuite/tests/ffi/should_fail/ccfail001.stderr
testsuite/tests/ffi/should_fail/ccfail002.stderr
testsuite/tests/ffi/should_fail/ccfail004.stderr
testsuite/tests/ffi/should_fail/ccfail005.stderr
testsuite/tests/generics/GenDerivOutput.stderr
testsuite/tests/generics/GenDerivOutput1_0.stderr
testsuite/tests/generics/GenDerivOutput1_1.stderr
testsuite/tests/generics/T10604/T10604_deriving.stderr
testsuite/tests/ghc-api/annotations-literals/literals.stdout
testsuite/tests/ghc-api/annotations-literals/parsed.hs
testsuite/tests/ghc-api/annotations-literals/parsed.stdout
testsuite/tests/ghc-api/annotations/T10276.stderr
testsuite/tests/ghc-api/annotations/T10313.stdout
testsuite/tests/ghc-api/annotations/T11430.stdout
testsuite/tests/ghc-api/annotations/t11430.hs
testsuite/tests/ghci/scripts/T8959b.stderr
testsuite/tests/haddock/haddock_examples/haddock.Test.stderr
testsuite/tests/haddock/should_compile_flag_haddock/T11768.stderr
testsuite/tests/haddock/should_compile_flag_haddock/haddockA028.stderr
testsuite/tests/indexed-types/should_fail/SimpleFail14.stderr
testsuite/tests/indexed-types/should_fail/T12867.stderr
testsuite/tests/indexed-types/should_fail/T2664.stderr
testsuite/tests/indexed-types/should_fail/T2693.stderr
testsuite/tests/indexed-types/should_fail/T5439.stderr
testsuite/tests/indexed-types/should_fail/T7786.stderr
testsuite/tests/monadfail/MonadFailErrors.stderr
testsuite/tests/monadfail/MonadFailWarnings.stderr
testsuite/tests/partial-sigs/should_compile/SplicesUsed.stderr
testsuite/tests/partial-sigs/should_compile/T12845.stderr
testsuite/tests/polykinds/PolyKinds04.stderr
testsuite/tests/polykinds/PolyKinds07.stderr
testsuite/tests/polykinds/T10503.stderr
testsuite/tests/polykinds/T11399.stderr
testsuite/tests/polykinds/T11520.stderr
testsuite/tests/polykinds/T11611.stderr
testsuite/tests/polykinds/T5716.stderr
testsuite/tests/polykinds/T5716a.stderr
testsuite/tests/polykinds/T6054.stderr
testsuite/tests/polykinds/T7151.stderr
testsuite/tests/polykinds/T7328.stderr
testsuite/tests/polykinds/T7433.stderr
testsuite/tests/polykinds/T7805.stderr
testsuite/tests/printer/.gitignore [new file with mode: 0644]
testsuite/tests/printer/Makefile [new file with mode: 0644]
testsuite/tests/printer/Ppr001.hs [new file with mode: 0644]
testsuite/tests/printer/Ppr002.hs [new file with mode: 0644]
testsuite/tests/printer/Ppr003.hs [new file with mode: 0644]
testsuite/tests/printer/Ppr004.hs [new file with mode: 0644]
testsuite/tests/printer/Ppr005.hs [new file with mode: 0644]
testsuite/tests/printer/Ppr006.hs [new file with mode: 0644]
testsuite/tests/printer/Ppr006.stderr [new file with mode: 0644]
testsuite/tests/printer/Ppr007.hs [new file with mode: 0644]
testsuite/tests/printer/Ppr007.stderr [new file with mode: 0644]
testsuite/tests/printer/Ppr008.hs [new file with mode: 0644]
testsuite/tests/printer/Ppr009.hs [new file with mode: 0644]
testsuite/tests/printer/Ppr009.stderr [new file with mode: 0644]
testsuite/tests/printer/Ppr010.hs [new file with mode: 0644]
testsuite/tests/printer/Ppr011.hs [new file with mode: 0644]
testsuite/tests/printer/Ppr011.stderr [new file with mode: 0644]
testsuite/tests/printer/Ppr012.hs [new file with mode: 0644]
testsuite/tests/printer/Ppr012.stderr [new file with mode: 0644]
testsuite/tests/printer/Ppr012.stdout [new file with mode: 0644]
testsuite/tests/printer/Ppr013.hs [new file with mode: 0644]
testsuite/tests/printer/Ppr013.stderr [new file with mode: 0644]
testsuite/tests/printer/Ppr014.hs [new file with mode: 0644]
testsuite/tests/printer/Ppr014.stderr [new file with mode: 0644]
testsuite/tests/printer/Ppr015.hs [new file with mode: 0644]
testsuite/tests/printer/Ppr016.hs [new file with mode: 0644]
testsuite/tests/printer/Ppr016.stderr [new file with mode: 0644]
testsuite/tests/printer/Ppr017.hs [new file with mode: 0644]
testsuite/tests/printer/Ppr018.hs [new file with mode: 0644]
testsuite/tests/printer/Ppr018.stderr [new file with mode: 0644]
testsuite/tests/printer/Ppr019.hs [new file with mode: 0644]
testsuite/tests/printer/Ppr020.hs [new file with mode: 0644]
testsuite/tests/printer/Ppr020.stderr [new file with mode: 0644]
testsuite/tests/printer/Ppr021.hs [new file with mode: 0644]
testsuite/tests/printer/Ppr021.stderr [new file with mode: 0644]
testsuite/tests/printer/Ppr022.hs [new file with mode: 0644]
testsuite/tests/printer/Ppr022.stderr [new file with mode: 0644]
testsuite/tests/printer/Ppr023.hs [new file with mode: 0644]
testsuite/tests/printer/Ppr023.stderr [new file with mode: 0644]
testsuite/tests/printer/Ppr024.hs [new file with mode: 0644]
testsuite/tests/printer/Ppr024.stderr [new file with mode: 0644]
testsuite/tests/printer/Ppr025.hs [new file with mode: 0644]
testsuite/tests/printer/Ppr025.stderr [new file with mode: 0644]
testsuite/tests/printer/Ppr026.hs [new file with mode: 0644]
testsuite/tests/printer/Ppr026.stderr [new file with mode: 0644]
testsuite/tests/printer/Ppr027.hs [new file with mode: 0644]
testsuite/tests/printer/Ppr028.hs [new file with mode: 0644]
testsuite/tests/printer/Ppr028.stderr [new file with mode: 0644]
testsuite/tests/printer/Ppr029.hs [new file with mode: 0644]
testsuite/tests/printer/Ppr029.stderr [new file with mode: 0644]
testsuite/tests/printer/Ppr030.hs [new file with mode: 0644]
testsuite/tests/printer/Ppr030.stderr [new file with mode: 0644]
testsuite/tests/printer/Ppr031.hs [new file with mode: 0644]
testsuite/tests/printer/Ppr031.stderr [new file with mode: 0644]
testsuite/tests/printer/Ppr032.hs [new file with mode: 0644]
testsuite/tests/printer/Ppr032.stderr [new file with mode: 0644]
testsuite/tests/printer/Ppr033.hs [new file with mode: 0644]
testsuite/tests/printer/Ppr033.stderr [new file with mode: 0644]
testsuite/tests/printer/Ppr034.hs [new file with mode: 0644]
testsuite/tests/printer/Ppr034.stderr [new file with mode: 0644]
testsuite/tests/printer/Ppr035.hs [new file with mode: 0644]
testsuite/tests/printer/Ppr036.hs [new file with mode: 0644]
testsuite/tests/printer/Ppr036.stderr [new file with mode: 0644]
testsuite/tests/printer/Ppr037.hs [new file with mode: 0644]
testsuite/tests/printer/Ppr037.stderr [new file with mode: 0644]
testsuite/tests/printer/Ppr038.hs [new file with mode: 0644]
testsuite/tests/printer/Ppr039.hs [new file with mode: 0644]
testsuite/tests/printer/Ppr039.stderr [new file with mode: 0644]
testsuite/tests/printer/Ppr040.hs [new file with mode: 0644]
testsuite/tests/printer/Ppr040.stderr [new file with mode: 0644]
testsuite/tests/printer/Ppr041.hs [new file with mode: 0644]
testsuite/tests/printer/Ppr042.hs [new file with mode: 0644]
testsuite/tests/printer/Ppr042.stderr [new file with mode: 0644]
testsuite/tests/printer/Ppr043.hs [new file with mode: 0644]
testsuite/tests/printer/Ppr044.hs [new file with mode: 0644]
testsuite/tests/printer/Ppr045.hs [new file with mode: 0644]
testsuite/tests/printer/Ppr046.hs [new file with mode: 0644]
testsuite/tests/printer/Ppr046.stderr [new file with mode: 0644]
testsuite/tests/printer/Ppr047.hs [new file with mode: 0644]
testsuite/tests/printer/all.T [new file with mode: 0644]
testsuite/tests/quasiquotation/T7918.hs
testsuite/tests/rebindable/rebindable6.stderr
testsuite/tests/rename/should_fail/Misplaced.stderr
testsuite/tests/rename/should_fail/rnfail026.stderr
testsuite/tests/roles/should_compile/T8958.stderr
testsuite/tests/safeHaskell/ghci/p6.stderr
testsuite/tests/safeHaskell/safeLanguage/SafeLang08.stderr
testsuite/tests/safeHaskell/safeLanguage/SafeLang10.stderr
testsuite/tests/safeHaskell/safeLanguage/SafeLang17.stderr
testsuite/tests/simplCore/should_compile/T7785.stderr
testsuite/tests/simplCore/should_compile/T8331.stderr
testsuite/tests/simplCore/should_compile/T8848a.stderr
testsuite/tests/simplCore/should_compile/simpl017.stderr
testsuite/tests/th/T10598_TH.stderr
testsuite/tests/th/T10638.stderr
testsuite/tests/th/T12530.stderr
testsuite/tests/th/T3177a.stderr
testsuite/tests/th/T3319.stderr
testsuite/tests/th/T3899a.hs
testsuite/tests/th/T4436.stderr
testsuite/tests/th/T5217.stderr
testsuite/tests/th/T5358.stderr
testsuite/tests/th/T5508.stderr
testsuite/tests/th/T5700.stderr
testsuite/tests/th/T5883.stderr
testsuite/tests/th/T7532.stderr
testsuite/tests/th/T8577.stderr
testsuite/tests/th/T8761.stderr
testsuite/tests/th/TH_PromotedTuple.stderr
testsuite/tests/th/TH_exn2.stderr
testsuite/tests/th/TH_foreignCallingConventions.stderr
testsuite/tests/th/TH_foreignInterruptible.stderr
testsuite/tests/th/TH_pragma.stderr
testsuite/tests/th/TH_unresolvedInfix2.stderr
testsuite/tests/typecheck/should_compile/T11339.stderr
testsuite/tests/typecheck/should_compile/tc211.stderr
testsuite/tests/typecheck/should_fail/T11464.stderr
testsuite/tests/typecheck/should_fail/T12124.stderr
testsuite/tests/typecheck/should_fail/T2994.stderr
testsuite/tests/typecheck/should_fail/T3540.stderr
testsuite/tests/typecheck/should_fail/T3613.stderr
testsuite/tests/typecheck/should_fail/T7748a.stderr
testsuite/tests/typecheck/should_fail/T7851.stderr
testsuite/tests/typecheck/should_fail/T8603.stderr
testsuite/tests/typecheck/should_fail/T9201.stderr
testsuite/tests/typecheck/should_fail/T9612.stderr
testsuite/tests/typecheck/should_fail/tcfail028.stderr
testsuite/tests/typecheck/should_fail/tcfail070.stderr
testsuite/tests/typecheck/should_fail/tcfail103.stderr
testsuite/tests/typecheck/should_fail/tcfail128.stderr
testsuite/tests/typecheck/should_fail/tcfail132.stderr
testsuite/tests/typecheck/should_fail/tcfail146.stderr
testsuite/tests/typecheck/should_fail/tcfail162.stderr
testsuite/tests/typecheck/should_fail/tcfail165.stderr
testsuite/tests/typecheck/should_fail/tcfail168.stderr
testsuite/tests/unboxedsums/ffi1.stderr
testsuite/tests/wcompat-warnings/WCompatWarningsOn.stderr
utils/check-ppr/Main.hs [new file with mode: 0644]
utils/check-ppr/README [new file with mode: 0644]
utils/check-ppr/check-ppr.cabal [new file with mode: 0644]
utils/check-ppr/ghc.mk [new file with mode: 0644]
utils/genprimopcode/Parser.y
utils/genprimopcode/Syntax.hs
utils/haddock

index ce00c45..a9f1e63 100644 (file)
@@ -30,7 +30,7 @@ module BasicTypes(
 
         FunctionOrData(..),
 
-        WarningTxt(..), StringLiteral(..),
+        WarningTxt(..), pprWarningTxtForMsg, StringLiteral(..),
 
         Fixity(..), FixityDirection(..),
         defaultFixity, maxPrecedence, minPrecedence,
@@ -90,14 +90,17 @@ module BasicTypes(
         inlinePragmaSpec, inlinePragmaSat,
         inlinePragmaActivation, inlinePragmaRuleMatchInfo,
         setInlinePragmaActivation, setInlinePragmaRuleMatchInfo,
+        pprInline, pprInlineDebug,
 
         SuccessFlag(..), succeeded, failed, successIf,
 
         FractionalLit(..), negateFractionalLit, integralFractionalLit,
 
-        SourceText,
+        SourceText(..), pprWithSourceText,
 
-        IntWithInf, infinity, treatZeroAsInf, mkIntWithInf, intGtLimit
+        IntWithInf, infinity, treatZeroAsInf, mkIntWithInf, intGtLimit,
+
+        SpliceExplicitFlag(..)
    ) where
 
 import FastString
@@ -312,6 +315,9 @@ data StringLiteral = StringLiteral
 instance Eq StringLiteral where
   (StringLiteral _ a) == (StringLiteral _ b) = a == b
 
+instance Outputable StringLiteral where
+  ppr sl = pprWithSourceText (sl_st sl) (ftext $ sl_fs sl)
+
 -- | Warning Text
 --
 -- reason/explanation from a WARNING or DEPRECATED pragma
@@ -322,11 +328,30 @@ data WarningTxt = WarningTxt (Located SourceText)
     deriving (Eq, Data)
 
 instance Outputable WarningTxt where
-    ppr (WarningTxt    _ ws)
-                         = doubleQuotes (vcat (map (ftext . sl_fs . unLoc) ws))
-    ppr (DeprecatedTxt _ ds)
-                         = text "Deprecated:" <+>
-                           doubleQuotes (vcat (map (ftext . sl_fs . unLoc) ds))
+    ppr (WarningTxt    lsrc ws)
+      = case unLoc lsrc of
+          NoSourceText   -> pp_ws ws
+          SourceText src -> text src <+> pp_ws ws <+> text "#-}"
+
+    ppr (DeprecatedTxt lsrc  ds)
+      = case unLoc lsrc of
+          NoSourceText   -> pp_ws ds
+          SourceText src -> text src <+> pp_ws ds <+> text "#-}"
+
+pp_ws :: [Located StringLiteral] -> SDoc
+pp_ws [l] = ppr $ unLoc l
+pp_ws ws
+  = text "["
+    <+> vcat (punctuate comma (map (ppr . unLoc) ws))
+    <+> text "]"
+
+
+pprWarningTxtForMsg :: WarningTxt -> SDoc
+pprWarningTxtForMsg (WarningTxt    _ ws)
+                     = doubleQuotes (vcat (map (ftext . sl_fs . unLoc) ws))
+pprWarningTxtForMsg (DeprecatedTxt _ ds)
+                     = text "Deprecated:" <+>
+                       doubleQuotes (vcat (map (ftext . sl_fs . unLoc) ds))
 
 {-
 ************************************************************************
@@ -375,12 +400,12 @@ maxPrecedence = 9
 minPrecedence = 0
 
 defaultFixity :: Fixity
-defaultFixity = Fixity (show maxPrecedence) maxPrecedence InfixL
+defaultFixity = Fixity NoSourceText maxPrecedence InfixL
 
 negateFixity, funTyFixity :: Fixity
 -- Wired-in fixities
-negateFixity = Fixity "6" 6 InfixL  -- Fixity of unary negate
-funTyFixity  = Fixity "0" 0 InfixR  -- Fixity of '->'
+negateFixity = Fixity NoSourceText 6 InfixL  -- Fixity of unary negate
+funTyFixity  = Fixity NoSourceText 0 InfixR  -- Fixity of '->'
 
 {-
 Consider
@@ -979,8 +1004,21 @@ For OverLitVal
   HsIsString      "\x41nd" == "And"
 -}
 
-type SourceText = String -- Note [Literal source text],[Pragma source text]
+ -- Note [Literal source text],[Pragma source text]
+data SourceText = SourceText String
+                | NoSourceText -- ^ For when code is generated, e.g. TH,
+                               -- deriving. The pretty printer will then make
+                               -- its own representation of the item.
+                deriving (Data, Show, Eq )
 
+instance Outputable SourceText where
+  ppr (SourceText s) = text "SourceText" <+> text s
+  ppr NoSourceText   = text "NoSourceText"
+
+-- | Special combinator for showing string literals.
+pprWithSourceText :: SourceText -> SDoc -> SDoc
+pprWithSourceText NoSourceText     d = d
+pprWithSourceText (SourceText src) _ = text src
 
 {-
 ************************************************************************
@@ -1117,7 +1155,7 @@ isEmptyInlineSpec _               = False
 
 defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma
   :: InlinePragma
-defaultInlinePragma = InlinePragma { inl_src = "{-# INLINE"
+defaultInlinePragma = InlinePragma { inl_src = SourceText "{-# INLINE"
                                    , inl_act = AlwaysActive
                                    , inl_rule = FunLike
                                    , inl_inline = EmptyInlineSpec
@@ -1175,8 +1213,8 @@ setInlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo -> InlinePragma
 setInlinePragmaRuleMatchInfo prag info = prag { inl_rule = info }
 
 instance Outputable Activation where
-   ppr AlwaysActive       = brackets (text "ALWAYS")
-   ppr NeverActive        = brackets (text "NEVER")
+   ppr AlwaysActive       = empty
+   ppr NeverActive        = brackets (text "~")
    ppr (ActiveBefore _ n) = brackets (char '~' <> int n)
    ppr (ActiveAfter  _ n) = brackets (int n)
 
@@ -1191,10 +1229,21 @@ instance Outputable InlineSpec where
    ppr EmptyInlineSpec = empty
 
 instance Outputable InlinePragma where
-  ppr (InlinePragma { inl_inline = inline, inl_act = activation
-                    , inl_rule = info, inl_sat = mb_arity })
-    = ppr inline <> pp_act inline activation <+> pp_sat <+> pp_info
+  ppr = pprInline
+
+pprInline :: InlinePragma -> SDoc
+pprInline = pprInline' True
+
+pprInlineDebug :: InlinePragma -> SDoc
+pprInlineDebug = pprInline' False
+
+pprInline' :: Bool -> InlinePragma -> SDoc
+pprInline' emptyInline (InlinePragma { inl_inline = inline, inl_act = activation
+                                    , inl_rule = info, inl_sat = mb_arity })
+    = pp_inl inline <> pp_act inline activation <+> pp_sat <+> pp_info
     where
+      pp_inl x = if emptyInline then empty else ppr x
+
       pp_act Inline   AlwaysActive = empty
       pp_act NoInline NeverActive  = empty
       pp_act _        act          = ppr act
@@ -1356,3 +1405,8 @@ treatZeroAsInf n = Int n
 -- | Inject any integer into an 'IntWithInf'
 mkIntWithInf :: Int -> IntWithInf
 mkIntWithInf = Int
+
+data SpliceExplicitFlag
+          = ExplicitSplice | -- ^ <=> $(f x y)
+            ImplicitSplice   -- ^ <=> f x y,  i.e. a naked top level expression
+    deriving Data
index 1cd90d1..f4cdb21 100644 (file)
@@ -495,7 +495,7 @@ data DataConRep
 -- emit a warning (in checkValidDataCon) and treat it like
 -- @(HsSrcBang _ NoSrcUnpack SrcLazy)@
 data HsSrcBang =
-  HsSrcBang (Maybe SourceText) -- Note [Pragma source text] in BasicTypes
+  HsSrcBang SourceText -- Note [Pragma source text] in BasicTypes
             SrcUnpackedness
             SrcStrictness
   deriving Data.Data
index 649100a..dc8b4d0 100644 (file)
@@ -1122,7 +1122,8 @@ seqId = pcMiscPrelId seqName ty info
                        `setRuleInfo`       mkRuleInfo [seq_cast_rule]
 
     inline_prag
-         = alwaysInlinePragma `setInlinePragmaActivation` ActiveAfter "0" 0
+         = alwaysInlinePragma `setInlinePragmaActivation` ActiveAfter
+                 NoSourceText 0
                   -- Make 'seq' not inline-always, so that simpleOptExpr
                   -- (see CoreSubst.simple_app) won't inline 'seq' on the
                   -- LHS of rules.  That way we can have rules for 'seq';
index a231cf7..e783efe 100644 (file)
@@ -316,6 +316,9 @@ instance Data Var where
   gunfold _ _  = error "gunfold"
   dataTypeOf _ = mkNoRepType "Var"
 
+instance HasOccName Var where
+  occName = nameOccName . varName
+
 varUnique :: Var -> Unique
 varUnique var = mkUniqueGrimily (realUnique var)
 
index 9129c90..5394697 100644 (file)
@@ -402,7 +402,7 @@ pprIdBndrInfo info
     has_lbv   = not (hasNoOneShotInfo lbv_info)
 
     doc = showAttributes
-          [ (has_prag, text "InlPrag=" <> ppr prag_info)
+          [ (has_prag, text "InlPrag=" <> pprInlineDebug prag_info)
           , (has_occ,  text "Occ=" <> ppr occ_info)
           , (has_dmd,  text "Dmd=" <> ppr dmd_info)
           , (has_lbv , text "OS=" <> ppr lbv_info)
index b964912..51bfb18 100644 (file)
@@ -888,9 +888,10 @@ addTickHsCmd (HsCmdArrApp   e1 e2 ty1 arr_ty lr) =
                (return ty1)
                (return arr_ty)
                (return lr)
-addTickHsCmd (HsCmdArrForm e fix cmdtop) =
-        liftM3 HsCmdArrForm
+addTickHsCmd (HsCmdArrForm e f fix cmdtop) =
+        liftM4 HsCmdArrForm
                (addTickLHsExpr e)
+               (return f)
                (return fix)
                (mapM (liftL (addTickHsCmdTop)) cmdtop)
 
index 0ce6f50..16ec704 100644 (file)
@@ -607,7 +607,7 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdDo (L _ stmts) _) env_ids = do
 -- -----------------------------------
 -- D; xs |-a (|e c1 ... cn|) :: stk --> t       ---> e [t_xs] c1 ... cn
 
-dsCmd _ids local_vars _stack_ty _res_ty (HsCmdArrForm op _ args) env_ids = do
+dsCmd _ids local_vars _stack_ty _res_ty (HsCmdArrForm op _ args) env_ids = do
     let env_ty = mkBigCoreVarTupTy env_ids
     core_op <- dsLExpr op
     (core_args, fv_sets) <- mapAndUnzipM (dsTrimCmdArg local_vars env_ids) args
index 0d9bbb4..d87d935 100644 (file)
@@ -37,7 +37,6 @@ import TysPrim
 import TyCon
 import TysWiredIn
 import BasicTypes
-import FastString ( unpackFS )
 import Literal
 import PrelNames
 import DynFlags
@@ -95,7 +94,7 @@ dsCCall lbl args may_gc result_ty
        uniq <- newUnique
        dflags <- getDynFlags
        let
-           target = StaticTarget (unpackFS lbl) lbl Nothing True
+           target = StaticTarget NoSourceText lbl Nothing True
            the_fcall    = CCall (CCallSpec target CCallConv may_gc)
            the_prim_app = mkFCall dflags uniq the_fcall unboxed_args ccall_result_ty
        return (foldr ($) (res_wrapper the_prim_app) arg_wrappers)
index 981745e..b7ea8ab 100644 (file)
@@ -218,7 +218,7 @@ dsFCall fn_id co fcall mDeclHeader = do
                                CApiConv safety) ->
                do wrapperName <- mkWrapperName "ghc_wrapper" (unpackFS cName)
                   let fcall' = CCall (CCallSpec
-                                      (StaticTarget (unpackFS wrapperName)
+                                      (StaticTarget NoSourceText
                                                     wrapperName mUnitId
                                                     True)
                                       CApiConv safety)
index 556fbf9..ee64fa7 100644 (file)
@@ -944,7 +944,7 @@ repTy :: HsType Name -> DsM (Core TH.TypeQ)
 repTy ty@(HsForAllTy {}) = repForall ty
 repTy ty@(HsQualTy {})   = repForall ty
 
-repTy (HsTyVar (L _ n))
+repTy (HsTyVar (L _ n))
   | isTvOcc occ   = do tv1 <- lookupOcc n
                        repTvar tv1
   | isDataOcc occ = do tc1 <- lookupOcc n
@@ -970,7 +970,8 @@ repTy (HsListTy t)          = do
                                 repTapp tcon t1
 repTy (HsPArrTy t)     = do
                            t1   <- repLTy t
-                           tcon <- repTy (HsTyVar (noLoc (tyConName parrTyCon)))
+                           tcon <- repTy (HsTyVar NotPromoted
+                                                  (noLoc (tyConName parrTyCon)))
                            repTapp tcon t1
 repTy (HsTupleTy HsUnboxedTuple tys) = do
                                 tys1 <- repLTys tys
@@ -995,7 +996,7 @@ repTy (HsKindSig t k)       = do
                                 k1 <- repLKind k
                                 repTSig t1 k1
 repTy (HsSpliceTy splice _)     = repSplice splice
-repTy (HsExplicitListTy _ tys)  = do
+repTy (HsExplicitListTy _ _ tys) = do
                                     tys1 <- repLTys tys
                                     repTPromotedList tys1
 repTy (HsExplicitTupleTy _ tys) = do
@@ -1041,7 +1042,7 @@ repNonArrowLKind :: LHsKind Name -> DsM (Core TH.Kind)
 repNonArrowLKind (L _ ki) = repNonArrowKind ki
 
 repNonArrowKind :: HsKind Name -> DsM (Core TH.Kind)
-repNonArrowKind (HsTyVar (L _ name))
+repNonArrowKind (HsTyVar (L _ name))
   | isLiftedTypeKindTyConName name       = repKStar
   | name `hasKey` constraintKindTyConKey = repKConstraint
   | isTvOcc (nameOccName name)      = lookupOcc name >>= repKVar
@@ -1073,10 +1074,10 @@ repRole (L _ Nothing)                 = rep2 inferRName []
 repSplice :: HsSplice Name -> DsM (Core a)
 -- See Note [How brackets and nested splices are handled] in TcSplice
 -- We return a CoreExpr of any old type; the context should know
-repSplice (HsTypedSplice   n _)  = rep_splice n
-repSplice (HsUntypedSplice n _)  = rep_splice n
-repSplice (HsQuasiQuote n _ _ _) = rep_splice n
-repSplice e@(HsSpliced _ _)      = pprPanic "repSplice" (ppr e)
+repSplice (HsTypedSplice   _ n _) = rep_splice n
+repSplice (HsUntypedSplice _ n _) = rep_splice n
+repSplice (HsQuasiQuote n _ _ _)  = rep_splice n
+repSplice e@(HsSpliced _ _)       = pprPanic "repSplice" (ppr e)
 
 rep_splice :: Name -> DsM (Core a)
 rep_splice splice_name
@@ -2345,15 +2346,15 @@ repLiteral lit
 
 mk_integer :: Integer -> DsM HsLit
 mk_integer  i = do integer_ty <- lookupType integerTyConName
-                   return $ HsInteger "" i integer_ty
+                   return $ HsInteger NoSourceText i integer_ty
 mk_rational :: FractionalLit -> DsM HsLit
 mk_rational r = do rat_ty <- lookupType rationalTyConName
                    return $ HsRat r rat_ty
 mk_string :: FastString -> DsM HsLit
-mk_string s = return $ HsString "" s
+mk_string s = return $ HsString NoSourceText s
 
 mk_char :: Char -> DsM HsLit
-mk_char c = return $ HsChar "" c
+mk_char c = return $ HsChar NoSourceText c
 
 repOverloadedLiteral :: HsOverLit Name -> DsM (Core TH.Lit)
 repOverloadedLiteral (OverLit { ol_val = val})
index c66021f..9849eec 100644 (file)
@@ -291,11 +291,11 @@ tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _eq outer_ty
         --     which might be ok if we have 'instance IsString Int'
         --
   | not type_change, isIntTy ty,    Just int_lit <- mb_int_lit
-                            = mk_con_pat intDataCon    (HsIntPrim    "" int_lit)
+                 = mk_con_pat intDataCon    (HsIntPrim    NoSourceText int_lit)
   | not type_change, isWordTy ty,   Just int_lit <- mb_int_lit
-                            = mk_con_pat wordDataCon   (HsWordPrim   "" int_lit)
+                 = mk_con_pat wordDataCon   (HsWordPrim   NoSourceText int_lit)
   | not type_change, isStringTy ty, Just str_lit <- mb_str_lit
-                            = tidy_lit_pat (HsString "" str_lit)
+                 = tidy_lit_pat (HsString NoSourceText str_lit)
      -- NB: do /not/ convert Float or Double literals to F# 3.8 or D# 5.3
      -- If we do convert to the constructor form, we'll generate a case
      -- expression on a Float# or Double# and that's not allowed in Core; see
index 6bb7199..2c863c7 100644 (file)
@@ -39,8 +39,6 @@ import MonadUtils ( foldrM )
 import qualified Data.ByteString as BS
 import Control.Monad( unless, liftM, ap )
 
-import Data.Char ( chr )
-import Data.Word ( Word8 )
 import Data.Maybe( catMaybes, fromMaybe, isNothing )
 import Language.Haskell.TH as TH hiding (sigP)
 import Language.Haskell.TH.Syntax as TH
@@ -268,10 +266,10 @@ cvtDec (InstanceD o ctxt ty decs)
   where
   overlap pragma =
     case pragma of
-      TH.Overlaps      -> Hs.Overlaps     "OVERLAPS"
-      TH.Overlappable  -> Hs.Overlappable "OVERLAPPABLE"
-      TH.Overlapping   -> Hs.Overlapping  "OVERLAPPING"
-      TH.Incoherent    -> Hs.Incoherent   "INCOHERENT"
+      TH.Overlaps      -> Hs.Overlaps     (SourceText "OVERLAPS")
+      TH.Overlappable  -> Hs.Overlappable (SourceText "OVERLAPPABLE")
+      TH.Overlapping   -> Hs.Overlapping  (SourceText "OVERLAPPING")
+      TH.Incoherent    -> Hs.Incoherent   (SourceText "INCOHERENT")
 
 
 
@@ -550,7 +548,7 @@ cvt_arg (Bang su ss, ty)
   = do { ty' <- cvtType ty
        ; let su' = cvtSrcUnpackedness su
        ; let ss' = cvtSrcStrictness ss
-       ; returnL $ HsBangTy (HsSrcBang Nothing su' ss') ty' }
+       ; returnL $ HsBangTy (HsSrcBang NoSourceText su' ss') ty' }
 
 cvt_id_arg :: (TH.Name, TH.Bang, TH.Type) -> CvtM (LConDeclField RdrName)
 cvt_id_arg (i, str, ty)
@@ -582,12 +580,13 @@ cvtForD (ImportF callconv safety from nm ty)
   -- and are inserted verbatim, analogous to mkImport in RdrHsSyn
   | callconv == TH.Prim || callconv == TH.JavaScript
   = mk_imp (CImport (noLoc (cvt_conv callconv)) (noLoc safety') Nothing
-                    (CFunction (StaticTarget from (mkFastString from) Nothing
+                    (CFunction (StaticTarget (SourceText from)
+                                             (mkFastString from) Nothing
                                              True))
-                    (noLoc from))
+                    (noLoc $ quotedSourceText from))
   | Just impspec <- parseCImport (noLoc (cvt_conv callconv)) (noLoc safety')
                                  (mkFastString (TH.nameBase nm))
-                                 from (noLoc from)
+                                 from (noLoc $ quotedSourceText from)
   = mk_imp impspec
   | otherwise
   = failWith $ text (show from) <+> text "is not a valid ccall impent"
@@ -608,10 +607,10 @@ cvtForD (ImportF callconv safety from nm ty)
 cvtForD (ExportF callconv as nm ty)
   = do  { nm' <- vNameL nm
         ; ty' <- cvtType ty
-        ; let e = CExport (noLoc (CExportStatic as
+        ; let e = CExport (noLoc (CExportStatic (SourceText as)
                                                 (mkFastString as)
                                                 (cvt_conv callconv)))
-                                                (noLoc as)
+                                                (noLoc (SourceText as))
         ; return $ ForeignExport { fd_name = nm'
                                  , fd_sig_ty = mkLHsSigType ty'
                                  , fd_co = noForeignExportCoercionYet
@@ -632,7 +631,10 @@ cvtPragmaD :: Pragma -> CvtM (Maybe (LHsDecl RdrName))
 cvtPragmaD (InlineP nm inline rm phases)
   = do { nm' <- vNameL nm
        ; let dflt = dfltActivation inline
-       ; let ip   = InlinePragma { inl_src    = "{-# INLINE"
+       ; let src TH.NoInline  = "{-# NOINLINE"
+             src TH.Inline    = "{-# INLINE"
+             src TH.Inlinable = "{-# INLINABLE"
+       ; let ip   = InlinePragma { inl_src    = SourceText $ src inline
                                  , inl_inline = cvtInline inline
                                  , inl_rule   = cvtRuleMatch rm
                                  , inl_act    = cvtPhases phases dflt
@@ -642,10 +644,15 @@ cvtPragmaD (InlineP nm inline rm phases)
 cvtPragmaD (SpecialiseP nm ty inline phases)
   = do { nm' <- vNameL nm
        ; ty' <- cvtType ty
-       ; let (inline', dflt) = case inline of
-               Just inline1 -> (cvtInline inline1, dfltActivation inline1)
-               Nothing      -> (EmptyInlineSpec,   AlwaysActive)
-       ; let ip = InlinePragma { inl_src    = "{-# INLINE"
+       ; let src TH.NoInline  = "{-# SPECIALISE NOINLINE"
+             src TH.Inline    = "{-# SPECIALISE INLINE"
+             src TH.Inlinable = "{-# SPECIALISE INLINE"
+       ; let (inline', dflt,srcText) = case inline of
+               Just inline1 -> (cvtInline inline1, dfltActivation inline1,
+                                src inline1)
+               Nothing      -> (EmptyInlineSpec,   AlwaysActive,
+                                "{-# SPECIALISE")
+       ; let ip = InlinePragma { inl_src    = SourceText srcText
                                , inl_inline = inline'
                                , inl_rule   = Hs.FunLike
                                , inl_act    = cvtPhases phases dflt
@@ -655,7 +662,7 @@ cvtPragmaD (SpecialiseP nm ty inline phases)
 cvtPragmaD (SpecialiseInstP ty)
   = do { ty' <- cvtType ty
        ; returnJustL $ Hs.SigD $
-         SpecInstSig "{-# SPECIALISE" (mkLHsSigType ty') }
+         SpecInstSig (SourceText "{-# SPECIALISE") (mkLHsSigType ty') }
 
 cvtPragmaD (RuleP nm bndrs lhs rhs phases)
   = do { let nm' = mkFastString nm
@@ -664,7 +671,8 @@ cvtPragmaD (RuleP nm bndrs lhs rhs phases)
        ; lhs'   <- cvtl lhs
        ; rhs'   <- cvtl rhs
        ; returnJustL $ Hs.RuleD
-            $ HsRules "{-# RULES" [noLoc $ HsRule (noLoc (nm,nm')) act bndrs'
+            $ HsRules (SourceText "{-# RULES")
+                      [noLoc $ HsRule (noLoc (SourceText nm,nm')) act bndrs'
                                                   lhs' placeHolderNames
                                                   rhs' placeHolderNames]
        }
@@ -679,7 +687,8 @@ cvtPragmaD (AnnP target exp)
          ValueAnnotation n -> do
            n' <- vcName n
            return (ValueAnnProvenance (noLoc n'))
-       ; returnJustL $ Hs.AnnD $ HsAnnotation "{-# ANN" target' exp'
+       ; returnJustL $ Hs.AnnD $ HsAnnotation (SourceText "{-# ANN") target'
+                                               exp'
        }
 
 cvtPragmaD (LineP line file)
@@ -702,8 +711,8 @@ cvtRuleMatch TH.FunLike = Hs.FunLike
 
 cvtPhases :: TH.Phases -> Activation -> Activation
 cvtPhases AllPhases       dflt = dflt
-cvtPhases (FromPhase i)   _    = ActiveAfter (show i) i
-cvtPhases (BeforePhase i) _    = ActiveBefore (show i) i
+cvtPhases (FromPhase i)   _    = ActiveAfter NoSourceText i
+cvtPhases (BeforePhase i) _    = ActiveBefore NoSourceText i
 
 cvtRuleBndr :: TH.RuleBndr -> CvtM (Hs.LRuleBndr RdrName)
 cvtRuleBndr (RuleVar n)
@@ -980,13 +989,13 @@ cvtpair (PatG gs,rhs)    = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs
 
 cvtOverLit :: Lit -> CvtM (HsOverLit RdrName)
 cvtOverLit (IntegerL i)
-  = do { force i; return $ mkHsIntegral (show i) i placeHolderType}
+  = do { force i; return $ mkHsIntegral NoSourceText i placeHolderType}
 cvtOverLit (RationalL r)
   = do { force r; return $ mkHsFractional (cvtFractionalLit r) placeHolderType}
 cvtOverLit (StringL s)
   = do { let { s' = mkFastString s }
        ; force s'
-       ; return $ mkHsIsString s s' placeHolderType
+       ; return $ mkHsIsString (quotedSourceText s) s' placeHolderType
        }
 cvtOverLit _ = panic "Convert.cvtOverLit: Unexpected overloaded literal"
 -- An Integer is like an (overloaded) '3' in a Haskell source program
@@ -1014,25 +1023,25 @@ allCharLs xs
     go _  _                     = Nothing
 
 cvtLit :: Lit -> CvtM HsLit
-cvtLit (IntPrimL i)    = do { force i; return $ HsIntPrim (show i) i }
-cvtLit (WordPrimL w)   = do { force w; return $ HsWordPrim (show w) w }
+cvtLit (IntPrimL i)    = do { force i; return $ HsIntPrim NoSourceText i }
+cvtLit (WordPrimL w)   = do { force w; return $ HsWordPrim NoSourceText w }
 cvtLit (FloatPrimL f)  = do { force f; return $ HsFloatPrim (cvtFractionalLit f) }
 cvtLit (DoublePrimL f) = do { force f; return $ HsDoublePrim (cvtFractionalLit f) }
-cvtLit (CharL c)       = do { force c; return $ HsChar (show c) c }
-cvtLit (CharPrimL c)   = do { force c; return $ HsCharPrim (show c) c }
+cvtLit (CharL c)       = do { force c; return $ HsChar NoSourceText c }
+cvtLit (CharPrimL c)   = do { force c; return $ HsCharPrim NoSourceText c }
 cvtLit (StringL s)     = do { let { s' = mkFastString s }
                             ; force s'
-                            ; return $ HsString s s' }
+                            ; return $ HsString (quotedSourceText s) s' }
 cvtLit (StringPrimL s) = do { let { s' = BS.pack s }
                             ; force s'
-                            ; return $ HsStringPrim (w8ToString s) s' }
+                            ; return $ HsStringPrim NoSourceText s' }
 cvtLit _ = panic "Convert.cvtLit: Unexpected literal"
         -- cvtLit should not be called on IntegerL, RationalL
         -- That precondition is established right here in
         -- Convert.hs, hence panic
 
-w8ToString :: [Word8] -> String
-w8ToString ws = map (\w -> chr (fromIntegral w)) ws
+quotedSourceText :: String -> SourceText
+quotedSourceText s = SourceText $ "\"" ++ s ++ "\""
 
 cvtPats :: [TH.Pat] -> CvtM [Hs.LPat RdrName]
 cvtPats pats = mapM cvtPat pats
@@ -1153,13 +1162,14 @@ cvtTypeKind ty_str ty
              | n == 1
              -> failWith (ptext (sLit ("Illegal 1-tuple " ++ ty_str ++ " constructor")))
              | otherwise
-             -> mk_apps (HsTyVar (noLoc (getRdrName (tupleTyCon Boxed n)))) tys'
+             -> mk_apps (HsTyVar NotPromoted
+                               (noLoc (getRdrName (tupleTyCon Boxed n)))) tys'
            UnboxedTupleT n
              | length tys' == n         -- Saturated
              -> returnL (HsTupleTy HsUnboxedTuple tys')
              | otherwise
-             -> mk_apps (HsTyVar (noLoc (getRdrName (tupleTyCon Unboxed n))))
-                        tys'
+             -> mk_apps (HsTyVar NotPromoted
+                             (noLoc (getRdrName (tupleTyCon Unboxed n)))) tys'
            UnboxedSumT n
              | n < 2
             -> failWith $
@@ -1169,18 +1179,22 @@ cvtTypeKind ty_str ty
              | length tys' == n -- Saturated
              -> returnL (HsSumTy tys')
              | otherwise
-             -> mk_apps (HsTyVar (noLoc (getRdrName (sumTyCon n)))) tys'
+             -> mk_apps (HsTyVar NotPromoted (noLoc (getRdrName (sumTyCon n))))
+                        tys'
            ArrowT
              | [x',y'] <- tys' -> returnL (HsFunTy x' y')
-             | otherwise -> mk_apps (HsTyVar (noLoc (getRdrName funTyCon))) tys'
+             | otherwise ->
+                  mk_apps (HsTyVar NotPromoted (noLoc (getRdrName funTyCon)))
+                          tys'
            ListT
              | [x']    <- tys' -> returnL (HsListTy x')
-             | otherwise
-                        -> mk_apps (HsTyVar (noLoc (getRdrName listTyCon))) tys'
+             | otherwise ->
+                  mk_apps (HsTyVar NotPromoted (noLoc (getRdrName listTyCon)))
+                           tys'
            VarT nm -> do { nm' <- tNameL nm
-                         ; mk_apps (HsTyVar nm') tys' }
+                         ; mk_apps (HsTyVar NotPromoted nm') tys' }
            ConT nm -> do { nm' <- tconName nm
-                         ; mk_apps (HsTyVar (noLoc nm')) tys' }
+                         ; mk_apps (HsTyVar NotPromoted (noLoc nm')) tys' }
 
            ForallT tvs cxt ty
              | null tys'
@@ -1213,7 +1227,7 @@ cvtTypeKind ty_str ty
              -> do { s'  <- tconName s
                    ; t1' <- cvtType t1
                    ; t2' <- cvtType t2
-                   ; mk_apps (HsTyVar (noLoc s')) [t1', t2']
+                   ; mk_apps (HsTyVar NotPromoted (noLoc s')) [t1', t2']
                    }
 
            UInfixT t1 s t2
@@ -1229,7 +1243,7 @@ cvtTypeKind ty_str ty
                    }
 
            PromotedT nm -> do { nm' <- cName nm
-                              ; mk_apps (HsTyVar (noLoc nm')) tys' }
+                              ; mk_apps (HsTyVar NotPromoted (noLoc nm')) tys' }
                  -- Promoted data constructor; hence cName
 
            PromotedTupleT n
@@ -1243,25 +1257,29 @@ cvtTypeKind ty_str ty
                m = length tys'
 
            PromotedNilT
-             -> returnL (HsExplicitListTy placeHolderKind [])
+             -> returnL (HsExplicitListTy Promoted placeHolderKind [])
 
            PromotedConsT  -- See Note [Representing concrete syntax in types]
                           -- in Language.Haskell.TH.Syntax
-             | [ty1, L _ (HsExplicitListTy _ tys2)] <- tys'
-             -> returnL (HsExplicitListTy placeHolderKind (ty1:tys2))
+             | [ty1, L _ (HsExplicitListTy ip _ tys2)] <- tys'
+             -> returnL (HsExplicitListTy ip placeHolderKind (ty1:tys2))
              | otherwise
-             -> mk_apps (HsTyVar (noLoc (getRdrName consDataCon))) tys'
+             -> mk_apps (HsTyVar NotPromoted (noLoc (getRdrName consDataCon)))
+                        tys'
 
            StarT
-             -> returnL (HsTyVar (noLoc (getRdrName liftedTypeKindTyCon)))
+             -> returnL (HsTyVar NotPromoted (noLoc
+                                              (getRdrName liftedTypeKindTyCon)))
 
            ConstraintT
-             -> returnL (HsTyVar (noLoc (getRdrName constraintKindTyCon)))
+             -> returnL (HsTyVar NotPromoted
+                              (noLoc (getRdrName constraintKindTyCon)))
 
            EqualityT
              | [x',y'] <- tys' -> returnL (HsEqTy x' y')
-             | otherwise
-                      -> mk_apps (HsTyVar (noLoc (getRdrName eqPrimTyCon))) tys'
+             | otherwise ->
+                   mk_apps (HsTyVar NotPromoted
+                            (noLoc (getRdrName eqPrimTyCon))) tys'
 
            _ -> failWith (ptext (sLit ("Malformed " ++ ty_str)) <+> text (show ty))
     }
@@ -1286,8 +1304,8 @@ split_ty_app ty = go ty []
     go f as           = return (f,as)
 
 cvtTyLit :: TH.TyLit -> HsTyLit
-cvtTyLit (TH.NumTyLit i) = HsNumTy (show i) i
-cvtTyLit (TH.StrTyLit s) = HsStrTy s        (fsLit s)
+cvtTyLit (TH.NumTyLit i) = HsNumTy NoSourceText i
+cvtTyLit (TH.StrTyLit s) = HsStrTy NoSourceText (fsLit s)
 
 {- | @cvtOpAppT x op y@ takes converted arguments and flattens any HsAppsTy
    structure in them.
@@ -1359,7 +1377,7 @@ cvtPatSynSigTy ty         = cvtType ty
 
 -----------------------------------------------------------
 cvtFixity :: TH.Fixity -> Hs.Fixity
-cvtFixity (TH.Fixity prec dir) = Hs.Fixity (show prec) prec (cvt_dir dir)
+cvtFixity (TH.Fixity prec dir) = Hs.Fixity NoSourceText prec (cvt_dir dir)
    where
      cvt_dir TH.InfixL = Hs.InfixL
      cvt_dir TH.InfixR = Hs.InfixR
index 4878592..eeb446e 100644 (file)
@@ -22,7 +22,7 @@ import {-# SOURCE #-} HsExpr ( pprExpr, LHsExpr,
                                GRHSs, pprPatBind )
 import {-# SOURCE #-} HsPat  ( LPat )
 
-import PlaceHolder ( PostTc,PostRn,DataId,OutputableBndrId )
+import PlaceHolder ( PostTc,PostRn,DataId,OutputableBndrId,HasOccNameId )
 import HsTypes
 import PprCore ()
 import CoreSyn
@@ -437,13 +437,15 @@ Specifically,
     it's just an error thunk
 -}
 
-instance (OutputableBndrId idL, OutputableBndrId idR)
+instance (OutputableBndrId idL, OutputableBndrId idR,
+          HasOccNameId idL, HasOccNameId idR)
         => Outputable (HsLocalBindsLR idL idR) where
   ppr (HsValBinds bs) = ppr bs
   ppr (HsIPBinds bs)  = ppr bs
   ppr EmptyLocalBinds = empty
 
-instance (OutputableBndrId idL, OutputableBndrId idR)
+instance (OutputableBndrId idL, OutputableBndrId idR,
+          HasOccNameId idL, HasOccNameId idR)
         => Outputable (HsValBindsLR idL idR) where
   ppr (ValBindsIn binds sigs)
    = pprDeclList (pprLHsBindsForUser binds sigs)
@@ -459,14 +461,16 @@ instance (OutputableBndrId idL, OutputableBndrId idR)
      pp_rec Recursive    = text "rec"
      pp_rec NonRecursive = text "nonrec"
 
-pprLHsBinds :: (OutputableBndrId idL, OutputableBndrId idR)
+pprLHsBinds :: (OutputableBndrId idL, OutputableBndrId idR,
+                HasOccNameId idL, HasOccNameId idR)
             => LHsBindsLR idL idR -> SDoc
 pprLHsBinds binds
   | isEmptyLHsBinds binds = empty
   | otherwise = pprDeclList (map ppr (bagToList binds))
 
 pprLHsBindsForUser :: (OutputableBndrId idL, OutputableBndrId idR,
-                       OutputableBndrId id2)
+                       OutputableBndrId id2, HasOccNameId id2,
+                       HasOccNameId idL, HasOccNameId idR)
                    => LHsBindsLR idL idR -> [LSig id2] -> [SDoc]
 --  pprLHsBindsForUser is different to pprLHsBinds because
 --  a) No braces: 'let' and 'where' include a list of HsBindGroups
@@ -504,6 +508,10 @@ isEmptyLocalBinds (HsValBinds ds) = isEmptyValBinds ds
 isEmptyLocalBinds (HsIPBinds ds)  = isEmptyIPBinds ds
 isEmptyLocalBinds EmptyLocalBinds = True
 
+eqEmptyLocalBinds :: HsLocalBindsLR a b -> Bool
+eqEmptyLocalBinds EmptyLocalBinds = True
+eqEmptyLocalBinds _               = False
+
 isEmptyValBinds :: HsValBindsLR a b -> Bool
 isEmptyValBinds (ValBindsIn ds sigs)  = isEmptyLHsBinds ds && null sigs
 isEmptyValBinds (ValBindsOut ds sigs) = null ds && null sigs
@@ -553,11 +561,13 @@ So the desugarer tries to do a better job:
                                       in (fm,gm)
 -}
 
-instance (OutputableBndrId idL, OutputableBndrId idR)
+instance (OutputableBndrId idL, OutputableBndrId idR,
+          HasOccNameId idL, HasOccNameId idR)
          => Outputable (HsBindLR idL idR) where
     ppr mbind = ppr_monobind mbind
 
-ppr_monobind :: (OutputableBndrId idL, OutputableBndrId idR)
+ppr_monobind :: (OutputableBndrId idL, OutputableBndrId idR,
+                 HasOccNameId idL,  HasOccNameId idR)
              => HsBindLR idL idR -> SDoc
 
 ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss })
@@ -613,7 +623,7 @@ instance (OutputableBndr id) => Outputable (ABExport id) where
            , nest 2 (pprTcSpecPrags prags)
            , nest 2 (text "wrap:" <+> ppr wrap)]
 
-instance (OutputableBndr idL, OutputableBndrId idR)
+instance (OutputableBndr idL, OutputableBndrId idR, HasOccNameId idR)
           => Outputable (PatSynBind idL idR) where
   ppr (PSB{ psb_id = (L _ psyn), psb_args = details, psb_def = pat,
             psb_dir = dir })
@@ -685,11 +695,12 @@ data IPBind id
   = IPBind (Either (Located HsIPName) id) (LHsExpr id)
 deriving instance (DataId name) => Data (IPBind name)
 
-instance (OutputableBndrId id) => Outputable (HsIPBinds id) where
+instance (OutputableBndrId id, HasOccNameId id)
+        => Outputable (HsIPBinds id) where
   ppr (IPBinds bs ds) = pprDeeperList vcat (map ppr bs)
                         $$ ifPprDebug (ppr ds)
 
-instance (OutputableBndrId id) => Outputable (IPBind id) where
+instance (OutputableBndrId id, HasOccNameId id) => Outputable (IPBind id) where
   ppr (IPBind lr rhs) = name <+> equals <+> pprExpr (unLoc rhs)
     where name = case lr of
                    Left (L _ ip) -> pprBndr LetBind ip
@@ -946,28 +957,36 @@ signatures. Since some of the signatures contain a list of names, testing for
 equality is not enough -- we have to check if they overlap.
 -}
 
-instance (OutputableBndrId name) => Outputable (Sig name) where
+instance (OutputableBndrId name, HasOccNameId name)
+       => Outputable (Sig name) where
     ppr sig = ppr_sig sig
 
-ppr_sig :: (OutputableBndrId name) => Sig name -> SDoc
+ppr_sig :: (OutputableBndrId name, HasOccNameId name) => Sig name -> SDoc
 ppr_sig (TypeSig vars ty)    = pprVarSig (map unLoc vars) (ppr ty)
 ppr_sig (ClassOpSig is_deflt vars ty)
   | is_deflt                 = text "default" <+> pprVarSig (map unLoc vars) (ppr ty)
   | otherwise                = pprVarSig (map unLoc vars) (ppr ty)
 ppr_sig (IdSig id)           = pprVarSig [id] (ppr (varType id))
 ppr_sig (FixSig fix_sig)     = ppr fix_sig
-ppr_sig (SpecSig var ty inl)
-  = pragBrackets (pprSpec (unLoc var) (interpp'SP ty) inl)
-ppr_sig (InlineSig var inl)       = pragBrackets (ppr inl <+> pprPrefixOcc (unLoc var))
-ppr_sig (SpecInstSig _ ty)
-  = pragBrackets (text "SPECIALIZE instance" <+> ppr ty)
+ppr_sig (SpecSig var ty inl@(InlinePragma { inl_inline = spec }))
+  = pragSrcBrackets (inl_src inl) pragmaSrc (pprSpec (unLoc var)
+                                             (interpp'SP ty) inl)
+    where
+      pragmaSrc = case spec of
+        EmptyInlineSpec -> "{-# SPECIALISE"
+        _               -> "{-# SPECIALISE_INLINE"
+ppr_sig (InlineSig var inl)
+  = pragSrcBrackets (inl_src inl) "{-# INLINE"  (pprInline inl
+                                   <+> pprPrefixOcc (unLoc var))
+ppr_sig (SpecInstSig src ty)
+  = pragSrcBrackets src "{-# SPECIALISE" (text "instance" <+> ppr ty)
 ppr_sig (MinimalSig _ bf)         = pragBrackets (pprMinimalSig bf)
 ppr_sig (PatSynSig names sig_ty)
   = text "pattern" <+> pprVarSig (map unLoc names) (ppr sig_ty)
 ppr_sig (SCCFunSig _ fn Nothing)
   = pragBrackets (text "SCC" <+> ppr fn)
-ppr_sig (SCCFunSig _ fn (Just str))
-  = pragBrackets (text "SCC" <+> ppr fn <+> ppr (sl_st str))
+ppr_sig (SCCFunSig src fn (Just str))
+  = pragSrcBrackets  src "{-# SCC#-}" (ppr fn <+> ppr str)
 
 instance OutputableBndr name => Outputable (FixitySig name) where
   ppr (FixitySig names fixity) = sep [ppr fixity, pprops]
@@ -975,7 +994,13 @@ instance OutputableBndr name => Outputable (FixitySig name) where
       pprops = hsep $ punctuate comma (map (pprInfixOcc . unLoc) names)
 
 pragBrackets :: SDoc -> SDoc
-pragBrackets doc = text "{-#" <+> doc <+> ptext (sLit "#-}")
+pragBrackets doc = text "{-#" <+> doc <+> text "#-}"
+
+-- | Using SourceText in case the pragma was spelled differently or used mixed
+-- case
+pragSrcBrackets :: SourceText -> String -> SDoc -> SDoc
+pragSrcBrackets (SourceText src) _   doc = text src <+> doc <+> text "#-}"
+pragSrcBrackets NoSourceText     alt doc = text alt <+> doc <+> text "#-}"
 
 pprVarSig :: (OutputableBndr id) => [id] -> SDoc -> SDoc
 pprVarSig vars pp_ty = sep [pprvars <+> dcolon, nest 2 pp_ty]
@@ -983,19 +1008,21 @@ pprVarSig vars pp_ty = sep [pprvars <+> dcolon, nest 2 pp_ty]
     pprvars = hsep $ punctuate comma (map pprPrefixOcc vars)
 
 pprSpec :: (OutputableBndr id) => id -> SDoc -> InlinePragma -> SDoc
-pprSpec var pp_ty inl = text "SPECIALIZE" <+> pp_inl <+> pprVarSig [var] pp_ty
+pprSpec var pp_ty inl = pp_inl <+> pprVarSig [var] pp_ty
   where
     pp_inl | isDefaultInlinePragma inl = empty
-           | otherwise = ppr inl
+           | otherwise = pprInline inl
 
 pprTcSpecPrags :: TcSpecPrags -> SDoc
 pprTcSpecPrags IsDefaultMethod = text "<default method>"
 pprTcSpecPrags (SpecPrags ps)  = vcat (map (ppr . unLoc) ps)
 
 instance Outputable TcSpecPrag where
-  ppr (SpecPrag var _ inl) = pprSpec var (text "<type>") inl
+  ppr (SpecPrag var _ inl)
+    = text "SPECIALIZE" <+> pprSpec var (text "<type>") inl
 
-pprMinimalSig :: OutputableBndr name => LBooleanFormula (Located name) -> SDoc
+pprMinimalSig :: (OutputableBndr name, HasOccName name)
+              => LBooleanFormula (Located name) -> SDoc
 pprMinimalSig (L _ bf) = text "MINIMAL" <+> ppr (fmap unLoc bf)
 
 {-
index 0d6bbf6..c82cd8b 100644 (file)
@@ -86,7 +86,8 @@ module HsDecls (
     ) where
 
 -- friends:
-import {-# SOURCE #-}   HsExpr( LHsExpr, HsExpr, HsSplice, pprExpr, pprSplice )
+import {-# SOURCE #-}   HsExpr( LHsExpr, HsExpr, HsSplice, pprExpr,
+                                pprSpliceDecl )
         -- Because Expr imports Decls via HsBracket
 
 import HsBinds
@@ -97,7 +98,8 @@ import Name
 import BasicTypes
 import Coercion
 import ForeignCall
-import PlaceHolder ( PostTc,PostRn,PlaceHolder(..),DataId, OutputableBndrId )
+import PlaceHolder ( PostTc,PostRn,PlaceHolder(..),DataId, OutputableBndrId,
+                     HasOccNameId )
 import NameSet
 
 -- others:
@@ -250,7 +252,8 @@ appendGroups
         hs_vects  = vects1 ++ vects2,
         hs_docs   = docs1  ++ docs2 }
 
-instance (OutputableBndrId name) => Outputable (HsDecl name) where
+instance (OutputableBndrId name, HasOccNameId name)
+        => Outputable (HsDecl name) where
     ppr (TyClD dcl)             = ppr dcl
     ppr (ValD binds)            = ppr binds
     ppr (DefD def)              = ppr def
@@ -266,7 +269,8 @@ instance (OutputableBndrId name) => Outputable (HsDecl name) where
     ppr (DocD doc)              = ppr doc
     ppr (RoleAnnotD ra)         = ppr ra
 
-instance (OutputableBndrId name) => Outputable (HsGroup name) where
+instance (OutputableBndrId name, HasOccNameId name)
+        => Outputable (HsGroup name) where
     ppr (HsGroup { hs_valds  = val_decls,
                    hs_tyclds = tycl_decls,
                    hs_derivds = deriv_decls,
@@ -300,10 +304,6 @@ instance (OutputableBndrId name) => Outputable (HsGroup name) where
           vcat_mb gap (Nothing : ds) = vcat_mb gap ds
           vcat_mb gap (Just d  : ds) = gap $$ d $$ vcat_mb blankLine ds
 
-data SpliceExplicitFlag = ExplicitSplice | -- <=> $(f x y)
-                          ImplicitSplice   -- <=> f x y,  i.e. a naked top level expression
-    deriving Data
-
 -- | Located Splice Declaration
 type LSpliceDecl name = Located (SpliceDecl name)
 
@@ -314,8 +314,9 @@ data SpliceDecl id
         SpliceExplicitFlag
 deriving instance (DataId id) => Data (SpliceDecl id)
 
-instance (OutputableBndrId name) => Outputable (SpliceDecl name) where
-   ppr (SpliceDecl (L _ e) _) = pprSplice e
+instance (OutputableBndrId name, HasOccNameId name)
+        => Outputable (SpliceDecl name) where
+   ppr (SpliceDecl (L _ e) f) = pprSpliceDecl e f
 
 {-
 ************************************************************************
@@ -632,7 +633,8 @@ hsDeclHasCusk (ClassDecl { tcdTyVars = tyvars }) = hsTvbAllKinded tyvars
 -- Pretty-printing TyClDecl
 -- ~~~~~~~~~~~~~~~~~~~~~~~~
 
-instance (OutputableBndrId name) => Outputable (TyClDecl name) where
+instance (OutputableBndrId name, HasOccNameId name)
+       => Outputable (TyClDecl name) where
 
     ppr (FamDecl { tcdFam = decl }) = ppr decl
     ppr (SynDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdRhs = rhs })
@@ -660,7 +662,8 @@ instance (OutputableBndrId name) => Outputable (TyClDecl name) where
                      <+> pp_vanilla_decl_head lclas tyvars (unLoc context)
                      <+> pprFundeps (map unLoc fds)
 
-instance (OutputableBndrId name) => Outputable (TyClGroup name) where
+instance (OutputableBndrId name, HasOccNameId name)
+        => Outputable (TyClGroup name) where
   ppr (TyClGroup { group_tyclds = tyclds
                  , group_roles = roles
                  , group_instds = instds
@@ -670,13 +673,21 @@ instance (OutputableBndrId name) => Outputable (TyClGroup name) where
       ppr roles $$
       ppr instds
 
-pp_vanilla_decl_head :: (OutputableBndrId name)
+pp_vanilla_decl_head :: (OutputableBndrId name, HasOccNameId name)
    => Located name
    -> LHsQTyVars name
    -> HsContext name
    -> SDoc
-pp_vanilla_decl_head thing tyvars context
- = hsep [pprHsContext context, pprPrefixOcc (unLoc thing), ppr tyvars]
+pp_vanilla_decl_head thing (HsQTvs { hsq_explicit = tyvars }) context
+ = hsep [pprHsContext context, pp_tyvars tyvars]
+  where
+    pp_tyvars (varl:varsr)
+      | isSymOcc $ occName (unLoc thing)
+         = hsep [ppr (unLoc varl), pprInfixOcc (unLoc thing)
+         , hsep (map (ppr.unLoc) varsr)]
+      | otherwise = hsep [ pprPrefixOcc (unLoc thing)
+                  , hsep (map (ppr.unLoc) (varl:varsr))]
+    pp_tyvars [] = ppr thing
 
 pprTyClDeclFlavour :: TyClDecl a -> SDoc
 pprTyClDeclFlavour (ClassDecl {})   = text "class"
@@ -944,10 +955,11 @@ resultVariableName :: FamilyResultSig a -> Maybe a
 resultVariableName (TyVarSig sig) = Just $ hsLTyVarName sig
 resultVariableName _              = Nothing
 
-instance (OutputableBndrId name) => Outputable (FamilyDecl name) where
+instance (OutputableBndrId name, HasOccNameId name)
+        => Outputable (FamilyDecl name) where
   ppr = pprFamilyDecl TopLevel
 
-pprFamilyDecl :: (OutputableBndrId name)
+pprFamilyDecl :: (OutputableBndrId name, HasOccNameId name)
               => TopLevelFlag -> FamilyDecl name -> SDoc
 pprFamilyDecl top_level (FamilyDecl { fdInfo = info, fdLName = ltycon
                                     , fdTyVars = tyvars
@@ -1064,12 +1076,20 @@ data HsDerivingClause name
     }
 deriving instance (DataId id) => Data (HsDerivingClause id)
 
-instance (OutputableBndrId name) => Outputable (HsDerivingClause name) where
+instance (OutputableBndrId name, HasOccNameId name)
+       => Outputable (HsDerivingClause name) where
   ppr (HsDerivingClause { deriv_clause_strategy = dcs
                         , deriv_clause_tys      = L _ dct })
     = hsep [ text "deriving"
            , ppDerivStrategy dcs
-           , parens (interpp'SP dct) ]
+           , pp_dct dct ]
+      where
+        -- This complexity is to distinguish between
+        --    deriving Show
+        --    deriving (Show)
+        pp_dct [a@(HsIB _ (L _ HsAppsTy{}))] = parens (ppr a)
+        pp_dct [a] = ppr a
+        pp_dct _   = parens (interpp'SP dct)
 
 data NewOrData
   = NewType                     -- ^ @newtype Blah ...@
@@ -1173,42 +1193,51 @@ hsConDeclArgTys (PrefixCon tys)    = tys
 hsConDeclArgTys (InfixCon ty1 ty2) = [ty1,ty2]
 hsConDeclArgTys (RecCon flds)      = map (cd_fld_type . unLoc) (unLoc flds)
 
-pp_data_defn :: (OutputableBndrId name)
+pp_data_defn :: (OutputableBndrId name, HasOccNameId name)
                   => (HsContext name -> SDoc)   -- Printing the header
                   -> HsDataDefn name
                   -> SDoc
 pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = L _ context
+                                , dd_cType = mb_ct
                                 , dd_kindSig = mb_sig
                                 , dd_cons = condecls, dd_derivs = derivings })
   | null condecls
-  = ppr new_or_data <+> pp_hdr context <+> pp_sig
+  = ppr new_or_data <+> pp_ct <+> pp_hdr context <+> pp_sig
+    <+> pp_derivings derivings
 
   | otherwise
-  = hang (ppr new_or_data <+> pp_hdr context <+> pp_sig)
+  = hang (ppr new_or_data <+> pp_ct  <+> pp_hdr context <+> pp_sig)
        2 (pp_condecls condecls $$ pp_derivings derivings)
   where
+    pp_ct = case mb_ct of
+               Nothing   -> empty
+               Just ct -> ppr ct
     pp_sig = case mb_sig of
                Nothing   -> empty
                Just kind -> dcolon <+> ppr kind
     pp_derivings (L _ ds) = vcat (map ppr ds)
 
-instance (OutputableBndrId name) => Outputable (HsDataDefn name) where
+instance (OutputableBndrId name, HasOccNameId name)
+       => Outputable (HsDataDefn name) where
    ppr d = pp_data_defn (\_ -> text "Naked HsDataDefn") d
 
 instance Outputable NewOrData where
   ppr NewType  = text "newtype"
   ppr DataType = text "data"
 
-pp_condecls :: (OutputableBndrId name) => [LConDecl name] -> SDoc
+pp_condecls :: (OutputableBndrId name, HasOccNameId name)
+            => [LConDecl name] -> SDoc
 pp_condecls cs@(L _ ConDeclGADT{} : _) -- In GADT syntax
   = hang (text "where") 2 (vcat (map ppr cs))
 pp_condecls cs                    -- In H98 syntax
   = equals <+> sep (punctuate (text " |") (map ppr cs))
 
-instance (OutputableBndrId name) => Outputable (ConDecl name) where
+instance (OutputableBndrId name, HasOccNameId name)
+       => Outputable (ConDecl name) where
     ppr = pprConDecl
 
-pprConDecl :: (OutputableBndrId name) => ConDecl name -> SDoc
+pprConDecl :: (OutputableBndrId name, HasOccNameId name)
+           => ConDecl name -> SDoc
 pprConDecl (ConDeclH98 { con_name = L _ con
                        , con_qvars = mtvs
                        , con_cxt = mcxt
@@ -1411,10 +1440,11 @@ data InstDecl name  -- Both class and family instances
       { tfid_inst :: TyFamInstDecl name }
 deriving instance (DataId id) => Data (InstDecl id)
 
-instance (OutputableBndrId name) => Outputable (TyFamInstDecl name) where
+instance (OutputableBndrId name, HasOccNameId name)
+       => Outputable (TyFamInstDecl name) where
   ppr = pprTyFamInstDecl TopLevel
 
-pprTyFamInstDecl :: (OutputableBndrId name)
+pprTyFamInstDecl :: (OutputableBndrId name, HasOccNameId name)
                  => TopLevelFlag -> TyFamInstDecl name -> SDoc
 pprTyFamInstDecl top_lvl (TyFamInstDecl { tfid_eqn = eqn })
    = text "type" <+> ppr_instance_keyword top_lvl <+> ppr_fam_inst_eqn eqn
@@ -1423,22 +1453,25 @@ ppr_instance_keyword :: TopLevelFlag -> SDoc
 ppr_instance_keyword TopLevel    = text "instance"
 ppr_instance_keyword NotTopLevel = empty
 
-ppr_fam_inst_eqn :: (OutputableBndrId name) => LTyFamInstEqn name -> SDoc
+ppr_fam_inst_eqn :: (OutputableBndrId name, HasOccNameId name)
+                 => LTyFamInstEqn name -> SDoc
 ppr_fam_inst_eqn (L _ (TyFamEqn { tfe_tycon = tycon
                                 , tfe_pats  = pats
                                 , tfe_rhs   = rhs }))
     = pp_fam_inst_lhs tycon pats [] <+> equals <+> ppr rhs
 
-ppr_fam_deflt_eqn :: (OutputableBndrId name) => LTyFamDefltEqn name -> SDoc
+ppr_fam_deflt_eqn :: (OutputableBndrId name, HasOccNameId name)
+                  => LTyFamDefltEqn name -> SDoc
 ppr_fam_deflt_eqn (L _ (TyFamEqn { tfe_tycon = tycon
                                  , tfe_pats  = tvs
                                  , tfe_rhs   = rhs }))
     = text "type" <+> pp_vanilla_decl_head tycon tvs [] <+> equals <+> ppr rhs
 
-instance (OutputableBndrId name) => Outputable (DataFamInstDecl name) where
+instance (OutputableBndrId name, HasOccNameId name)
+       => Outputable (DataFamInstDecl name) where
   ppr = pprDataFamInstDecl TopLevel
 
-pprDataFamInstDecl :: (OutputableBndrId name)
+pprDataFamInstDecl :: (OutputableBndrId name, HasOccNameId name)
                    => TopLevelFlag -> DataFamInstDecl name -> SDoc
 pprDataFamInstDecl top_lvl (DataFamInstDecl { dfid_tycon = tycon
                                             , dfid_pats  = pats
@@ -1451,16 +1484,25 @@ pprDataFamInstFlavour :: DataFamInstDecl name -> SDoc
 pprDataFamInstFlavour (DataFamInstDecl { dfid_defn = (HsDataDefn { dd_ND = nd }) })
   = ppr nd
 
-pp_fam_inst_lhs :: (OutputableBndrId name)
+pp_fam_inst_lhs :: (OutputableBndrId name, HasOccNameId name)
    => Located name
    -> HsTyPats name
    -> HsContext name
    -> SDoc
-pp_fam_inst_lhs thing (HsIB { hsib_body = typats }) context -- explicit type patterns
-   = hsep [ pprHsContext context, pprPrefixOcc (unLoc thing)
-          , hsep (map (pprParendHsType.unLoc) typats)]
-
-instance (OutputableBndrId name) => Outputable (ClsInstDecl name) where
+pp_fam_inst_lhs thing (HsIB { hsib_body = typats }) context
+                                              -- explicit type patterns
+   = hsep [ pprHsContext context, pp_pats typats]
+   where
+     pp_pats (patl:patsr)
+       | isSymOcc $ occName (unLoc thing)
+          = hsep [pprParendHsType (unLoc patl), pprInfixOcc (unLoc thing)
+          , hsep (map (pprParendHsType.unLoc) patsr)]
+       | otherwise = hsep [ pprPrefixOcc (unLoc thing)
+                   , hsep (map (pprParendHsType.unLoc) (patl:patsr))]
+     pp_pats [] = empty
+
+instance (OutputableBndrId name, HasOccNameId name)
+       => Outputable (ClsInstDecl name) where
     ppr (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = binds
                      , cid_sigs = sigs, cid_tyfam_insts = ats
                      , cid_overlap_mode = mbOverlap
@@ -1488,14 +1530,18 @@ ppOverlapPragma :: Maybe (Located OverlapMode) -> SDoc
 ppOverlapPragma mb =
   case mb of
     Nothing           -> empty
-    Just (L _ (NoOverlap _))    -> text "{-# NO_OVERLAP #-}"
-    Just (L _ (Overlappable _)) -> text "{-# OVERLAPPABLE #-}"
-    Just (L _ (Overlapping _))  -> text "{-# OVERLAPPING #-}"
-    Just (L _ (Overlaps _))     -> text "{-# OVERLAPS #-}"
-    Just (L _ (Incoherent _))   -> text "{-# INCOHERENT #-}"
+    Just (L _ (NoOverlap s))    -> maybe_stext s "{-# NO_OVERLAP #-}"
+    Just (L _ (Overlappable s)) -> maybe_stext s "{-# OVERLAPPABLE #-}"
+    Just (L _ (Overlapping s))  -> maybe_stext s "{-# OVERLAPPING #-}"
+    Just (L _ (Overlaps s))     -> maybe_stext s "{-# OVERLAPS #-}"
+    Just (L _ (Incoherent s))   -> maybe_stext s "{-# INCOHERENT #-}"
+  where
+    maybe_stext NoSourceText     alt = text alt
+    maybe_stext (SourceText src) _   = text src <+> text "#-}"
 
 
-instance (OutputableBndrId name) => Outputable (InstDecl name) where
+instance (OutputableBndrId name, HasOccNameId name)
+       => Outputable (InstDecl name) where
     ppr (ClsInstD     { cid_inst  = decl }) = ppr decl
     ppr (TyFamInstD   { tfid_inst = decl }) = ppr decl
     ppr (DataFamInstD { dfid_inst = decl }) = ppr decl
@@ -1536,7 +1582,8 @@ data DerivDecl name = DerivDecl
         }
 deriving instance (DataId name) => Data (DerivDecl name)
 
-instance (OutputableBndrId name) => Outputable (DerivDecl name) where
+instance (OutputableBndrId name, HasOccNameId name)
+       => Outputable (DerivDecl name) where
     ppr (DerivDecl { deriv_type = ty
                    , deriv_strategy = ds
                    , deriv_overlap_mode = o })
@@ -1570,7 +1617,8 @@ data DefaultDecl name
         -- For details on above see note [Api annotations] in ApiAnnotation
 deriving instance (DataId name) => Data (DefaultDecl name)
 
-instance (OutputableBndrId name) => Outputable (DefaultDecl name) where
+instance (OutputableBndrId name, HasOccNameId name)
+       => Outputable (DefaultDecl name) where
 
     ppr (DefaultDecl tys)
       = text "default" <+> parens (interpp'SP tys)
@@ -1673,7 +1721,8 @@ data ForeignExport = CExport  (Located CExportSpec) -- contains the calling
 -- pretty printing of foreign declarations
 --
 
-instance (OutputableBndrId name) => Outputable (ForeignDecl name) where
+instance (OutputableBndrId name, HasOccNameId name)
+       => Outputable (ForeignDecl name) where
   ppr (ForeignImport { fd_name = n, fd_sig_ty = ty, fd_fi = fimport })
     = hang (text "foreign import" <+> ppr fimport <+> ppr n)
          2 (dcolon <+> ppr ty)
@@ -1682,24 +1731,32 @@ instance (OutputableBndrId name) => Outputable (ForeignDecl name) where
        2 (dcolon <+> ppr ty)
 
 instance Outputable ForeignImport where
-  ppr (CImport  cconv safety mHeader spec _) =
-    ppr cconv <+> ppr safety <+>
-    char '"' <> pprCEntity spec <> char '"'
+  ppr (CImport  cconv safety mHeader spec (L _ srcText)) =
+    ppr cconv <+> ppr safety
+      <+> pprWithSourceText srcText (pprCEntity spec "")
     where
       pp_hdr = case mHeader of
                Nothing -> empty
                Just (Header _ header) -> ftext header
 
-      pprCEntity (CLabel lbl) =
-        text "static" <+> pp_hdr <+> char '&' <> ppr lbl
-      pprCEntity (CFunction (StaticTarget _ lbl _ isFun)) =
-            text "static"
-        <+> pp_hdr
-        <+> (if isFun then empty else text "value")
-        <+> ppr lbl
-      pprCEntity (CFunction (DynamicTarget)) =
-        text "dynamic"
-      pprCEntity (CWrapper) = text "wrapper"
+      pprCEntity (CLabel lbl) _ =
+        doubleQuotes $ text "static" <+> pp_hdr <+> char '&' <> ppr lbl
+      pprCEntity (CFunction (StaticTarget st _lbl _ isFun)) src =
+        if dqNeeded then doubleQuotes ce else empty
+          where
+            dqNeeded = (take 6 src == "static")
+                    || isJust mHeader
+                    || not isFun
+                    || st /= NoSourceText
+            ce =
+                  -- We may need to drop leading spaces first
+                  (if take 6 src == "static" then text "static" else empty)
+              <+> pp_hdr
+              <+> (if isFun then empty else text "value")
+              <+> (pprWithSourceText st empty)
+      pprCEntity (CFunction DynamicTarget) _ =
+        doubleQuotes $ text "dynamic"
+      pprCEntity CWrapper _ = doubleQuotes $ text "wrapper"
 
 instance Outputable ForeignExport where
   ppr (CExport  (L _ (CExportStatic _ lbl cconv)) _) =
@@ -1769,24 +1826,28 @@ collectRuleBndrSigTys :: [RuleBndr name] -> [LHsSigWcType name]
 collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ ty <- bndrs]
 
 pprFullRuleName :: Located (SourceText, RuleName) -> SDoc
-pprFullRuleName (L _ (_, n)) = doubleQuotes $ ftext n
+pprFullRuleName (L _ (st, n)) = pprWithSourceText st (doubleQuotes $ ftext n)
 
-instance (OutputableBndrId name) => Outputable (RuleDecls name) where
-  ppr (HsRules _ rules) = ppr rules
+instance (OutputableBndrId name, HasOccNameId name)
+       => Outputable (RuleDecls name) where
+  ppr (HsRules st rules)
+    = pprWithSourceText st (text "{-# RULES")
+          <+> vcat (punctuate semi (map ppr rules)) <+> text "#-}"
 
-instance (OutputableBndrId name) => Outputable (RuleDecl name) where
+instance (OutputableBndrId name, HasOccNameId name)
+       => Outputable (RuleDecl name) where
   ppr (HsRule name act ns lhs _fv_lhs rhs _fv_rhs)
-        = sep [text "{-# RULES" <+> pprFullRuleName name
-                                <+> ppr act,
+        = sep [pprFullRuleName name <+> ppr act,
                nest 4 (pp_forall <+> pprExpr (unLoc lhs)),
-               nest 4 (equals <+> pprExpr (unLoc rhs) <+> text "#-}") ]
+               nest 6 (equals <+> pprExpr (unLoc rhs)) ]
         where
           pp_forall | null ns   = empty
                     | otherwise = forAllLit <+> fsep (map ppr ns) <> dot
 
-instance (OutputableBndrId name) => Outputable (RuleBndr name) where
+instance (OutputableBndrId name, HasOccNameId name)
+        => Outputable (RuleBndr name) where
    ppr (RuleBndr name) = ppr name
-   ppr (RuleBndrSig name ty) = ppr name <> dcolon <> ppr ty
+   ppr (RuleBndrSig name ty) = parens (ppr name <> dcolon <> ppr ty)
 
 {-
 ************************************************************************
@@ -1871,7 +1932,8 @@ lvectInstDecl (L _ (HsVectInstIn _))  = True
 lvectInstDecl (L _ (HsVectInstOut _)) = True
 lvectInstDecl _                       = False
 
-instance (OutputableBndrId name) => Outputable (VectDecl name) where
+instance (OutputableBndrId name, HasOccNameId name)
+       => Outputable (VectDecl name) where
   ppr (HsVect _ v rhs)
     = sep [text "{-# VECTORISE" <+> ppr v,
            nest 4 $
@@ -1960,11 +2022,14 @@ data WarnDecl name = Warning [Located name] WarningTxt
   deriving Data
 
 instance OutputableBndr name => Outputable (WarnDecls name) where
-    ppr (Warnings _ decls) = ppr decls
+    ppr (Warnings (SourceText src) decls)
+      = text src <+> vcat (punctuate comma (map ppr decls)) <+> text "#-}"
+    ppr (Warnings NoSourceText _decls) = panic "WarnDecls"
 
 instance OutputableBndr name => Outputable (WarnDecl name) where
     ppr (Warning thing txt)
-      = hsep [text "{-# DEPRECATED", ppr thing, doubleQuotes (ppr txt), text "#-}"]
+      = hsep ( punctuate comma (map ppr thing))
+              <+> ppr txt
 
 {-
 ************************************************************************
@@ -1989,7 +2054,8 @@ data AnnDecl name = HsAnnotation
       -- For details on above see note [Api annotations] in ApiAnnotation
 deriving instance (DataId name) => Data (AnnDecl name)
 
-instance (OutputableBndrId name) => Outputable (AnnDecl name) where
+instance (OutputableBndrId name, HasOccNameId name)
+       => Outputable (AnnDecl name) where
     ppr (HsAnnotation _ provenance expr)
       = hsep [text "{-#", pprAnnProvenance provenance, pprExpr (unLoc expr), text "#-}"]
 
index df60084..78ee4e0 100644 (file)
@@ -22,7 +22,7 @@ import HsDecls
 import HsPat
 import HsLit
 import PlaceHolder ( PostTc,PostRn,DataId,DataIdPost,
-                     NameOrRdrName,OutputableBndrId )
+                     NameOrRdrName,OutputableBndrId, HasOccNameId )
 import HsTypes
 import HsBinds
 
@@ -84,7 +84,7 @@ type PostTcExpr  = HsExpr Id
 type PostTcTable = [(Name, PostTcExpr)]
 
 noPostTcExpr :: PostTcExpr
-noPostTcExpr = HsLit (HsString "" (fsLit "noPostTcExpr"))
+noPostTcExpr = HsLit (HsString NoSourceText (fsLit "noPostTcExpr"))
 
 noPostTcTable :: PostTcTable
 noPostTcTable = []
@@ -116,11 +116,12 @@ deriving instance (DataId id) => Data (SyntaxExpr id)
 -- | This is used for rebindable-syntax pieces that are too polymorphic
 -- for tcSyntaxOp (trS_fmap and the mzip in ParStmt)
 noExpr :: HsExpr id
-noExpr = HsLit (HsString "" (fsLit "noExpr"))
+noExpr = HsLit (HsString (SourceText  "noExpr") (fsLit "noExpr"))
 
 noSyntaxExpr :: SyntaxExpr id -- Before renaming, and sometimes after,
                               -- (if the syntax slot makes no sense)
-noSyntaxExpr = SyntaxExpr { syn_expr      = HsLit (HsString "" (fsLit "noSyntaxExpr"))
+noSyntaxExpr = SyntaxExpr { syn_expr      = HsLit (HsString NoSourceText
+                                                        (fsLit "noSyntaxExpr"))
                           , syn_arg_wraps = []
                           , syn_res_wrap  = WpHole }
 
@@ -133,7 +134,8 @@ mkRnSyntaxExpr name = SyntaxExpr { syn_expr      = HsVar $ noLoc name
   -- don't care about filling in syn_arg_wraps because we're clearly
   -- not past the typechecker
 
-instance (OutputableBndrId id) => Outputable (SyntaxExpr id) where
+instance (OutputableBndrId id, HasOccNameId id)
+         => Outputable (SyntaxExpr id) where
   ppr (SyntaxExpr { syn_expr      = expr
                   , syn_arg_wraps = arg_wraps
                   , syn_res_wrap  = res_wrap })
@@ -769,16 +771,17 @@ RenamedSource that the API Annotations cannot be used directly with
 RenamedSource, so this allows a simple mapping to be used based on the location.
 -}
 
-instance (OutputableBndrId id) => Outputable (HsExpr id) where
+instance (OutputableBndrId id, HasOccNameId id)
+          => Outputable (HsExpr id) where
     ppr expr = pprExpr expr
 
 -----------------------
 -- pprExpr, pprLExpr, pprBinds call pprDeeper;
 -- the underscore versions do not
-pprLExpr :: (OutputableBndrId id) => LHsExpr id -> SDoc
+pprLExpr :: (OutputableBndrId id, HasOccNameId id) => LHsExpr id -> SDoc
 pprLExpr (L _ e) = pprExpr e
 
-pprExpr :: (OutputableBndrId id) => HsExpr id -> SDoc
+pprExpr :: (OutputableBndrId id,HasOccNameId id) => HsExpr id -> SDoc
 pprExpr e | isAtomicHsExpr e || isQuietHsExpr e =            ppr_expr e
           | otherwise                           = pprDeeper (ppr_expr e)
 
@@ -794,15 +797,17 @@ isQuietHsExpr (HsAppTypeOut _ _) = True
 isQuietHsExpr (OpApp _ _ _ _)    = True
 isQuietHsExpr _ = False
 
-pprBinds :: (OutputableBndrId idL, OutputableBndrId idR)
+pprBinds :: (OutputableBndrId idL, OutputableBndrId idR,
+             HasOccNameId idL, HasOccNameId idR)
          => HsLocalBindsLR idL idR -> SDoc
 pprBinds b = pprDeeper (ppr b)
 
 -----------------------
-ppr_lexpr :: (OutputableBndrId id) => LHsExpr id -> SDoc
+ppr_lexpr :: (OutputableBndrId id,HasOccNameId id) => LHsExpr id -> SDoc
 ppr_lexpr e = ppr_expr (unLoc e)
 
-ppr_expr :: forall id. (OutputableBndrId id) => HsExpr id -> SDoc
+ppr_expr :: forall id. (OutputableBndrId id,HasOccNameId id)
+         => HsExpr id -> SDoc
 ppr_expr (HsVar (L _ v))  = pprPrefixOcc v
 ppr_expr (HsUnboundVar uv)= pprPrefixOcc (unboundVarOcc uv)
 ppr_expr (HsIPVar v)      = ppr v
@@ -811,8 +816,10 @@ ppr_expr (HsLit lit)      = ppr lit
 ppr_expr (HsOverLit lit)  = ppr lit
 ppr_expr (HsPar e)        = parens (ppr_lexpr e)
 
-ppr_expr (HsCoreAnn _ (StringLiteral _ s) e)
-  = vcat [text "HsCoreAnn" <+> ftext s, ppr_lexpr e]
+ppr_expr (HsCoreAnn stc (StringLiteral sta s) e)
+  = vcat [pprWithSourceText stc (text "{-# CORE")
+          <+> pprWithSourceText sta (doubleQuotes $ ftext s) <+> text "#-}"
+         , ppr_lexpr e]
 
 ppr_expr e@(HsApp {})        = ppr_apps e []
 ppr_expr e@(HsAppType {})    = ppr_apps e []
@@ -831,7 +838,7 @@ ppr_expr (OpApp e1 op _ e2)
       = hang (ppr op) 2 (sep [pp_e1, pp_e2])
 
     pp_infixly v
-      = sep [pp_e1, sep [pprInfixOcc v, nest 2 pp_e2]]
+      = hang pp_e1 2 (sep [pprInfixOcc v, nest 2 pp_e2])
 
 ppr_expr (NegApp e _) = char '-' <+> pprDebugParendExpr e
 
@@ -877,12 +884,15 @@ ppr_expr (HsLam matches)
   = pprMatches matches
 
 ppr_expr (HsLamCase matches)
-  = sep [ sep [text "\\case {"],
-          nest 2 (pprMatches matches <+> char '}') ]
+  = sep [ sep [text "\\case"],
+          nest 2 (pprMatches matches) ]
 
-ppr_expr (HsCase expr matches)
+ppr_expr (HsCase expr matches@(MG { mg_alts = L _ [_] }))
   = sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of {")],
-          nest 2 (pprMatches matches <+> char '}') ]
+          nest 2 (pprMatches matches) <+> char '}']
+ppr_expr (HsCase expr matches)
+  = sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of")],
+          nest 2 (pprMatches matches) ]
 
 ppr_expr (HsIf _ e1 e2 e3)
   = sep [hsep [text "if", nest 2 (ppr e1), ptext (sLit "then")],
@@ -891,10 +901,14 @@ ppr_expr (HsIf _ e1 e2 e3)
          nest 4 (ppr e3)]
 
 ppr_expr (HsMultiIf _ alts)
-  = sep $ text "if" : map ppr_alt alts
+  = hang (text "if") 3  (vcat (map ppr_alt alts))
   where ppr_alt (L _ (GRHS guards expr)) =
-          sep [ vbar <+> interpp'SP guards
-              , text "->" <+> pprDeeper (ppr expr) ]
+          hang vbar 2 (ppr_one one_alt)
+          where
+            ppr_one [] = panic "ppr_exp HsMultiIf"
+            ppr_one (h:t) = hang h 2 (sep t)
+            one_alt = [ interpp'SP guards
+                      , text "->" <+> pprDeeper (ppr expr) ]
 
 -- special case: let ... in let ...
 ppr_expr (HsLet (L _ binds) expr@(L _ (HsLet _ _)))
@@ -934,8 +948,11 @@ ppr_expr (ELazyPat e)   = char '~' <> pprParendLExpr e
 ppr_expr (EAsPat v e)   = ppr v <> char '@' <> pprParendLExpr e
 ppr_expr (EViewPat p e) = ppr p <+> text "->" <+> ppr e
 
-ppr_expr (HsSCC _ (StringLiteral _ lbl) expr)
-  = sep [ text "{-# SCC" <+> doubleQuotes (ftext lbl) <+> ptext (sLit "#-}"),
+ppr_expr (HsSCC st (StringLiteral stl lbl) expr)
+  = sep [ pprWithSourceText st (text "{-# SCC")
+         -- no doublequotes if stl empty, for the case where the SCC was written
+         -- without quotes.
+          <+> pprWithSourceText stl (ftext lbl) <+> text "#-}",
           pprParendLExpr expr ]
 
 ppr_expr (HsWrap co_fn e)
@@ -993,9 +1010,10 @@ ppr_expr (HsRecFld f) = ppr f
 -- We must tiresomely make the "id" parameter to the LHsWcType existential
 -- because it's different in the HsAppType case and the HsAppTypeOut case
 -- | Located Haskell Wildcard Type Expression
-data LHsWcTypeX = forall id. (OutputableBndrId id) => LHsWcTypeX (LHsWcType id)
+data LHsWcTypeX = forall id. (OutputableBndrId id, HasOccNameId id)
+                   => LHsWcTypeX (LHsWcType id)
 
-ppr_apps :: (OutputableBndrId id)
+ppr_apps :: (OutputableBndrId id,HasOccNameId id)
          => HsExpr id
          -> [Either (LHsExpr id) LHsWcTypeX]
          -> SDoc
@@ -1027,16 +1045,17 @@ fixities should do the job, except in debug mode (-dppr-debug) so we
 can see the structure of the parse tree.
 -}
 
-pprDebugParendExpr :: (OutputableBndrId id) => LHsExpr id -> SDoc
+pprDebugParendExpr :: (OutputableBndrId id, HasOccNameId id)
+                   => LHsExpr id -> SDoc
 pprDebugParendExpr expr
   = getPprStyle (\sty ->
     if debugStyle sty then pprParendLExpr expr
                       else pprLExpr      expr)
 
-pprParendLExpr :: (OutputableBndrId id) => LHsExpr id -> SDoc
+pprParendLExpr :: (OutputableBndrId id, HasOccNameId id) => LHsExpr id -> SDoc
 pprParendLExpr (L _ e) = pprParendExpr e
 
-pprParendExpr :: (OutputableBndrId id) => HsExpr id -> SDoc
+pprParendExpr :: (OutputableBndrId id, HasOccNameId id) => HsExpr id -> SDoc
 pprParendExpr expr
   | hsExprNeedsParens expr = parens (pprExpr expr)
   | otherwise              = pprExpr expr
@@ -1064,6 +1083,9 @@ hsExprNeedsParens (HsTcBracketOut {}) = False
 hsExprNeedsParens (HsDo sc _ _)
        | isListCompExpr sc            = False
 hsExprNeedsParens (HsRecFld{})        = False
+hsExprNeedsParens (RecordCon{})       = False
+hsExprNeedsParens (HsSpliceE{})       = False
+hsExprNeedsParens (RecordUpd{})       = False
 hsExprNeedsParens _ = True
 
 
@@ -1114,9 +1136,11 @@ data HsCmd id
 
   -- For details on above see note [Api annotations] in ApiAnnotation
   | HsCmdArrForm         -- Command formation,  (| e cmd1 .. cmdn |)
-        (LHsExpr id)     -- the operator
-                         -- after type-checking, a type abstraction to be
+        (LHsExpr id)     -- The operator.
+                         -- After type-checking, a type abstraction to be
                          -- applied to the type of the local environment tuple
+        FunctionFixity   -- Whether the operator appeared prefix or infix when
+                         -- parsed.
         (Maybe Fixity)   -- fixity (filled in by the renamer), for forms that
                          -- were converted from OpApp's by the renamer
         [LHsCmdTop id]   -- argument commands
@@ -1199,16 +1223,17 @@ data HsCmdTop id
              (CmdSyntaxTable id) -- See Note [CmdSyntaxTable]
 deriving instance (DataId id) => Data (HsCmdTop id)
 
-instance (OutputableBndrId id) => Outputable (HsCmd id) where
+instance (OutputableBndrId id, HasOccNameId id) => Outputable (HsCmd id) where
     ppr cmd = pprCmd cmd
 
 -----------------------
 -- pprCmd and pprLCmd call pprDeeper;
 -- the underscore versions do not
-pprLCmd :: (OutputableBndrId id) => LHsCmd id -> SDoc
+pprLCmd :: (OutputableBndrId id, HasOccName id, HasOccName (NameOrRdrName id))
+        => LHsCmd id -> SDoc
 pprLCmd (L _ c) = pprCmd c
 
-pprCmd :: (OutputableBndrId id) => HsCmd id -> SDoc
+pprCmd :: (OutputableBndrId id, HasOccNameId id) => HsCmd id -> SDoc
 pprCmd c | isQuietHsCmd c =            ppr_cmd c
          | otherwise      = pprDeeper (ppr_cmd c)
 
@@ -1222,10 +1247,11 @@ isQuietHsCmd (HsCmdApp _ _) = True
 isQuietHsCmd _ = False
 
 -----------------------
-ppr_lcmd :: (OutputableBndrId id) => LHsCmd id -> SDoc
+ppr_lcmd :: (OutputableBndrId id, HasOccNameId id) => LHsCmd id -> SDoc
 ppr_lcmd c = ppr_cmd (unLoc c)
 
-ppr_cmd :: forall id. (OutputableBndrId id) => HsCmd id -> SDoc
+ppr_cmd :: forall id. (OutputableBndrId id, HasOccNameId id)
+        => HsCmd id -> SDoc
 ppr_cmd (HsCmdPar c) = parens (ppr_lcmd c)
 
 ppr_cmd (HsCmdApp c e)
@@ -1239,8 +1265,8 @@ ppr_cmd (HsCmdLam matches)
   = pprMatches matches
 
 ppr_cmd (HsCmdCase expr matches)
-  = sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of {")],
-          nest 2 (pprMatches matches <+> char '}') ]
+  = sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of")],
+          nest 2 (pprMatches matches) ]
 
 ppr_cmd (HsCmdIf _ e ct ce)
   = sep [hsep [text "if", nest 2 (ppr e), ptext (sLit "then")],
@@ -1270,19 +1296,22 @@ ppr_cmd (HsCmdArrApp arrow arg _ HsHigherOrderApp True)
 ppr_cmd (HsCmdArrApp arrow arg _ HsHigherOrderApp False)
   = hsep [ppr_lexpr arg, arrowtt, ppr_lexpr arrow]
 
-ppr_cmd (HsCmdArrForm (L _ (HsVar (L _ v))) (Just _) [arg1, arg2])
-  = sep [pprCmdArg (unLoc arg1), hsep [pprInfixOcc v, pprCmdArg (unLoc arg2)]]
-ppr_cmd (HsCmdArrForm op _ args)
+ppr_cmd (HsCmdArrForm (L _ (HsVar (L _ v))) _ (Just _) [arg1, arg2])
+  = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc v
+                                         , pprCmdArg (unLoc arg2)])
+ppr_cmd (HsCmdArrForm (L _ (HsVar (L _ v))) Infix _    [arg1, arg2])
+  = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc v
+                                         , pprCmdArg (unLoc arg2)])
+ppr_cmd (HsCmdArrForm op _ _ args)
   = hang (text "(|" <> ppr_lexpr op)
          4 (sep (map (pprCmdArg.unLoc) args) <> text "|)")
 
-pprCmdArg :: (OutputableBndrId id) => HsCmdTop id -> SDoc
-pprCmdArg (HsCmdTop cmd@(L _ (HsCmdArrForm _ Nothing [])) _ _ _)
-  = ppr_lcmd cmd
+pprCmdArg :: (OutputableBndrId id, HasOccNameId id) => HsCmdTop id -> SDoc
 pprCmdArg (HsCmdTop cmd _ _ _)
-  = parens (ppr_lcmd cmd)
+  = ppr_lcmd cmd
 
-instance (OutputableBndrId id) => Outputable (HsCmdTop id) where
+instance (OutputableBndrId id, HasOccNameId id)
+        => Outputable (HsCmdTop id) where
     ppr = pprCmdArg
 
 {-
@@ -1347,7 +1376,7 @@ data Match id body
   }
 deriving instance (Data body,DataId id) => Data (Match id body)
 
-instance (OutputableBndrId idR, Outputable body)
+instance (OutputableBndrId idR, HasOccNameId idR, Outputable body)
             => Outputable (Match idR body) where
   ppr = pprMatch
 
@@ -1442,25 +1471,29 @@ deriving instance (Data body,DataId id) => Data (GRHS id body)
 
 -- We know the list must have at least one @Match@ in it.
 
-pprMatches :: (OutputableBndrId idR, Outputable body)
+pprMatches :: (OutputableBndrId idR, HasOccNameId idR, Outputable body)
            => MatchGroup idR body -> SDoc
 pprMatches MG { mg_alts = matches }
     = vcat (map pprMatch (map unLoc (unLoc matches)))
       -- Don't print the type; it's only a place-holder before typechecking
 
 -- Exported to HsBinds, which can't see the defn of HsMatchContext
-pprFunBind :: (OutputableBndrId idR, Outputable body)
+pprFunBind :: (OutputableBndrId idR, HasOccNameId idR, Outputable body)
            => MatchGroup idR body -> SDoc
 pprFunBind matches = pprMatches matches
 
 -- Exported to HsBinds, which can't see the defn of HsMatchContext
 pprPatBind :: forall bndr id body. (OutputableBndrId bndr,
-                                    OutputableBndrId id, Outputable body)
+                                    OutputableBndrId id,
+                                    HasOccNameId id,
+                                    HasOccNameId bndr,
+                                    Outputable body)
            => LPat bndr -> GRHSs id body -> SDoc
 pprPatBind pat (grhss)
  = sep [ppr pat, nest 2 (pprGRHSs (PatBindRhs :: HsMatchContext id) grhss)]
 
-pprMatch :: (OutputableBndrId idR, Outputable body) => Match idR body -> SDoc
+pprMatch :: (OutputableBndrId idR, HasOccNameId idR, Outputable body)
+         => Match idR body -> SDoc
 pprMatch match
   = sep [ sep (herald : map (nest 2 . pprParendLPat) other_pats)
         , nest 2 ppr_maybe_ty
@@ -1495,14 +1528,16 @@ pprMatch match
                         Nothing -> empty
 
 
-pprGRHSs :: (OutputableBndrId idR, Outputable body)
+pprGRHSs :: (OutputableBndrId idR, HasOccNameId idR, Outputable body)
          => HsMatchContext idL -> GRHSs idR body -> SDoc
 pprGRHSs ctxt (GRHSs grhss (L _ binds))
   = vcat (map (pprGRHS ctxt . unLoc) grhss)
- $$ ppUnless (isEmptyLocalBinds binds)
+  -- Print the "where" even if the contents of the binds is empty. Only
+  -- EmptyLocalBinds means no "where" keyword
+ $$ ppUnless (eqEmptyLocalBinds binds)
       (text "where" $$ nest 4 (pprBinds binds))
 
-pprGRHS :: (OutputableBndrId idR, Outputable body)
+pprGRHS :: (OutputableBndrId idR, HasOccNameId idR, Outputable body)
         => HsMatchContext idL -> GRHS idR body -> SDoc
 pprGRHS ctxt (GRHS [] body)
  =  pp_rhs ctxt body
@@ -1848,14 +1883,17 @@ In any other context than 'MonadComp', the fields for most of these
 'SyntaxExpr's stay bottom.
 -}
 
-instance (OutputableBndrId idL) => Outputable (ParStmtBlock idL idR) where
+instance (OutputableBndrId idL, HasOccNameId idL)
+          => Outputable (ParStmtBlock idL idR) where
   ppr (ParStmtBlock stmts _ _) = interpp'SP stmts
 
-instance (OutputableBndrId idL, OutputableBndrId idR, Outputable body)
+instance (OutputableBndrId idL, OutputableBndrId idR,
+          HasOccNameId idL, HasOccNameId idR, Outputable body)
          => Outputable (StmtLR idL idR body) where
     ppr stmt = pprStmt stmt
 
 pprStmt :: forall idL idR body . (OutputableBndrId idL, OutputableBndrId idR,
+                                  HasOccNameId idL, HasOccNameId idR,
                                   Outputable body)
         => (StmtLR idL idR body) -> SDoc
 pprStmt (LastStmt expr ret_stripped _)
@@ -1886,7 +1924,7 @@ pprStmt (ApplicativeStmt args mb_join _)
   -- make all the Applicative stuff invisible in error messages by
   -- flattening the whole ApplicativeStmt nest back to a sequence
   -- of statements.
-   pp_for_user = vcat $ punctuate semi $ concatMap flattenArg args
+   pp_for_user = vcat $ concatMap flattenArg args
 
    -- ppr directly rather than transforming here, because we need to
    -- inject a "return" which is hard when we're polymorphic in the id
@@ -1919,7 +1957,7 @@ pprStmt (ApplicativeStmt args mb_join _)
                 (stmts ++ [noLoc (LastStmt (noLoc return) False noSyntaxExpr)]))
            (error "pprStmt"))
 
-pprTransformStmt :: (OutputableBndrId id)
+pprTransformStmt :: (OutputableBndrId id, HasOccNameId id)
                  => [id] -> LHsExpr id -> Maybe (LHsExpr id) -> SDoc
 pprTransformStmt bndrs using by
   = sep [ text "then" <+> ifPprDebug (braces (ppr bndrs))
@@ -1936,7 +1974,7 @@ pprBy :: Outputable body => Maybe body -> SDoc
 pprBy Nothing  = empty
 pprBy (Just e) = text "by" <+> ppr e
 
-pprDo :: (OutputableBndrId id, Outputable body)
+pprDo :: (OutputableBndrId id, HasOccNameId id, Outputable body)
       => HsStmtContext any -> [LStmt id body] -> SDoc
 pprDo DoExpr        stmts = text "do"  <+> ppr_do_stmts stmts
 pprDo GhciStmtCtxt  stmts = text "do"  <+> ppr_do_stmts stmts
@@ -1947,15 +1985,13 @@ pprDo PArrComp      stmts = paBrackets  $ pprComp stmts
 pprDo MonadComp     stmts = brackets    $ pprComp stmts
 pprDo _             _     = panic "pprDo" -- PatGuard, ParStmtCxt
 
-ppr_do_stmts :: (OutputableBndrId idL, OutputableBndrId idR, Outputable body)
+ppr_do_stmts :: (OutputableBndrId idL, OutputableBndrId idR,
+                 HasOccNameId idL, HasOccNameId idR, Outputable body)
              => [LStmtLR idL idR body] -> SDoc
--- Print a bunch of do stmts, with explicit braces and semicolons,
--- so that we are not vulnerable to layout bugs
-ppr_do_stmts stmts
-  = lbrace <+> pprDeeperList vcat (punctuate semi (map ppr stmts))
-           <+> rbrace
+-- Print a bunch of do stmts
+ppr_do_stmts stmts = pprDeeperList vcat (map ppr stmts)
 
-pprComp :: (OutputableBndrId id, Outputable body)
+pprComp :: (OutputableBndrId id, HasOccNameId id, Outputable body)
         => [LStmt id body] -> SDoc
 pprComp quals     -- Prints:  body | qual1, ..., qualn
   | Just (initStmts, L _ (LastStmt body _ _)) <- snocView quals
@@ -1970,7 +2006,7 @@ pprComp quals     -- Prints:  body | qual1, ..., qualn
   | otherwise
   = pprPanic "pprComp" (pprQuals quals)
 
-pprQuals :: (OutputableBndrId id, Outputable body)
+pprQuals :: (OutputableBndrId id, HasOccNameId id, Outputable body)
         => [LStmt id body] -> SDoc
 -- Show list comprehension qualifiers separated by commas
 pprQuals quals = interpp'SP quals
@@ -1986,10 +2022,12 @@ pprQuals quals = interpp'SP quals
 -- | Haskell Splice
 data HsSplice id
    = HsTypedSplice       --  $$z  or $$(f 4)
+        HasParens        -- Whether $$( ) variant found, for pretty printing
         id               -- A unique name to identify this splice point
         (LHsExpr id)     -- See Note [Pending Splices]
 
    | HsUntypedSplice     --  $z  or $(f 4)
+        HasParens        -- Whether $( ) variant found, for pretty printing
         id               -- A unique name to identify this splice point
         (LHsExpr id)     -- See Note [Pending Splices]
 
@@ -2007,9 +2045,17 @@ data HsSplice id
         ThModFinalizers     -- TH finalizers produced by the splice.
         (HsSplicedThing id) -- The result of splicing
   deriving Typeable
-
 deriving instance (DataId id) => Data (HsSplice id)
 
+data HasParens = HasParens
+               | NoParens
+               deriving (Data, Eq, Show)
+
+instance Outputable HasParens where
+  ppr HasParens = text "HasParens"
+  ppr NoParens  = text "NoParens"
+
+
 isTypedSplice :: HsSplice id -> Bool
 isTypedSplice (HsTypedSplice {}) = True
 isTypedSplice _                  = False   -- Quasi-quotes are untyped splices
@@ -2135,41 +2181,53 @@ splices. In contrast, when pretty printing the output of the type checker, we
 sense, although I hate to add another constructor to HsExpr.
 -}
 
-instance OutputableBndrId id => Outputable (HsSplicedThing id) where
+instance (OutputableBndrId id, HasOccNameId id)
+    => Outputable (HsSplicedThing id) where
   ppr (HsSplicedExpr e) = ppr_expr e
   ppr (HsSplicedTy   t) = ppr t
   ppr (HsSplicedPat  p) = ppr p
 
-instance (OutputableBndrId id) => Outputable (HsSplice id) where
+instance (OutputableBndrId id, HasOccNameId id)
+        => Outputable (HsSplice id) where
   ppr s = pprSplice s
 
-pprPendingSplice :: (OutputableBndrId id)
+pprPendingSplice :: (OutputableBndrId id, HasOccNameId id)
                  => SplicePointName -> LHsExpr id -> SDoc
 pprPendingSplice n e = angleBrackets (ppr n <> comma <+> ppr e)
 
-pprSplice :: (OutputableBndrId id) => HsSplice id -> SDoc
-pprSplice (HsTypedSplice   n e)  = ppr_splice (text "$$") n e
-pprSplice (HsUntypedSplice n e)  = ppr_splice (text "$")  n e
-pprSplice (HsQuasiQuote n q _ s) = ppr_quasi n q s
-pprSplice (HsSpliced _ thing)    = ppr thing
+pprSpliceDecl ::  (OutputableBndrId id, HasOccNameId id)
+          => HsSplice id -> SpliceExplicitFlag -> SDoc
+pprSpliceDecl e@HsQuasiQuote{} _ = pprSplice e
+pprSpliceDecl e ExplicitSplice   = text "$(" <> ppr_splice_decl e <> text ")"
+pprSpliceDecl e ImplicitSplice   = ppr_splice_decl e
+
+ppr_splice_decl :: (OutputableBndrId id, HasOccNameId id)
+          => HsSplice id -> SDoc
+ppr_splice_decl (HsUntypedSplice _ n e) = ppr_splice empty n e empty
+ppr_splice_decl e = pprSplice e
+
+pprSplice :: (OutputableBndrId id, HasOccNameId id)
+          => HsSplice id -> SDoc
+pprSplice (HsTypedSplice HasParens  n e)
+  = ppr_splice (text "$$(") n e (text ")")
+pprSplice (HsTypedSplice NoParens n e)
+  = ppr_splice (text "$$") n e empty
+pprSplice (HsUntypedSplice HasParens  n e)
+  = ppr_splice (text "$(") n e (text ")")
+pprSplice (HsUntypedSplice NoParens n e)
+  = ppr_splice (text "$")  n e empty
+pprSplice (HsQuasiQuote n q _ s)      = ppr_quasi n q s
+pprSplice (HsSpliced _ thing)         = ppr thing
 
 ppr_quasi :: OutputableBndr id => id -> id -> FastString -> SDoc
 ppr_quasi n quoter quote = ifPprDebug (brackets (ppr n)) <>
                            char '[' <> ppr quoter <> vbar <>
                            ppr quote <> text "|]"
 
-ppr_splice :: (OutputableBndrId id) => SDoc -> id -> LHsExpr id -> SDoc
-ppr_splice herald n e
-    = herald <> ifPprDebug (brackets (ppr n)) <> eDoc
-    where
-          -- We use pprLExpr to match pprParendLExpr:
-          --     Using pprLExpr makes sure that we go 'deeper'
-          --     I think that is usually (always?) right
-          pp_as_was = pprLExpr e
-          eDoc = case unLoc e of
-                 HsPar _ -> pp_as_was
-                 HsVar _ -> pp_as_was
-                 _ -> parens pp_as_was
+ppr_splice :: (OutputableBndrId id, HasOccNameId id)
+           => SDoc -> id -> LHsExpr id -> SDoc -> SDoc
+ppr_splice herald n e trail
+    = herald <> ifPprDebug (brackets (ppr n)) <> ppr e <> trail
 
 -- | Haskell Bracket
 data HsBracket id = ExpBr (LHsExpr id)   -- [|  expr  |]
@@ -2186,18 +2244,21 @@ isTypedBracket :: HsBracket id -> Bool
 isTypedBracket (TExpBr {}) = True
 isTypedBracket _           = False
 
-instance (OutputableBndrId id) => Outputable (HsBracket id) where
+instance (OutputableBndrId id, HasOccNameId id)
+        => Outputable (HsBracket id) where
   ppr = pprHsBracket
 
 
-pprHsBracket :: (OutputableBndrId id) => HsBracket id -> SDoc
+pprHsBracket :: (OutputableBndrId id, HasOccNameId id) => HsBracket id -> SDoc
 pprHsBracket (ExpBr e)   = thBrackets empty (ppr e)
 pprHsBracket (PatBr p)   = thBrackets (char 'p') (ppr p)
 pprHsBracket (DecBrG gp) = thBrackets (char 'd') (ppr gp)
 pprHsBracket (DecBrL ds) = thBrackets (char 'd') (vcat (map ppr ds))
 pprHsBracket (TypBr t)   = thBrackets (char 't') (ppr t)
-pprHsBracket (VarBr True n)  = char '\''         <> ppr n
-pprHsBracket (VarBr False n) = text "''" <> ppr n
+pprHsBracket (VarBr True n)
+  = char '\'' <> pprPrefixVar (isSymOcc $ occName n) (ppr n)
+pprHsBracket (VarBr False n)
+  = text "''" <> pprPrefixVar (isSymOcc $ occName n) (ppr n)
 pprHsBracket (TExpBr e)  = thTyBrackets (ppr e)
 
 thBrackets :: SDoc -> SDoc -> SDoc
@@ -2233,7 +2294,8 @@ data ArithSeqInfo id
                     (LHsExpr id)
 deriving instance (DataId id) => Data (ArithSeqInfo id)
 
-instance (OutputableBndrId id) => Outputable (ArithSeqInfo id) where
+instance (OutputableBndrId id, HasOccName id, HasOccName (NameOrRdrName id))
+         => Outputable (ArithSeqInfo id) where
     ppr (From e1)             = hcat [ppr e1, pp_dotdot]
     ppr (FromThen e1 e2)      = hcat [ppr e1, comma, space, ppr e2, pp_dotdot]
     ppr (FromTo e1 e3)        = hcat [ppr e1, pp_dotdot, ppr e3]
@@ -2420,7 +2482,7 @@ matchContextErrString (StmtCtxt ListComp)          = text "list comprehension"
 matchContextErrString (StmtCtxt MonadComp)         = text "monad comprehension"
 matchContextErrString (StmtCtxt PArrComp)          = text "array comprehension"
 
-pprMatchInCtxt :: (OutputableBndrId idR,
+pprMatchInCtxt :: (OutputableBndrId idR, HasOccNameId idR,
                    Outputable (NameOrRdrName (NameOrRdrName idR)),
                    Outputable body)
                => Match idR body -> SDoc
@@ -2428,7 +2490,9 @@ pprMatchInCtxt match  = hang (text "In" <+> pprMatchContext (m_ctxt match)
                                         <> colon)
                              4 (pprMatch match)
 
-pprStmtInCtxt :: (OutputableBndrId idL, OutputableBndrId idR, Outputable body)
+pprStmtInCtxt :: (OutputableBndrId idL, OutputableBndrId idR,
+                  HasOccNameId idL, HasOccNameId idR,
+                  Outputable body)
                => HsStmtContext idL -> StmtLR idL idR body -> SDoc
 pprStmtInCtxt ctxt (LastStmt e _ _)
   | isListCompExpr ctxt      -- For [ e | .. ], do not mutter about "stmts"
index 022ca6b..070465e 100644 (file)
@@ -10,7 +10,8 @@ module HsExpr where
 import SrcLoc     ( Located )
 import Outputable ( SDoc, Outputable )
 import {-# SOURCE #-} HsPat  ( LPat )
-import PlaceHolder ( DataId, OutputableBndrId )
+import BasicTypes ( SpliceExplicitFlag(..))
+import PlaceHolder ( DataId, OutputableBndrId, HasOccNameId )
 import Data.Data hiding ( Fixity )
 
 type role HsExpr nominal
@@ -33,20 +34,27 @@ instance (Data body,DataId id) => Data (MatchGroup id body)
 instance (Data body,DataId id) => Data (GRHSs id body)
 instance (DataId id) => Data (SyntaxExpr id)
 
-instance (OutputableBndrId id) => Outputable (HsExpr id)
-instance (OutputableBndrId id) => Outputable (HsCmd id)
+instance (OutputableBndrId id, HasOccNameId id) => Outputable (HsExpr id)
+instance (OutputableBndrId id, HasOccNameId id) => Outputable (HsCmd id)
 
 type LHsExpr a = Located (HsExpr a)
 
-pprLExpr :: (OutputableBndrId id) => LHsExpr id -> SDoc
+pprLExpr :: (OutputableBndrId id, HasOccNameId id) => LHsExpr id -> SDoc
 
-pprExpr :: (OutputableBndrId id) => HsExpr id -> SDoc
+pprExpr :: (OutputableBndrId id,HasOccNameId id) => HsExpr id -> SDoc
 
-pprSplice :: (OutputableBndrId id) => HsSplice id -> SDoc
+pprSplice :: (OutputableBndrId id, HasOccNameId id)
+          => HsSplice id -> SDoc
+
+pprSpliceDecl ::  (OutputableBndrId id, HasOccNameId id)
+          => HsSplice id -> SpliceExplicitFlag -> SDoc
 
 pprPatBind :: (OutputableBndrId bndr,
-               OutputableBndrId id, Outputable body)
+               OutputableBndrId id,
+               HasOccNameId id,
+               HasOccNameId bndr,
+               Outputable body)
            => LPat bndr -> GRHSs id body -> SDoc
 
-pprFunBind :: (OutputableBndrId idR, Outputable body)
+pprFunBind :: (OutputableBndrId idR, HasOccNameId idR, Outputable body)
            => MatchGroup idR body -> SDoc
index 011a80a..8641f1f 100644 (file)
@@ -12,8 +12,8 @@ module HsImpExp where
 
 import Module           ( ModuleName )
 import HsDoc            ( HsDocString )
-import OccName          ( HasOccName(..), isTcOcc, isSymOcc )
-import BasicTypes       ( SourceText, StringLiteral(..) )
+import OccName          ( HasOccName(..), isTcOcc, isSymOcc, isDataOcc )
+import BasicTypes       ( SourceText(..), StringLiteral(..), pprWithSourceText )
 import FieldLabel       ( FieldLbl(..) )
 
 import Outputable
@@ -45,7 +45,7 @@ type LImportDecl name = Located (ImportDecl name)
 -- A single Haskell @import@ declaration.
 data ImportDecl name
   = ImportDecl {
-      ideclSourceSrc :: Maybe SourceText,
+      ideclSourceSrc :: SourceText,
                                  -- Note [Pragma source text] in BasicTypes
       ideclName      :: Located ModuleName, -- ^ Module name.
       ideclPkgQual   :: Maybe StringLiteral,  -- ^ Package qualifier.
@@ -77,7 +77,7 @@ data ImportDecl name
 
 simpleImportDecl :: ModuleName -> ImportDecl name
 simpleImportDecl mn = ImportDecl {
-      ideclSourceSrc = Nothing,
+      ideclSourceSrc = NoSourceText,
       ideclName      = noLoc mn,
       ideclPkgQual   = Nothing,
       ideclSource    = False,
@@ -89,7 +89,8 @@ simpleImportDecl mn = ImportDecl {
     }
 
 instance (OutputableBndr name, HasOccName name) => Outputable (ImportDecl name) where
-    ppr (ImportDecl { ideclName = mod', ideclPkgQual = pkg
+    ppr (ImportDecl { ideclSourceSrc = mSrcText, ideclName = mod'
+                    , ideclPkgQual = pkg
                     , ideclSource = from, ideclSafe = safe
                     , ideclQualified = qual, ideclImplicit = implicit
                     , ideclAs = as, ideclHiding = spec })
@@ -100,8 +101,9 @@ instance (OutputableBndr name, HasOccName name) => Outputable (ImportDecl name)
         pp_implicit False = empty
         pp_implicit True = ptext (sLit ("(implicit)"))
 
-        pp_pkg Nothing                     = empty
-        pp_pkg (Just (StringLiteral _ p)) = doubleQuotes (ftext p)
+        pp_pkg Nothing                    = empty
+        pp_pkg (Just (StringLiteral st p))
+          = pprWithSourceText st (doubleQuotes (ftext p))
 
         pp_qual False   = empty
         pp_qual True    = text "qualified"
@@ -112,7 +114,9 @@ instance (OutputableBndr name, HasOccName name) => Outputable (ImportDecl name)
         pp_as Nothing   = empty
         pp_as (Just a)  = text "as" <+> ppr a
 
-        ppr_imp True  = text "{-# SOURCE #-}"
+        ppr_imp True  = case mSrcText of
+                          NoSourceText   -> text "{-# SOURCE #-}"
+                          SourceText src -> text src <+> text "#-}"
         ppr_imp False = empty
 
         pp_spec Nothing             = empty
@@ -241,7 +245,10 @@ pprImpExp name = type_pref <+> pprPrefixOcc name
               | otherwise                   = empty
 
 instance (HasOccName name, OutputableBndr name) => Outputable (IE name) where
-    ppr (IEVar          var)    = pprPrefixOcc (unLoc var)
+    ppr (IEVar          var)
+      -- This is a messy test, should perhaps create IEPatternVar
+      = (if isDataOcc $ occName $ unLoc var then text "pattern" else empty)
+        <+> pprPrefixOcc (unLoc var)
     ppr (IEThingAbs     thing)  = pprImpExp (unLoc thing)
     ppr (IEThingAll      thing) = hcat [pprImpExp (unLoc thing), text "(..)"]
     ppr (IEThingWith thing wc withs flds)
index 4cf5719..e513fe9 100644 (file)
@@ -19,11 +19,11 @@ module HsLit where
 #include "HsVersions.h"
 
 import {-# SOURCE #-} HsExpr( HsExpr, pprExpr )
-import BasicTypes ( FractionalLit(..),SourceText )
+import BasicTypes ( FractionalLit(..),SourceText(..),pprWithSourceText )
 import Type       ( Type )
 import Outputable
 import FastString
-import PlaceHolder ( PostTc,PostRn,DataId,OutputableBndrId )
+import PlaceHolder ( PostTc,PostRn,DataId,OutputableBndrId, HasOccNameId )
 
 import Data.ByteString (ByteString)
 import Data.Data hiding ( Fixity )
@@ -166,29 +166,34 @@ instance Ord OverLitVal where
   compare (HsIsString _ _)    (HsFractional _)    = GT
 
 instance Outputable HsLit where
-    ppr (HsChar _ c)       = pprHsChar c
-    ppr (HsCharPrim _ c)   = pprPrimChar c
-    ppr (HsString _ s)     = pprHsString s
-    ppr (HsStringPrim _ s) = pprHsBytes s
-    ppr (HsInt _ i)        = integer i
-    ppr (HsInteger _ i _)  = integer i
-    ppr (HsRat f _)        = ppr f
-    ppr (HsFloatPrim f)    = ppr f <> primFloatSuffix
-    ppr (HsDoublePrim d)   = ppr d <> primDoubleSuffix
-    ppr (HsIntPrim _ i)    = pprPrimInt i
-    ppr (HsWordPrim _ w)   = pprPrimWord w
-    ppr (HsInt64Prim _ i)  = pprPrimInt64 i
-    ppr (HsWord64Prim _ w) = pprPrimWord64 w
+    ppr (HsChar st c)       = pprWithSourceText st (pprHsChar c)
+    ppr (HsCharPrim st c)   = pp_st_suffix st primCharSuffix (pprPrimChar c)
+    ppr (HsString st s)     = pprWithSourceText st (pprHsString s)
+    ppr (HsStringPrim st s) = pprWithSourceText st (pprHsBytes s)
+    ppr (HsInt st i)        = pprWithSourceText st (integer i)
+    ppr (HsInteger st i _)  = pprWithSourceText st (integer i)
+    ppr (HsRat f _)         = ppr f
+    ppr (HsFloatPrim f)     = ppr f <> primFloatSuffix
+    ppr (HsDoublePrim d)    = ppr d <> primDoubleSuffix
+    ppr (HsIntPrim st i)    = pprWithSourceText st (pprPrimInt i)
+    ppr (HsWordPrim st w)   = pprWithSourceText st (pprPrimWord w)
+    ppr (HsInt64Prim st i)  = pp_st_suffix st primInt64Suffix  (pprPrimInt64 i)
+    ppr (HsWord64Prim st w) = pp_st_suffix st primWord64Suffix (pprPrimWord64 w)
+
+pp_st_suffix :: SourceText -> SDoc -> SDoc -> SDoc
+pp_st_suffix NoSourceText         _ doc = doc
+pp_st_suffix (SourceText st) suffix _   = text st <> suffix
 
 -- in debug mode, print the expression that it's resolved to, too
-instance (OutputableBndrId id) => Outputable (HsOverLit id) where
+instance (OutputableBndrId id, HasOccNameId id)
+           => Outputable (HsOverLit id) where
   ppr (OverLit {ol_val=val, ol_witness=witness})
         = ppr val <+> (ifPprDebug (parens (pprExpr witness)))
 
 instance Outputable OverLitVal where
-  ppr (HsIntegral _ i)   = integer i
+  ppr (HsIntegral st i)  = pprWithSourceText st (integer i)
   ppr (HsFractional f)   = ppr f
-  ppr (HsIsString _ s)   = pprHsString s
+  ppr (HsIsString st s)  = pprWithSourceText st (pprHsString s)
 
 -- | pmPprHsLit pretty prints literals and is used when pretty printing pattern
 -- match warnings. All are printed the same (i.e., without hashes if they are
@@ -199,7 +204,7 @@ instance Outputable OverLitVal where
 pmPprHsLit :: HsLit -> SDoc
 pmPprHsLit (HsChar _ c)       = pprHsChar c
 pmPprHsLit (HsCharPrim _ c)   = pprHsChar c
-pmPprHsLit (HsString _ s)     = pprHsString s
+pmPprHsLit (HsString st s)    = pprWithSourceText st (pprHsString s)
 pmPprHsLit (HsStringPrim _ s) = pprHsBytes s
 pmPprHsLit (HsInt _ i)        = integer i
 pmPprHsLit (HsIntPrim _ i)    = integer i
index ec5578f..853e8cb 100644 (file)
@@ -409,7 +409,8 @@ hsRecUpdFieldOcc = fmap unambiguousFieldOcc . hsRecFieldLbl
 ************************************************************************
 -}
 
-instance (OutputableBndrId name) => Outputable (Pat name) where
+instance (OutputableBndrId name, HasOccNameId name)
+        => Outputable (Pat name) where
     ppr = pprPat
 
 pprPatBndr :: OutputableBndr name => name -> SDoc
@@ -421,10 +422,11 @@ pprPatBndr var                  -- Print with type info if -dppr-debug is on
     else
         pprPrefixOcc var
 
-pprParendLPat :: (OutputableBndrId name) => LPat name -> SDoc
+pprParendLPat :: (OutputableBndrId name, HasOccNameId name)
+              => LPat name -> SDoc
 pprParendLPat (L _ p) = pprParendPat p
 
-pprParendPat :: (OutputableBndrId name) => Pat name -> SDoc
+pprParendPat :: (OutputableBndrId name, HasOccNameId name) => Pat name -> SDoc
 pprParendPat p = sdocWithDynFlags $ \ dflags ->
                  if need_parens dflags p
                  then parens (pprPat p)
@@ -438,7 +440,7 @@ pprParendPat p = sdocWithDynFlags $ \ dflags ->
       -- But otherwise the CoPat is discarded, so it
       -- is the pattern inside that matters.  Sigh.
 
-pprPat :: (OutputableBndrId name) => Pat name -> SDoc
+pprPat :: (OutputableBndrId name, HasOccNameId name) => Pat name -> SDoc
 pprPat (VarPat (L _ var))     = pprPatBndr var
 pprPat (WildPat _)            = char '_'
 pprPat (LazyPat pat)          = char '~' <> pprParendLPat pat
@@ -475,12 +477,13 @@ pprPat (ConPatOut { pat_con = con, pat_tvs = tvs, pat_dicts = dicts,
     else pprUserCon (unLoc con) details
 
 
-pprUserCon :: (OutputableBndr con, OutputableBndrId id)
+pprUserCon :: (OutputableBndr con, OutputableBndrId id, HasOccNameId id)
            => con -> HsConPatDetails id -> SDoc
 pprUserCon c (InfixCon p1 p2) = ppr p1 <+> pprInfixOcc c <+> ppr p2
 pprUserCon c details          = pprPrefixOcc c <+> pprConArgs details
 
-pprConArgs :: (OutputableBndrId id) => HsConPatDetails id -> SDoc
+pprConArgs :: (OutputableBndrId id, HasOccNameId id)
+           => HsConPatDetails id -> SDoc
 pprConArgs (PrefixCon pats) = sep (map pprParendLPat pats)
 pprConArgs (InfixCon p1 p2) = sep [pprParendLPat p1, pprParendLPat p2]
 pprConArgs (RecCon rpats)   = ppr rpats
@@ -519,7 +522,7 @@ mkPrefixConPat dc pats tys
 mkNilPat :: Type -> OutPat id
 mkNilPat ty = mkPrefixConPat nilDataCon [] [ty]
 
-mkCharLitPat :: String -> Char -> OutPat id
+mkCharLitPat :: SourceText -> Char -> OutPat id
 mkCharLitPat src c = mkPrefixConPat charDataCon
                                     [noLoc $ LitPat (HsCharPrim src c)] []
 
@@ -595,7 +598,7 @@ looksLazyLPat (L _ (VarPat {}))            = False
 looksLazyLPat (L _ (WildPat {}))           = False
 looksLazyLPat _                            = True
 
-isIrrefutableHsPat :: (OutputableBndrId id) => LPat id -> Bool
+isIrrefutableHsPat :: (OutputableBndrId id, HasOccNameId id) => LPat id -> Bool
 -- (isIrrefutableHsPat p) is true if matching against p cannot fail,
 -- in the sense of falling through to the next pattern.
 --      (NB: this is not quite the same as the (silly) defn
@@ -670,9 +673,9 @@ hsPatNeedsParens (LitPat {})         = False
 hsPatNeedsParens (NPat {})           = False
 
 conPatNeedsParens :: HsConDetails a b -> Bool
-conPatNeedsParens (PrefixCon args) = not (null args)
-conPatNeedsParens (InfixCon {})    = True
-conPatNeedsParens (RecCon {})      = True
+conPatNeedsParens (PrefixCon {}) = False
+conPatNeedsParens (InfixCon {})  = True
+conPatNeedsParens (RecCon {})    = False
 
 {-
 % Collect all EvVars from all constructor patterns
index aba5686..8bcaa5a 100644 (file)
@@ -10,11 +10,11 @@ import SrcLoc( Located )
 
 import Data.Data hiding (Fixity)
 import Outputable
-import PlaceHolder      ( DataId, OutputableBndrId )
+import PlaceHolder      ( DataId, OutputableBndrId,HasOccNameId )
 
 type role Pat nominal
 data Pat (i :: *)
 type LPat i = Located (Pat i)
 
 instance (DataId id) => Data (Pat id)
-instance (OutputableBndrId name) => Outputable (Pat name)
+instance (OutputableBndrId name, HasOccNameId name) => Outputable (Pat name)
index 1e5a4bb..93e4354 100644 (file)
@@ -46,7 +46,6 @@ import HsUtils
 import HsDoc
 
 -- others:
-import OccName          ( HasOccName )
 import Outputable
 import SrcLoc
 import Module           ( ModuleName )
@@ -109,7 +108,7 @@ data HsModule name
      -- For details on above see note [Api annotations] in ApiAnnotation
 deriving instance (DataId name) => Data (HsModule name)
 
-instance (OutputableBndrId name, HasOccName name)
+instance (OutputableBndrId name, HasOccNameId name)
         => Outputable (HsModule name) where
 
     ppr (HsModule Nothing _ imports decls _ mbDoc)
index 6d82f92..e3e5246 100644 (file)
@@ -24,6 +24,7 @@ module HsTypes (
         HsWildCardBndrs(..),
         LHsSigType, LHsSigWcType, LHsWcType,
         HsTupleSort(..),
+        Promoted(..),
         HsContext, LHsContext,
         HsTyLit(..),
         HsIPName(..), hsIPNameFS,
@@ -70,7 +71,7 @@ module HsTypes (
 import {-# SOURCE #-} HsExpr ( HsSplice, pprSplice )
 
 import PlaceHolder ( PostTc,PostRn,DataId,PlaceHolder(..),
-                     OutputableBndrId )
+                     OutputableBndrId, HasOccNameId )
 
 import Id ( Id )
 import Name( Name )
@@ -112,7 +113,7 @@ getBangType ty                    = ty
 
 getBangStrictness :: LHsType a -> HsSrcBang
 getBangStrictness (L _ (HsBangTy s _)) = s
-getBangStrictness _ = (HsSrcBang Nothing NoSrcUnpack NoSrcStrict)
+getBangStrictness _ = (HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict)
 
 {-
 ************************************************************************
@@ -432,7 +433,9 @@ data HsType name
       { hst_ctxt :: LHsContext name       -- Context C => blah
       , hst_body :: LHsType name }
 
-  | HsTyVar    (Located name)
+  | HsTyVar             Promoted -- whether explictly promoted, for the pretty
+                                 -- printer
+                        (Located name)
                   -- Type variable, type constructor, or data constructor
                   -- see Note [Promotions (HsTyVar)]
                   -- See Note [Located RdrNames] in HsExpr
@@ -440,7 +443,7 @@ data HsType name
 
       -- For details on above see note [Api annotations] in ApiAnnotation
 
-  | HsAppsTy            [LHsAppType name]  -- Used only before renaming,
+  | HsAppsTy            [LHsAppType name] -- Used only before renaming,
                                           -- Note [HsAppsTy]
       -- ^ - 'ApiAnnotation.AnnKeywordId' : None
 
@@ -555,6 +558,7 @@ data HsType name
       -- For details on above see note [Api annotations] in ApiAnnotation
 
   | HsExplicitListTy       -- A promoted explicit list
+        Promoted           -- whether explcitly promoted, for pretty printer
         (PostTc name Kind) -- See Note [Promoted lists and tuples]
         [LHsType name]
       -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @"'["@,
@@ -606,7 +610,8 @@ data HsAppType name
   | HsAppPrefix (LHsType name)      -- anything else, including things like (+)
 deriving instance (DataId name) => Data (HsAppType name)
 
-instance (OutputableBndrId name) => Outputable (HsAppType name) where
+instance (OutputableBndrId name, HasOccNameId name)
+        => Outputable (HsAppType name) where
   ppr = ppr_app_ty TopPrec
 
 {-
@@ -661,6 +666,9 @@ HsTyVar: A name in a type or kind.
       Tv: kind variable
       TcCls: kind constructor or promoted type constructor
 
+  The 'Promoted' field in an HsTyVar captures whether the type was promoted in
+  the source code by prefixing an apostrophe.
+
 Note [HsAppsTy]
 ~~~~~~~~~~~~~~~
 How to parse
@@ -724,6 +732,11 @@ data HsTupleSort = HsUnboxedTuple
                  deriving Data
 
 
+-- | Promoted data types.
+data Promoted = Promoted
+              | NotPromoted
+              deriving (Data, Eq, Show)
+
 -- | Located Constructor Declaration Field
 type LConDeclField name = Located (ConDeclField name)
       -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnComma' when
@@ -742,7 +755,8 @@ data ConDeclField name  -- Record fields have Haddoc docs on them
       -- For details on above see note [Api annotations] in ApiAnnotation
 deriving instance (DataId name) => Data (ConDeclField name)
 
-instance (OutputableBndrId name) => Outputable (ConDeclField name) where
+instance (OutputableBndrId name, HasOccNameId name)
+       => Outputable (ConDeclField name) where
   ppr (ConDeclField fld_n fld_ty _) = ppr fld_n <+> dcolon <+> ppr fld_ty
 
 -- HsConDetails is used for patterns/expressions *and* for data type
@@ -873,9 +887,9 @@ hsLTyVarLocNames qtvs = map hsLTyVarLocName (hsQTvExplicit qtvs)
 -- | Convert a LHsTyVarBndr to an equivalent LHsType.
 hsLTyVarBndrToType :: LHsTyVarBndr name -> LHsType name
 hsLTyVarBndrToType = fmap cvt
-  where cvt (UserTyVar n)                     = HsTyVar n
+  where cvt (UserTyVar n) = HsTyVar NotPromoted n
         cvt (KindedTyVar (L name_loc n) kind)
-                   = HsKindSig (L name_loc (HsTyVar (L name_loc n))) kind
+          = HsKindSig (L name_loc (HsTyVar NotPromoted (L name_loc n))) kind
 
 -- | Convert a LHsTyVarBndrs to a list of types.
 -- Works on *type* variable only, no kind vars.
@@ -942,7 +956,7 @@ splitHsFunType (L _ (HsFunTy x y))
 splitHsFunType orig_ty@(L _ (HsAppTy t1 t2))
   = go t1 [t2]
   where  -- Look for (->) t1 t2, possibly with parenthesisation
-    go (L _ (HsTyVar (L _ fn))) tys | fn == funTyConName
+    go (L _ (HsTyVar (L _ fn))) tys | fn == funTyConName
                                  , [t1,t2] <- tys
                                  , (args, res) <- splitHsFunType t2
                                  = (t1:args, res)
@@ -960,7 +974,8 @@ getAppsTyHead_maybe tys = case splitHsAppsTy tys of
   ([app1:apps], []) ->  -- no symbols, some normal types
     Just (mkHsAppTys app1 apps, [])
   ([app1l:appsl, app1r:appsr], [L loc op]) ->  -- one operator
-    Just (L loc (HsTyVar (L loc op)), [mkHsAppTys app1l appsl, mkHsAppTys app1r appsr])
+    Just ( L loc (HsTyVar NotPromoted (L loc op))
+         , [mkHsAppTys app1l appsl, mkHsAppTys app1r appsr])
   _ -> -- can't figure it out
     Nothing
 
@@ -986,7 +1001,7 @@ splitHsAppsTy = go [] [] []
 hsTyGetAppHead_maybe :: LHsType name -> Maybe (Located name, [LHsType name])
 hsTyGetAppHead_maybe = go []
   where
-    go tys (L _ (HsTyVar ln))           = Just (ln, tys)
+    go tys (L _ (HsTyVar _ ln))          = Just (ln, tys)
     go tys (L _ (HsAppsTy apps))
       | Just (head, args) <- getAppsTyHead_maybe apps
                                          = go (args ++ tys) head
@@ -1137,16 +1152,19 @@ ambiguousFieldOcc (FieldOcc rdr sel) = Unambiguous rdr sel
 ************************************************************************
 -}
 
-instance (OutputableBndrId name) => Outputable (HsType name) where
+instance (OutputableBndrId name, HasOccNameId name)
+       => Outputable (HsType name) where
     ppr ty = pprHsType ty
 
 instance Outputable HsTyLit where
     ppr = ppr_tylit
 
-instance (OutputableBndrId name) => Outputable (LHsQTyVars name) where
+instance (OutputableBndrId name, HasOccNameId name)
+        => Outputable (LHsQTyVars name) where
     ppr (HsQTvs { hsq_explicit = tvs }) = interppSP tvs
 
-instance (OutputableBndrId name) => Outputable (HsTyVarBndr name) where
+instance (OutputableBndrId name, HasOccNameId name)
+          => Outputable (HsTyVarBndr name) where
     ppr (UserTyVar n)     = ppr n
     ppr (KindedTyVar n k) = parens $ hsep [ppr n, dcolon, ppr k]
 
@@ -1159,7 +1177,7 @@ instance (Outputable thing) => Outputable (HsWildCardBndrs name thing) where
 instance Outputable (HsWildCardInfo name) where
     ppr (AnonWildCard _)  = char '_'
 
-pprHsForAll :: (OutputableBndrId name)
+pprHsForAll :: (OutputableBndrId name, HasOccNameId name)
             => [LHsTyVarBndr name] -> LHsContext name -> SDoc
 pprHsForAll = pprHsForAllExtra Nothing
 
@@ -1170,7 +1188,7 @@ pprHsForAll = pprHsForAllExtra Nothing
 -- function for this is needed, as the extra-constraints wildcard is removed
 -- from the actual context and type, and stored in a separate field, thus just
 -- printing the type will not print the extra-constraints wildcard.
-pprHsForAllExtra :: (OutputableBndrId name)
+pprHsForAllExtra :: (OutputableBndrId name, HasOccNameId name)
                  => Maybe SrcSpan -> [LHsTyVarBndr name] -> LHsContext name
                  -> SDoc
 pprHsForAllExtra extra qtvs cxt
@@ -1178,26 +1196,38 @@ pprHsForAllExtra extra qtvs cxt
   where
     show_extra = isJust extra
 
-pprHsForAllTvs :: (OutputableBndrId name) => [LHsTyVarBndr name] -> SDoc
+pprHsForAllTvs :: (OutputableBndrId name, HasOccNameId name)
+               => [LHsTyVarBndr name] -> SDoc
 pprHsForAllTvs qtvs
   | show_forall = forAllLit <+> interppSP qtvs <> dot
   | otherwise   = empty
   where
     show_forall = opt_PprStyle_Debug || not (null qtvs)
 
-pprHsContext :: (OutputableBndrId name) => HsContext name -> SDoc
+pprHsContext :: (OutputableBndrId name, HasOccNameId name)
+             => HsContext name -> SDoc
 pprHsContext = maybe empty (<+> darrow) . pprHsContextMaybe
 
-pprHsContextNoArrow :: (OutputableBndrId name) => HsContext name -> SDoc
+pprHsContextNoArrow :: (OutputableBndrId name, HasOccNameId name)
+                    => HsContext name -> SDoc
 pprHsContextNoArrow = fromMaybe empty . pprHsContextMaybe
 
-pprHsContextMaybe :: (OutputableBndrId name) => HsContext name -> Maybe SDoc
+pprHsContextMaybe :: (OutputableBndrId name, HasOccNameId name)
+                  => HsContext name -> Maybe SDoc
 pprHsContextMaybe []         = Nothing
 pprHsContextMaybe [L _ pred] = Just $ ppr_mono_ty FunPrec pred
 pprHsContextMaybe cxt        = Just $ parens (interpp'SP cxt)
 
+-- For use in a HsQualTy, which always gets printed if it exists.
+pprHsContextAlways :: (OutputableBndrId name, HasOccNameId name)
+                  => HsContext name -> SDoc
+pprHsContextAlways []  = parens empty <+> darrow
+pprHsContextAlways [L _ ty] = ppr_mono_ty FunPrec ty <+> darrow
+pprHsContextAlways cxt = parens (interpp'SP cxt) <+> darrow
+
 -- True <=> print an extra-constraints wildcard, e.g. @(Show a, _) =>@
-pprHsContextExtra :: (OutputableBndrId name) => Bool -> HsContext name -> SDoc
+pprHsContextExtra :: (OutputableBndrId name, HasOccNameId name)
+                  => Bool -> HsContext name -> SDoc
 pprHsContextExtra show_extra ctxt
   | not show_extra
   = pprHsContext ctxt
@@ -1208,7 +1238,8 @@ pprHsContextExtra show_extra ctxt
   where
     ctxt' = map ppr ctxt ++ [char '_']
 
-pprConDeclFields :: (OutputableBndrId name) => [LConDeclField name] -> SDoc
+pprConDeclFields :: (OutputableBndrId name, HasOccNameId name)
+                 => [LConDeclField name] -> SDoc
 pprConDeclFields fields = braces (sep (punctuate comma (map ppr_fld fields)))
   where
     ppr_fld (L _ (ConDeclField { cd_fld_names = ns, cd_fld_type = ty,
@@ -1232,32 +1263,32 @@ seems like the Right Thing anyway.)
 
 -- Printing works more-or-less as for Types
 
-pprHsType, pprParendHsType :: (OutputableBndrId name) => HsType name -> SDoc
+pprHsType, pprParendHsType :: (OutputableBndrId name, HasOccNameId name)
+                           => HsType name -> SDoc
 
-pprHsType ty       = ppr_mono_ty TopPrec (prepare ty)
+pprHsType ty       = ppr_mono_ty TopPrec ty
 pprParendHsType ty = ppr_mono_ty TyConPrec ty
 
--- Before printing a type, remove outermost HsParTy parens
-prepare :: HsType name -> HsType name
-prepare (HsParTy ty)                            = prepare (unLoc ty)
-prepare (HsAppsTy [L _ (HsAppPrefix (L _ ty))]) = prepare ty
-prepare ty                                      = ty
-
-ppr_mono_lty :: (OutputableBndrId name) => TyPrec -> LHsType name -> SDoc
+ppr_mono_lty :: (OutputableBndrId name, HasOccNameId name)
+             => TyPrec -> LHsType name -> SDoc
 ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty)
 
-ppr_mono_ty :: (OutputableBndrId name) => TyPrec -> HsType name -> SDoc
+ppr_mono_ty :: (OutputableBndrId name, HasOccNameId name)
+            => TyPrec -> HsType name -> SDoc
 ppr_mono_ty ctxt_prec (HsForAllTy { hst_bndrs = tvs, hst_body = ty })
   = maybeParen ctxt_prec FunPrec $
     sep [pprHsForAllTvs tvs, ppr_mono_lty TopPrec ty]
 
-ppr_mono_ty ctxt_prec (HsQualTy { hst_ctxt = L _ ctxt, hst_body = ty })
-  = maybeParen ctxt_prec FunPrec $
-    sep [pprHsContext ctxt, ppr_mono_lty TopPrec ty]
+ppr_mono_ty _ctxt_prec (HsQualTy { hst_ctxt = L _ ctxt, hst_body = ty })
+  = sep [pprHsContextAlways ctxt, ppr_mono_lty TopPrec ty]
 
 ppr_mono_ty _    (HsBangTy b ty)     = ppr b <> ppr_mono_lty TyConPrec ty
 ppr_mono_ty _    (HsRecTy flds)      = pprConDeclFields flds
-ppr_mono_ty _    (HsTyVar (L _ name))= pprPrefixOcc name
+ppr_mono_ty _    (HsTyVar NotPromoted (L _ name))= pprPrefixOcc name
+ppr_mono_ty _    (HsTyVar Promoted (L _ name))
+  = space <> quote (pprPrefixOcc name)
+                         -- We need a space before the ' above, so the parser
+                         -- does not attach it to the previous symbol
 ppr_mono_ty prec (HsFunTy ty1 ty2)   = ppr_fun_ty prec ty1 ty2
 ppr_mono_ty _    (HsTupleTy con tys) = tupleParens std_con (pprWithCommas ppr tys)
   where std_con = case con of
@@ -1270,7 +1301,10 @@ ppr_mono_ty _    (HsPArrTy ty)       = paBrackets (ppr_mono_lty TopPrec ty)
 ppr_mono_ty prec (HsIParamTy n ty)   = maybeParen prec FunPrec (ppr n <+> dcolon <+> ppr_mono_lty TopPrec ty)
 ppr_mono_ty _    (HsSpliceTy s _)    = pprSplice s
 ppr_mono_ty _    (HsCoreTy ty)       = ppr ty
-ppr_mono_ty _    (HsExplicitListTy _ tys)  = quote $ brackets (interpp'SP tys)
+ppr_mono_ty _    (HsExplicitListTy Promoted _ tys)
+  = quote $ brackets (interpp'SP tys)
+ppr_mono_ty _    (HsExplicitListTy NotPromoted _ tys)
+  = brackets (interpp'SP tys)
 ppr_mono_ty _    (HsExplicitTupleTy _ tys) = quote $ parens (interpp'SP tys)
 ppr_mono_ty _    (HsTyLit t)         = ppr_tylit t
 ppr_mono_ty _    (HsWildCardTy {})   = char '_'
@@ -1279,13 +1313,11 @@ ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2)
   = maybeParen ctxt_prec TyOpPrec $
     ppr_mono_lty TyOpPrec ty1 <+> char '~' <+> ppr_mono_lty TyOpPrec ty2
 
-ppr_mono_ty ctxt_prec (HsAppsTy tys)
-  = maybeParen ctxt_prec TyConPrec $
-    hsep (map (ppr_app_ty TopPrec . unLoc) tys)
+ppr_mono_ty _ctxt_prec (HsAppsTy tys)
+  = hsep (map (ppr_app_ty TopPrec . unLoc) tys)
 
-ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty)
-  = maybeParen ctxt_prec TyConPrec $
-    hsep [ppr_mono_lty FunPrec fun_ty, ppr_mono_lty TyConPrec arg_ty]
+ppr_mono_ty _ctxt_prec (HsAppTy fun_ty arg_ty)
+  = hsep [ppr_mono_lty FunPrec fun_ty, ppr_mono_lty TyConPrec arg_ty]
 
 ppr_mono_ty ctxt_prec (HsOpTy ty1 (L _ op) ty2)
   = maybeParen ctxt_prec TyOpPrec $
@@ -1305,7 +1337,7 @@ ppr_mono_ty ctxt_prec (HsDocTy ty doc)
   -- postfix operators
 
 --------------------------
-ppr_fun_ty :: (OutputableBndrId name)
+ppr_fun_ty :: (OutputableBndrId name, HasOccNameId name)
            => TyPrec -> LHsType name -> LHsType name -> SDoc
 ppr_fun_ty ctxt_prec ty1 ty2
   = let p1 = ppr_mono_lty FunPrec ty1
@@ -1315,9 +1347,15 @@ ppr_fun_ty ctxt_prec ty1 ty2
     sep [p1, text "->" <+> p2]
 
 --------------------------
-ppr_app_ty :: (OutputableBndrId name) => TyPrec -> HsAppType name -> SDoc
+ppr_app_ty :: (OutputableBndrId name, HasOccNameId name)
+           => TyPrec -> HsAppType name -> SDoc
 ppr_app_ty _    (HsAppInfix (L _ n))                  = pprInfixOcc n
-ppr_app_ty _    (HsAppPrefix (L _ (HsTyVar (L _ n)))) = pprPrefixOcc n
+ppr_app_ty _    (HsAppPrefix (L _ (HsTyVar NotPromoted (L _ n))))
+  = pprPrefixOcc n
+ppr_app_ty _    (HsAppPrefix (L _ (HsTyVar Promoted  (L _ n))))
+  = space <> quote (pprPrefixOcc n) -- We need a space before the ' above, so
+                                    -- the parser does not attach it to the
+                                    -- previous symbol
 ppr_app_ty ctxt (HsAppPrefix ty)                      = ppr_mono_lty ctxt ty
 
 --------------------------
index f1500bb..b49cd98 100644 (file)
@@ -49,13 +49,13 @@ module HsUtils(
   -- Patterns
   mkNPat, mkNPlusKPat, nlVarPat, nlLitPat, nlConVarPat, nlConVarPatName, nlConPat,
   nlConPatName, nlInfixConPat, nlNullaryConPat, nlWildConPat, nlWildPat,
-  nlWildPatName, nlWildPatId, nlTuplePat, mkParPat,
+  nlWildPatName, nlWildPatId, nlTuplePat, mkParPat, nlParPat,
   mkBigLHsVarTup, mkBigLHsTup, mkBigLHsVarPatTup, mkBigLHsPatTup,
 
   -- Types
   mkHsAppTy, mkHsAppTys, userHsTyVarBndrs, userHsLTyVarBndrs,
   mkLHsSigType, mkLHsSigWcType, mkClassOpSigs, mkHsSigEnv,
-  nlHsAppTy, nlHsTyVar, nlHsFunTy, nlHsTyConApp,
+  nlHsAppTy, nlHsTyVar, nlHsFunTy, nlHsParTy, nlHsTyConApp,
 
   -- Stmts
   mkTransformStmt, mkTransformByStmt, mkBodyStmt, mkBindStmt, mkTcBindStmt,
@@ -207,14 +207,18 @@ mkParPat :: LPat name -> LPat name
 mkParPat lp@(L loc p) | hsPatNeedsParens p = L loc (ParPat lp)
                       | otherwise          = lp
 
+nlParPat :: LPat name -> LPat name
+nlParPat p = noLoc (ParPat p)
 
 -------------------------------
 -- These are the bits of syntax that contain rebindable names
 -- See RnEnv.lookupSyntaxName
 
-mkHsIntegral   :: String -> Integer -> PostTc RdrName Type -> HsOverLit RdrName
+mkHsIntegral   :: SourceText -> Integer -> PostTc RdrName Type
+               -> HsOverLit RdrName
 mkHsFractional :: FractionalLit -> PostTc RdrName Type -> HsOverLit RdrName
-mkHsIsString :: String -> FastString -> PostTc RdrName Type -> HsOverLit RdrName
+mkHsIsString :: SourceText -> FastString -> PostTc RdrName Type
+             -> HsOverLit RdrName
 mkHsDo         :: HsStmtContext Name -> [ExprLStmt RdrName] -> HsExpr RdrName
 mkHsComp       :: HsStmtContext Name -> [ExprLStmt RdrName] -> LHsExpr RdrName
                -> HsExpr RdrName
@@ -312,17 +316,18 @@ mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar (noLoc op)))
 unqualSplice :: RdrName
 unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice"))
 
-mkUntypedSplice :: LHsExpr RdrName -> HsSplice RdrName
-mkUntypedSplice e = HsUntypedSplice unqualSplice e
+mkUntypedSplice :: HasParens -> LHsExpr RdrName -> HsSplice RdrName
+mkUntypedSplice hasParen e = HsUntypedSplice hasParen unqualSplice e
 
-mkHsSpliceE :: LHsExpr RdrName -> HsExpr RdrName
-mkHsSpliceE e = HsSpliceE (mkUntypedSplice e)
+mkHsSpliceE :: HasParens -> LHsExpr RdrName -> HsExpr RdrName
+mkHsSpliceE hasParen e = HsSpliceE (mkUntypedSplice hasParen e)
 
-mkHsSpliceTE :: LHsExpr RdrName -> HsExpr RdrName
-mkHsSpliceTE e = HsSpliceE (HsTypedSplice unqualSplice e)
+mkHsSpliceTE :: HasParens -> LHsExpr RdrName -> HsExpr RdrName
+mkHsSpliceTE hasParen e = HsSpliceE (HsTypedSplice hasParen unqualSplice e)
 
-mkHsSpliceTy :: LHsExpr RdrName -> HsType RdrName
-mkHsSpliceTy e = HsSpliceTy (HsUntypedSplice unqualSplice e) placeHolderKind
+mkHsSpliceTy :: HasParens -> LHsExpr RdrName -> HsType RdrName
+mkHsSpliceTy hasParen e
+  = HsSpliceTy (HsUntypedSplice hasParen unqualSplice e) placeHolderKind
 
 mkHsQuasiQuote :: RdrName -> SrcSpan -> FastString -> HsSplice RdrName
 mkHsQuasiQuote quoter span quote = HsQuasiQuote unqualSplice quoter span quote
@@ -333,11 +338,11 @@ unqualQuasiQuote = mkRdrUnqual (mkVarOccFS (fsLit "quasiquote"))
                 -- identify the quasi-quote
 
 mkHsString :: String -> HsLit
-mkHsString s = HsString s (mkFastString s)
+mkHsString s = HsString NoSourceText (mkFastString s)
 
 mkHsStringPrimLit :: FastString -> HsLit
 mkHsStringPrimLit fs
-  = HsStringPrim (unpackFS fs) (fastStringToByteString fs)
+  = HsStringPrim NoSourceText (fastStringToByteString fs)
 
 -------------
 userHsLTyVarBndrs :: SrcSpan -> [Located name] -> [LHsTyVarBndr name]
@@ -385,7 +390,7 @@ nlHsSyntaxApps (SyntaxExpr { syn_expr      = fun
                                                      mkLHsWrap arg_wraps args))
 
 nlHsIntLit :: Integer -> LHsExpr id
-nlHsIntLit n = noLoc (HsLit (HsInt (show n) n))
+nlHsIntLit n = noLoc (HsLit (HsInt NoSourceText n))
 
 nlHsApps :: id -> [LHsExpr id] -> LHsExpr id
 nlHsApps f xs = foldl nlHsApp (nlHsVar f) xs
@@ -455,10 +460,12 @@ nlList exprs           = noLoc (ExplicitList placeHolderType Nothing exprs)
 nlHsAppTy :: LHsType name -> LHsType name -> LHsType name
 nlHsTyVar :: name                         -> LHsType name
 nlHsFunTy :: LHsType name -> LHsType name -> LHsType name
+nlHsParTy :: LHsType name                 -> LHsType name
 
 nlHsAppTy f t           = noLoc (HsAppTy f t)
-nlHsTyVar x             = noLoc (HsTyVar (noLoc x))
+nlHsTyVar x             = noLoc (HsTyVar NotPromoted (noLoc x))
 nlHsFunTy a b           = noLoc (HsFunTy a b)
+nlHsParTy t             = noLoc (HsParTy t)
 
 nlHsTyConApp :: name -> [LHsType name] -> LHsType name
 nlHsTyConApp tycon tys  = foldl nlHsAppTy (nlHsTyVar tycon) tys
@@ -613,8 +620,8 @@ typeToLHsType ty
                           , hst_body = go tau })
     go (TyVarTy tv)         = nlHsTyVar (getRdrName tv)
     go (AppTy t1 t2)        = nlHsAppTy (go t1) (go t2)
-    go (LitTy (NumTyLit n)) = noLoc $ HsTyLit (HsNumTy "" n)
-    go (LitTy (StrTyLit s)) = noLoc $ HsTyLit (HsStrTy "" s)
+    go (LitTy (NumTyLit n)) = noLoc $ HsTyLit (HsNumTy NoSourceText n)
+    go (LitTy (StrTyLit s)) = noLoc $ HsTyLit (HsStrTy NoSourceText s)
     go (TyConApp tc args)   = nlHsTyConApp (getRdrName tc) (map go args')
        where
          args' = filterOutInvisibleTypes tc args
index 2e195df..c29e8f9 100644 (file)
@@ -142,3 +142,10 @@ type OutputableBndrId id =
   ( OutputableBndr id
   , OutputableBndr (NameOrRdrName id)
   )
+
+-- |Constraint type to bundle up the requirement for 'HasOccName' on both
+-- the @id@ and the 'NameOrRdrName' type for it
+type HasOccNameId id =
+  ( HasOccName id
+  , HasOccName (NameOrRdrName id)
+  )
index 0337abc..b291bc5 100644 (file)
@@ -390,7 +390,7 @@ buildClass tycon_name binders roles sc_theta
         ; traceIf (text "buildClass" <+> ppr tycon)
         ; return result }
   where
-    no_bang = HsSrcBang Nothing NoSrcUnpack NoSrcStrict
+    no_bang = HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict
 
     mk_op_item :: Class -> TcMethInfo -> TcRnIf n m ClassOpItem
     mk_op_item rec_clas (op_name, _, dm_spec)
index 48bc316..921943a 100644 (file)
@@ -923,7 +923,8 @@ ghcPrimIface
         mi_fix_fn  = mkIfaceFixCache fixities
     }
   where
-    fixities = (getOccName seqId, Fixity "0" 0 InfixR)  -- seq is infixr 0
+    fixities = (getOccName seqId, Fixity NoSourceText 0 InfixR)
+                                      -- seq is infixr 0
              : (occName funTyConName, funTyFixity)  -- trac #10145
              : mapMaybe mkFixity allThePrimOps
     mkFixity op = (,) (primOpOcc op) <$> primOpFixity op
index 6baffed..123b02f 100644 (file)
@@ -803,7 +803,7 @@ tcIfaceDataCons tycon_name tycon tc_tybinders if_cons
                                       ; return (HsUnpack (Just co)) }
 
     src_strict :: IfaceSrcBang -> HsSrcBang
-    src_strict (IfSrcBang unpk bang) = HsSrcBang Nothing unpk bang
+    src_strict (IfSrcBang unpk bang) = HsSrcBang NoSourceText unpk bang
 
 tcIfaceEqSpec :: IfaceEqSpec -> IfL [EqSpec]
 tcIfaceEqSpec spec
index 2c27de1..ceb566c 100644 (file)
@@ -117,7 +117,7 @@ mkPrelImports this_mod loc implicit_prelude import_decls
 
       preludeImportDecl :: LImportDecl RdrName
       preludeImportDecl
-        = L loc $ ImportDecl { ideclSourceSrc = Nothing,
+        = L loc $ ImportDecl { ideclSourceSrc = NoSourceText,
                                ideclName      = L loc pRELUDE_NAME,
                                ideclPkgQual   = Nothing,
                                ideclSource    = False,
index 6800fab..14a7cb2 100644 (file)
@@ -114,7 +114,7 @@ import DynFlags
 import SrcLoc
 import Module
 import BasicTypes     ( InlineSpec(..), RuleMatchInfo(..), FractionalLit(..),
-                        SourceText )
+                        SourceText(..) )
 
 -- compiler/parser
 import Ctype
@@ -1126,7 +1126,7 @@ rulePrag :: Action
 rulePrag span buf len = do
   setExts (.|. xbit InRulePragBit)
   let !src = lexemeToString buf len
-  return (L span (ITrules_prag src))
+  return (L span (ITrules_prag (SourceText src)))
 
 endPrag :: Action
 endPrag span _buf _len = do
@@ -1260,13 +1260,13 @@ sym con span buf len =
     !fs = lexemeToFastString buf len
 
 -- Variations on the integral numeric literal.
-tok_integral :: (String -> Integer -> Token)
+tok_integral :: (SourceText -> Integer -> Token)
              -> (Integer -> Integer)
              -> Int -> Int
              -> (Integer, (Char -> Int))
              -> Action
 tok_integral itint transint transbuf translen (radix,char_to_int) span buf len
- = return $ L span $ itint (lexemeToString buf len)
+ = return $ L span $ itint (SourceText $ lexemeToString buf len)
        $! transint $ parseUnsignedInteger
        (offsetBytes transbuf buf) (subtract translen len) radix char_to_int
 
@@ -1452,8 +1452,8 @@ lex_string_tok span buf _len = do
   (AI end bufEnd) <- getInput
   let
     tok' = case tok of
-            ITprimstring _ bs -> ITprimstring src bs
-            ITstring _ s -> ITstring src s
+            ITprimstring _ bs -> ITprimstring (SourceText src) bs
+            ITstring _ s -> ITstring (SourceText src) s
             _ -> panic "lex_string_tok"
     src = lexemeToString buf (cur bufEnd - cur buf)
   return (L (mkRealSrcSpan (realSrcSpanStart span) end) tok')
@@ -1476,11 +1476,13 @@ lex_string s = do
                    if any (> '\xFF') s
                     then failMsgP "primitive string literal must contain only characters <= \'\\xFF\'"
                     else let bs = unsafeMkByteString (reverse s)
-                         in return (ITprimstring "" bs)
+                         in return (ITprimstring (SourceText (reverse s)) bs)
               _other ->
-                return (ITstring "" (mkFastString (reverse s)))
+                return (ITstring (SourceText (reverse s))
+                                 (mkFastString (reverse s)))
           else
-                return (ITstring "" (mkFastString (reverse s)))
+                return (ITstring (SourceText (reverse s))
+                                 (mkFastString (reverse s)))
 
     Just ('\\',i)
         | Just ('&',i) <- next -> do
@@ -1555,14 +1557,16 @@ finish_char_tok buf loc ch  -- We've already seen the closing quote
         i@(AI end bufEnd) <- getInput
         let src = lexemeToString buf (cur bufEnd - cur buf)
         if magicHash then do
-                case alexGetChar' i of
-                        Just ('#',i@(AI end _)) -> do
-                          setInput i
-                          return (L (mkRealSrcSpan loc end) (ITprimchar src ch))
-                        _other ->
-                          return (L (mkRealSrcSpan loc end) (ITchar src ch))
+            case alexGetChar' i of
+              Just ('#',i@(AI end _)) -> do
+                setInput i
+                return (L (mkRealSrcSpan loc end)
+                          (ITprimchar (SourceText src) ch))
+              _other ->
+                return (L (mkRealSrcSpan loc end)
+                          (ITchar (SourceText src) ch))
             else do
-                   return (L (mkRealSrcSpan loc end) (ITchar src ch))
+              return (L (mkRealSrcSpan loc end) (ITchar (SourceText src) ch))
 
 isAny :: Char -> Bool
 isAny c | c > '\x7f' = isPrint c
@@ -2713,37 +2717,46 @@ ignoredPrags = Map.fromList (map ignored pragmas)
                      pragmas = options_pragmas ++ ["cfiles", "contract"]
 
 oneWordPrags = Map.fromList([
-           ("rules", rulePrag),
-           ("inline", strtoken (\s -> (ITinline_prag s Inline FunLike))),
-           ("inlinable", strtoken (\s -> (ITinline_prag s Inlinable FunLike))),
-           ("inlineable", strtoken (\s -> (ITinline_prag s Inlinable FunLike))),
-                                          -- Spelling variant
-           ("notinline", strtoken (\s -> (ITinline_prag s NoInline FunLike))),
-           ("specialize", strtoken (\s -> ITspec_prag s)),
-           ("source", strtoken (\s -> ITsource_prag s)),
-           ("warning", strtoken (\s -> ITwarning_prag s)),
-           ("deprecated", strtoken (\s -> ITdeprecated_prag s)),
-           ("scc", strtoken (\s -> ITscc_prag s)),
-           ("generated", strtoken (\s -> ITgenerated_prag s)),
-           ("core", strtoken (\s -> ITcore_prag s)),
-           ("unpack", strtoken (\s -> ITunpack_prag s)),
-           ("nounpack", strtoken (\s -> ITnounpack_prag s)),
-           ("ann", strtoken (\s -> ITann_prag s)),
-           ("vectorize", strtoken (\s -> ITvect_prag s)),
-           ("novectorize", strtoken (\s -> ITnovect_prag s)),
-           ("minimal", strtoken (\s -> ITminimal_prag s)),
-           ("overlaps", strtoken (\s -> IToverlaps_prag s)),
-           ("overlappable", strtoken (\s -> IToverlappable_prag s)),
-           ("overlapping", strtoken (\s -> IToverlapping_prag s)),
-           ("incoherent", strtoken (\s -> ITincoherent_prag s)),
-           ("ctype", strtoken (\s -> ITctype s))])
+     ("rules", rulePrag),
+     ("inline",
+         strtoken (\s -> (ITinline_prag (SourceText s) Inline FunLike))),
+     ("inlinable",
+         strtoken (\s -> (ITinline_prag (SourceText s) Inlinable FunLike))),
+     ("inlineable",
+         strtoken (\s -> (ITinline_prag (SourceText s) Inlinable FunLike))),
+                                    -- Spelling variant
+     ("notinline",
+         strtoken (\s -> (ITinline_prag (SourceText s) NoInline FunLike))),
+     ("specialize", strtoken (\s -> ITspec_prag (SourceText s))),
+     ("source", strtoken (\s -> ITsource_prag (SourceText s))),
+     ("warning", strtoken (\s -> ITwarning_prag (SourceText s))),
+     ("deprecated", strtoken (\s -> ITdeprecated_prag (SourceText s))),
+     ("scc", strtoken (\s -> ITscc_prag (SourceText s))),
+     ("generated", strtoken (\s -> ITgenerated_prag (SourceText s))),
+     ("core", strtoken (\s -> ITcore_prag (SourceText s))),
+     ("unpack", strtoken (\s -> ITunpack_prag (SourceText s))),
+     ("nounpack", strtoken (\s -> ITnounpack_prag (SourceText s))),
+     ("ann", strtoken (\s -> ITann_prag (SourceText s))),
+     ("vectorize", strtoken (\s -> ITvect_prag (SourceText s))),
+     ("novectorize", strtoken (\s -> ITnovect_prag (SourceText s))),
+     ("minimal", strtoken (\s -> ITminimal_prag (SourceText s))),
+     ("overlaps", strtoken (\s -> IToverlaps_prag (SourceText s))),
+     ("overlappable", strtoken (\s -> IToverlappable_prag (SourceText s))),
+     ("overlapping", strtoken (\s -> IToverlapping_prag (SourceText s))),
+     ("incoherent", strtoken (\s -> ITincoherent_prag (SourceText s))),
+     ("ctype", strtoken (\s -> ITctype (SourceText s)))])
 
 twoWordPrags = Map.fromList([
-     ("inline conlike", strtoken (\s -> (ITinline_prag s Inline ConLike))),
-     ("notinline conlike", strtoken (\s -> (ITinline_prag s NoInline ConLike))),
-     ("specialize inline", strtoken (\s -> (ITspec_inline_prag s True))),
-     ("specialize notinline", strtoken (\s -> (ITspec_inline_prag s False))),
-     ("vectorize scalar", strtoken (\s -> ITvect_scalar_prag s))])
+     ("inline conlike",
+         strtoken (\s -> (ITinline_prag (SourceText s) Inline ConLike))),
+     ("notinline conlike",
+         strtoken (\s -> (ITinline_prag (SourceText s) NoInline ConLike))),
+     ("specialize inline",
+         strtoken (\s -> (ITspec_inline_prag (SourceText s) True))),
+     ("specialize notinline",
+         strtoken (\s -> (ITspec_inline_prag (SourceText s) False))),
+     ("vectorize scalar",
+         strtoken (\s -> ITvect_scalar_prag (SourceText s)))])
 
 dispatch_pragmas :: Map String Action -> Action
 dispatch_pragmas prags span buf len = case Map.lookup (clean_pragma (lexemeToString buf len)) prags of
index 2c90086..b31ca79 100644 (file)
@@ -824,10 +824,10 @@ importdecl :: { LImportDecl RdrName }
                    ((mj AnnImport $1 : (fst $ fst $2) ++ fst $3 ++ fst $4
                                     ++ fst $5 ++ fst $7)) }
 
-maybe_src :: { (([AddAnn],Maybe SourceText),IsBootInterface) }
-        : '{-# SOURCE' '#-}'        { (([mo $1,mc $2],Just (getSOURCE_PRAGs $1))
+maybe_src :: { (([AddAnn],SourceText),IsBootInterface) }
+        : '{-# SOURCE' '#-}'        { (([mo $1,mc $2],getSOURCE_PRAGs $1)
                                       ,True) }
-        | {- empty -}               { (([],Nothing),False) }
+        | {- empty -}               { (([],NoSourceText),False) }
 
 maybe_safe :: { ([AddAnn],Bool) }
         : 'safe'                                { ([mj AnnSafe $1],True) }
@@ -871,7 +871,7 @@ impspec :: { Located (Bool, Located [LIE RdrName]) }
 -- Fixity Declarations
 
 prec    :: { Located (SourceText,Int) }
-        : {- empty -}           { noLoc ("",9) }
+        : {- empty -}           { noLoc (NoSourceText,9) }
         | INTEGER
                  {% checkPrecP (sL1 $1 (getINTEGERs $1,fromInteger (getINTEGER $1))) }
 
@@ -1444,11 +1444,11 @@ binds   ::  { Located ([AddAnn],Located (HsLocalBinds RdrName)) }
                                                     ,sL1 $1 $ HsValBinds val_binds)) } }
 
         | '{'            dbinds '}'     { sLL $1 $> ([moc $1,mcc $3]
-                                             ,sL1 $2 $ HsIPBinds (IPBinds (unLoc $2)
+                                             ,sL1 $2 $ HsIPBinds (IPBinds (reverse $ unLoc $2)
                                                          emptyTcEvBinds)) }
 
         |     vocurly    dbinds close   { L (getLoc $2) ([]
-                                            ,sL1 $2 $ HsIPBinds (IPBinds (unLoc $2)
+                                            ,sL1 $2 $ HsIPBinds (IPBinds (reverse $ unLoc $2)
                                                         emptyTcEvBinds)) }
 
 
@@ -1521,7 +1521,7 @@ warnings :: { OrdList (LWarnDecl RdrName) }
 -- SUP: TEMPORARY HACK, not checking for `module Foo'
 warning :: { OrdList (LWarnDecl RdrName) }
         : namelist strings
-                {% amsu (sLL $1 $> (Warning (unLoc $1) (WarningTxt (noLoc "") $ snd $ unLoc $2)))
+                {% amsu (sLL $1 $> (Warning (unLoc $1) (WarningTxt (noLoc NoSourceText) $ snd $ unLoc $2)))
                      (fst $ unLoc $2) }
 
 deprecations :: { OrdList (LWarnDecl RdrName) }
@@ -1536,7 +1536,7 @@ deprecations :: { OrdList (LWarnDecl RdrName) }
 -- SUP: TEMPORARY HACK, not checking for `module Foo'
 deprecation :: { OrdList (LWarnDecl RdrName) }
         : namelist strings
-             {% amsu (sLL $1 $> $ (Warning (unLoc $1) (DeprecatedTxt (noLoc "") $ snd $ unLoc $2)))
+             {% amsu (sLL $1 $> $ (Warning (unLoc $1) (DeprecatedTxt (noLoc NoSourceText) $ snd $ unLoc $2)))
                      (fst $ unLoc $2) }
 
 strings :: { Located ([AddAnn],[Located StringLiteral]) }
@@ -1601,7 +1601,7 @@ fspec :: { Located ([AddAnn]
                                              ,(L (getLoc $1)
                                                     (getStringLiteral $1), $2, mkLHsSigType $4)) }
        |        var '::' sigtypedoc     { sLL $1 $> ([mu AnnDcolon $2]
-                                             ,(noLoc (StringLiteral "" nilFS), $1, mkLHsSigType $3)) }
+                                             ,(noLoc (StringLiteral NoSourceText nilFS), $1, mkLHsSigType $3)) }
          -- if the entity string is missing, it defaults to the empty string;
          -- the meaning of an empty entity string depends on the calling
          -- convention
@@ -1639,7 +1639,7 @@ sigtypes1 :: { (OrdList (LHsSigType RdrName)) }
 -- Types
 
 strict_mark :: { Located ([AddAnn],HsSrcBang) }
-        : strictness { sL1 $1 (let (a, str) = unLoc $1 in (a, HsSrcBang Nothing NoSrcUnpack str)) }
+        : strictness { sL1 $1 (let (a, str) = unLoc $1 in (a, HsSrcBang NoSourceText NoSrcUnpack str)) }
         | unpackedness { sL1 $1 (let (a, prag, unpk) = unLoc $1 in (a, HsSrcBang prag unpk NoSrcStrict)) }
         | unpackedness strictness { sLL $1 $> (let { (a, prag, unpk) = unLoc $1
                                                    ; (a', str) = unLoc $2 }
@@ -1651,9 +1651,9 @@ strictness :: { Located ([AddAnn], SrcStrictness) }
         : '!' { sL1 $1 ([mj AnnBang $1], SrcStrict) }
         | '~' { sL1 $1 ([mj AnnTilde $1], SrcLazy) }
 
-unpackedness :: { Located ([AddAnn], Maybe SourceText, SrcUnpackedness) }
-        : '{-# UNPACK' '#-}'   { sLL $1 $> ([mo $1, mc $2], Just $ getUNPACK_PRAGs $1, SrcUnpack) }
-        | '{-# NOUNPACK' '#-}' { sLL $1 $> ([mo $1, mc $2], Just $ getNOUNPACK_PRAGs $1, SrcNoUnpack) }
+unpackedness :: { Located ([AddAnn], SourceText, SrcUnpackedness) }
+        : '{-# UNPACK' '#-}'   { sLL $1 $> ([mo $1, mc $2], getUNPACK_PRAGs $1, SrcUnpack) }
+        | '{-# NOUNPACK' '#-}' { sLL $1 $> ([mo $1, mc $2], getNOUNPACK_PRAGs $1, SrcNoUnpack) }
 
 -- A ctype is a for-all type
 ctype   :: { LHsType RdrName }
@@ -1785,8 +1785,8 @@ tyapp :: { LHsAppType RdrName }
                                                [mj AnnSimpleQuote $1] }
 
 atype :: { LHsType RdrName }
-        : ntgtycon                       { sL1 $1 (HsTyVar $1) }      -- Not including unit tuples
-        | tyvar                          { sL1 $1 (HsTyVar $1) }      -- (See Note [Unit tuples])
+        : ntgtycon                       { sL1 $1 (HsTyVar NotPromoted $1) }      -- Not including unit tuples
+        | tyvar                          { sL1 $1 (HsTyVar NotPromoted $1) }      -- (See Note [Unit tuples])
         | strict_mark atype              {% ams (sLL $1 $> (HsBangTy (snd $ unLoc $1) $2))
                                                 (fst $ unLoc $1) }  -- Constructor sigs only
         | '{' fielddecls '}'             {% amms (checkRecordSyntax
@@ -1813,21 +1813,21 @@ atype :: { LHsType RdrName }
         | '(' ctype '::' kind ')'     {% ams (sLL $1 $> $ HsKindSig $2 $4)
                                              [mop $1,mu AnnDcolon $3,mcp $5] }
         | quasiquote                  { sL1 $1 (HsSpliceTy (unLoc $1) placeHolderKind) }
-        | '$(' exp ')'                {% ams (sLL $1 $> $ mkHsSpliceTy $2)
+        | '$(' exp ')'                {% ams (sLL $1 $> $ mkHsSpliceTy HasParens $2)
                                              [mj AnnOpenPE $1,mj AnnCloseP $3] }
-        | TH_ID_SPLICE                {%ams (sLL $1 $> $ mkHsSpliceTy $ sL1 $1 $ HsVar $
+        | TH_ID_SPLICE                {%ams (sLL $1 $> $ mkHsSpliceTy NoParens $ sL1 $1 $ HsVar $
                                              (sL1 $1 (mkUnqual varName (getTH_ID_SPLICE $1))))
                                              [mj AnnThIdSplice $1] }
                                       -- see Note [Promotion] for the followings
-        | SIMPLEQUOTE qcon_nowiredlist {% ams (sLL $1 $> $ HsTyVar $2) [mj AnnSimpleQuote $1,mj AnnName $2] }
+        | SIMPLEQUOTE qcon_nowiredlist {% ams (sLL $1 $> $ HsTyVar Promoted $2) [mj AnnSimpleQuote $1,mj AnnName $2] }
         | SIMPLEQUOTE  '(' ctype ',' comma_types1 ')'
                              {% addAnnotation (gl $3) AnnComma (gl $4) >>
                                 ams (sLL $1 $> $ HsExplicitTupleTy [] ($3 : $5))
                                     [mj AnnSimpleQuote $1,mop $2,mcp $6] }
-        | SIMPLEQUOTE  '[' comma_types0 ']'     {% ams (sLL $1 $> $ HsExplicitListTy
+        | SIMPLEQUOTE  '[' comma_types0 ']'     {% ams (sLL $1 $> $ HsExplicitListTy Promoted
                                                             placeHolderKind $3)
                                                        [mj AnnSimpleQuote $1,mos $2,mcs $4] }
-        | SIMPLEQUOTE var                       {% ams (sLL $1 $> $ HsTyVar $2)
+        | SIMPLEQUOTE var                       {% ams (sLL $1 $> $ HsTyVar Promoted $2)
                                                        [mj AnnSimpleQuote $1,mj AnnName $2] }
 
         -- Two or more [ty, ty, ty] must be a promoted list type, just as
@@ -1836,7 +1836,7 @@ atype :: { LHsType RdrName }
         -- so you have to quote those.)
         | '[' ctype ',' comma_types1 ']'  {% addAnnotation (gl $2) AnnComma
                                                            (gl $3) >>
-                                             ams (sLL $1 $> $ HsExplicitListTy
+                                             ams (sLL $1 $> $ HsExplicitListTy NotPromoted
                                                      placeHolderKind ($2 : $4))
                                                  [mos $1,mcs $5] }
         | INTEGER              { sLL $1 $> $ HsTyLit $ HsNumTy (getINTEGERs $1)
@@ -2362,7 +2362,7 @@ scc_annot :: { Located (([AddAnn],SourceText),StringLiteral) }
                                                 ,mc $3],getSCC_PRAGs $1),(StringLiteral (getSTRINGs $2) scc)) }
         | '{-# SCC' VARID  '#-}'      { sLL $1 $> (([mo $1,mj AnnVal $2
                                          ,mc $3],getSCC_PRAGs $1)
-                                        ,(StringLiteral (unpackFS $ getVARID $2) (getVARID $2))) }
+                                        ,(StringLiteral NoSourceText (getVARID $2))) }
 
 hpc_annot :: { Located ( (([AddAnn],SourceText),(StringLiteral,(Int,Int),(Int,Int))),
                          ((SourceText,SourceText),(SourceText,SourceText))
@@ -2471,17 +2471,17 @@ aexp2   :: { LHsExpr RdrName }
                                           [mo $1,mc $4] }
 
 splice_exp :: { LHsExpr RdrName }
-        : TH_ID_SPLICE          {% ams (sL1 $1 $ mkHsSpliceE
+        : TH_ID_SPLICE          {% ams (sL1 $1 $ mkHsSpliceE NoParens
                                         (sL1 $1 $ HsVar (sL1 $1 (mkUnqual varName
                                                            (getTH_ID_SPLICE $1)))))
                                        [mj AnnThIdSplice $1] }
-        | '$(' exp ')'          {% ams (sLL $1 $> $ mkHsSpliceE $2)
+        | '$(' exp ')'          {% ams (sLL $1 $> $ mkHsSpliceE HasParens $2)
                                        [mj AnnOpenPE $1,mj AnnCloseP $3] }
-        | TH_ID_TY_SPLICE       {% ams (sL1 $1 $ mkHsSpliceTE
+        | TH_ID_TY_SPLICE       {% ams (sL1 $1 $ mkHsSpliceTE NoParens
                                         (sL1 $1 $ HsVar (sL1 $1 (mkUnqual varName
                                                         (getTH_ID_TY_SPLICE $1)))))
                                        [mj AnnThIdTySplice $1] }
-        | '$$(' exp ')'         {% ams (sLL $1 $> $ mkHsSpliceTE $2)
+        | '$$(' exp ')'         {% ams (sLL $1 $> $ mkHsSpliceTE HasParens $2)
                                        [mj AnnOpenPTE $1,mj AnnCloseP $3] }
 
 cmdargs :: { [LHsCmdTop RdrName] }
@@ -3046,8 +3046,8 @@ qtycon :: { Located RdrName }   -- Qualified or unqualified
         | tycon             { $1 }
 
 qtycondoc :: { LHsType RdrName } -- Qualified or unqualified
-        : qtycon            { sL1 $1                     (HsTyVar $1)      }
-        | qtycon docprev    { sLL $1 $> (HsDocTy (sL1 $1 (HsTyVar $1)) $2) }
+        : qtycon            { sL1 $1                     (HsTyVar NotPromoted $1)      }
+        | qtycon docprev    { sLL $1 $> (HsDocTy (sL1 $1 (HsTyVar NotPromoted $1)) $2) }
 
 tycon   :: { Located RdrName }  -- Unqualified
         : CONID                   { sL1 $1 $! mkUnqual tcClsName (getCONID $1) }
index ab5708e..d964cc2 100644 (file)
@@ -281,7 +281,7 @@ mkSpliceDecl lexpr@(L loc expr)
   = SpliceD (SpliceDecl (L loc splice) ExplicitSplice)
 
   | otherwise
-  = SpliceD (SpliceDecl (L loc (mkUntypedSplice lexpr)) ImplicitSplice)
+  = SpliceD (SpliceDecl (L loc (mkUntypedSplice NoParens lexpr)) ImplicitSplice)
 
 mkRoleAnnotDecl :: SrcSpan
                 -> Located RdrName                   -- type being annotated
@@ -465,8 +465,8 @@ splitCon ty
  where
    -- This is used somewhere where HsAppsTy is not used
    split (L _ (HsAppTy t u)) ts       = split t (u : ts)
-   split (L l (HsTyVar (L _ tc)))  ts = do data_con <- tyConToDataCon l tc
-                                           return (data_con, mk_rest ts)
+   split (L l (HsTyVar (L _ tc)))  ts = do data_con <- tyConToDataCon l tc
+                                             return (data_con, mk_rest ts)
    split (L l (HsTupleTy HsBoxedOrConstraintTuple ts)) []
       = return (L l (getRdrName (tupleDataCon Boxed (length ts))), PrefixCon ts)
    split (L l _) _ = parseErrorSDoc l (text "Cannot parse data constructor in a data/newtype declaration:" <+> ppr ty)
@@ -681,9 +681,9 @@ checkTyVars pp_what equals_or_where tc tparms
 
         -- Check that the name space is correct!
     chk (L l (HsKindSig
-              (L _ (HsAppsTy [L _ (HsAppPrefix (L lv (HsTyVar (L _ tv))))])) k))
+            (L _ (HsAppsTy [L _ (HsAppPrefix (L lv (HsTyVar _ (L _ tv))))])) k))
         | isRdrTyVar tv    = return (L l (KindedTyVar (L lv tv) k))
-    chk (L l (HsTyVar (L ltv tv)))
+    chk (L l (HsTyVar (L ltv tv)))
         | isRdrTyVar tv    = return (L l (UserTyVar (L ltv tv)))
     chk t@(L loc _)
         = Left (loc,
@@ -732,7 +732,7 @@ checkTyClHdr is_cls ty
   where
     goL (L l ty) acc ann = go l ty acc ann
 
-    go l (HsTyVar (L _ tc)) acc ann
+    go l (HsTyVar (L _ tc)) acc ann
       | isRdrTc tc               = return (L l tc, acc, ann)
     go _ (HsOpTy t1 ltc@(L _ tc) t2) acc ann
       | isRdrTc tc               = return (ltc, t1:t2:acc, ann)
@@ -1088,7 +1088,8 @@ isFunLhs e = go e [] []
 splitTilde :: LHsType RdrName -> P (LHsType RdrName)
 splitTilde t = go t
   where go (L loc (HsAppTy t1 t2))
-          | L lo (HsBangTy (HsSrcBang Nothing NoSrcUnpack SrcLazy) t2') <- t2
+          | L lo (HsBangTy (HsSrcBang NoSourceText NoSrcUnpack SrcLazy) t2')
+                                                                          <- t2
           = do
               moveAnnotations lo loc
               t1' <- go t1
@@ -1116,7 +1117,7 @@ splitTildeApps (t : rest) = do
   return (t : rest')
   where go (L l (HsAppPrefix
             (L loc (HsBangTy
-                    (HsSrcBang Nothing NoSrcUnpack SrcLazy)
+                    (HsSrcBang NoSourceText NoSrcUnpack SrcLazy)
                     ty))))
           = addAnnotation l AnnTilde tilde_loc >>
             return
@@ -1160,7 +1161,7 @@ checkCmd :: SrcSpan -> HsExpr RdrName -> P (HsCmd RdrName)
 checkCmd _ (HsArrApp e1 e2 ptt haat b) =
     return $ HsCmdArrApp e1 e2 ptt haat b
 checkCmd _ (HsArrForm e mf args) =
-    return $ HsCmdArrForm e mf args
+    return $ HsCmdArrForm e Prefix mf args
 checkCmd _ (HsApp e1 e2) =
     checkCommand e1 >>= (\c -> return $ HsCmdApp c e2)
 checkCmd _ (HsLam mg) =
@@ -1184,7 +1185,7 @@ checkCmd _ (OpApp eLeft op _fixity eRight) = do
     c2 <- checkCommand eRight
     let arg1 = L (getLoc c1) $ HsCmdTop c1 placeHolderType placeHolderType []
         arg2 = L (getLoc c2) $ HsCmdTop c2 placeHolderType placeHolderType []
-    return $ HsCmdArrForm op Nothing [arg1, arg2]
+    return $ HsCmdArrForm op Infix Nothing [arg1, arg2]
 
 checkCmd l e = cmdFail l e
 
@@ -1274,7 +1275,7 @@ mk_rec_upd_field :: HsRecField RdrName (LHsExpr RdrName) -> HsRecUpdField RdrNam
 mk_rec_upd_field (HsRecField (L loc (FieldOcc rdr _)) arg pun)
   = HsRecField (L loc (Unambiguous rdr PlaceHolder)) arg pun
 
-mkInlinePragma :: String -> (InlineSpec, RuleMatchInfo) -> Maybe Activation
+mkInlinePragma :: SourceText -> (InlineSpec, RuleMatchInfo) -> Maybe Activation
                -> InlinePragma
 -- The (Maybe Activation) is because the user can omit
 -- the activation spec (and usually does)
@@ -1357,7 +1358,8 @@ parseCImport cconv safety nm str sourceText =
              ((mk Nothing <$> cimp nm) +++
               (do h <- munch1 hdr_char
                   skipSpaces
-                  mk (Just (Header h (mkFastString h))) <$> cimp nm))
+                  mk (Just (Header (SourceText h) (mkFastString h)))
+                      <$> cimp nm))
          ]
        skipSpaces
        return r
@@ -1386,7 +1388,7 @@ parseCImport cconv safety nm str sourceText =
                                              return False)
                               _ -> return True
                      cid' <- cid
-                     return (CFunction (StaticTarget (unpackFS cid') cid'
+                     return (CFunction (StaticTarget NoSourceText cid'
                                         Nothing isFun)))
           where
             cid = return nm +++
@@ -1405,7 +1407,7 @@ mkExport (L lc cconv) (L le (StringLiteral esrc entity), v, ty)
    ForeignExport { fd_name = v, fd_sig_ty = ty
                  , fd_co = noForeignExportCoercionYet
                  , fd_fe = CExport (L lc (CExportStatic esrc entity' cconv))
-                                   (L le (unpackFS entity)) }
+                                   (L le esrc) }
   where
     entity' | nullFS entity = mkExtName (unLoc v)
             | otherwise     = entity
index 8411f11..ff893ed 100644 (file)
@@ -22,7 +22,7 @@ import FastString
 import Binary
 import Outputable
 import Module
-import BasicTypes ( SourceText )
+import BasicTypes ( SourceText, pprWithSourceText )
 
 import Data.Char
 import Data.Data
@@ -203,14 +203,14 @@ instance Outputable CCallSpec where
       gc_suf | playSafe safety = text "_GC"
              | otherwise       = empty
 
-      ppr_fun (StaticTarget fn mPkgId isFun)
+      ppr_fun (StaticTarget st _fn mPkgId isFun)
         = text (if isFun then "__pkg_ccall"
                          else "__pkg_ccall_value")
        <> gc_suf
        <+> (case mPkgId of
             Nothing -> empty
             Just pkgId -> ppr pkgId)
-       <+> pprCLabelString fn
+       <+> (pprWithSourceText st empty)
 
       ppr_fun DynamicTarget
         = text "__dyn_ccall" <> gc_suf <+> text "\"\""
@@ -221,7 +221,7 @@ data Header = Header SourceText FastString
     deriving (Eq, Data)
 
 instance Outputable Header where
-    ppr (Header _ h) = quotes $ ppr h
+    ppr (Header st h) = pprWithSourceText st (doubleQuotes $ ppr h)
 
 -- | A C type, used in CAPI FFI calls
 --
@@ -236,7 +236,9 @@ data CType = CType SourceText -- Note [Pragma source text] in BasicTypes
     deriving (Eq, Data)
 
 instance Outputable CType where
-    ppr (CType _ mh (_,ct)) = hDoc <+> ftext ct
+    ppr (CType stp mh (stct,ct))
+      = pprWithSourceText stp (text "{-# CTYPE") <+> hDoc
+        <+> pprWithSourceText stct (doubleQuotes (ftext ct)) <+> text "#-}"
         where hDoc = case mh of
                      Nothing -> empty
                      Just h -> ppr h
index e174aed..0acac66 100644 (file)
@@ -38,7 +38,8 @@ import OccName          ( OccName, pprOccName, mkVarOccFS )
 import TyCon            ( TyCon, isPrimTyCon, PrimRep(..) )
 import Type
 import RepType          ( typePrimRep, tyConPrimRep )
-import BasicTypes       ( Arity, Fixity(..), FixityDirection(..), Boxity(..) )
+import BasicTypes       ( Arity, Fixity(..), FixityDirection(..), Boxity(..),
+                          SourceText(..) )
 import ForeignCall      ( CLabelString )
 import Unique           ( Unique, mkPrimOpIdUnique )
 import Outputable
index 1c47922..18cf530 100644 (file)
@@ -144,7 +144,8 @@ import Class            ( Class, mkClass )
 import RdrName
 import Name
 import NameSet          ( NameSet, mkNameSet, elemNameSet )
-import BasicTypes       ( Arity, Boxity(..), TupleSort(..), ConTagZ )
+import BasicTypes       ( Arity, Boxity(..), TupleSort(..), ConTagZ,
+                          SourceText(..) )
 import ForeignCall
 import SrcLoc           ( noSrcSpan )
 import Unique
@@ -525,7 +526,7 @@ pcDataConWithFixity' declared_infix dc_name wrk_key rri tyvars ex_tyvars arg_tys
                 (mkDataConWorkId wrk_name data_con)
                 NoDataConRep    -- Wired-in types are too simple to need wrappers
 
-    no_bang = HsSrcBang Nothing NoSrcUnpack NoSrcStrict
+    no_bang = HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict
 
     wrk_name = mkDataConWorkerName data_con wrk_key
 
@@ -1179,8 +1180,9 @@ charTy = mkTyConTy charTyCon
 
 charTyCon :: TyCon
 charTyCon   = pcNonEnumTyCon charTyConName
-                       (Just (CType "" Nothing ("HsChar",fsLit "HsChar")))
-                       [] [charDataCon]
+                   (Just (CType NoSourceText Nothing
+                                  (NoSourceText,fsLit "HsChar")))
+                   [] [charDataCon]
 charDataCon :: DataCon
 charDataCon = pcDataCon charDataConName [] [charPrimTy] charTyCon
 
@@ -1192,8 +1194,8 @@ intTy = mkTyConTy intTyCon
 
 intTyCon :: TyCon
 intTyCon = pcNonEnumTyCon intTyConName
-                            (Just (CType "" Nothing ("HsInt",fsLit "HsInt"))) []
-                            [intDataCon]
+               (Just (CType NoSourceText Nothing (NoSourceText,fsLit "HsInt")))
+                 [] [intDataCon]
 intDataCon :: DataCon
 intDataCon = pcDataCon intDataConName [] [intPrimTy] intTyCon
 
@@ -1202,8 +1204,8 @@ wordTy = mkTyConTy wordTyCon
 
 wordTyCon :: TyCon
 wordTyCon = pcNonEnumTyCon wordTyConName
-                      (Just (CType "" Nothing ("HsWord", fsLit "HsWord"))) []
-                      [wordDataCon]
+            (Just (CType NoSourceText Nothing (NoSourceText, fsLit "HsWord")))
+               [] [wordDataCon]
 wordDataCon :: DataCon
 wordDataCon = pcDataCon wordDataConName [] [wordPrimTy] wordTyCon
 
@@ -1212,7 +1214,8 @@ word8Ty = mkTyConTy word8TyCon
 
 word8TyCon :: TyCon
 word8TyCon = pcNonEnumTyCon word8TyConName
-                      (Just (CType "" Nothing ("HsWord8", fsLit "HsWord8"))) []
+                      (Just (CType NoSourceText Nothing
+                             (NoSourceText, fsLit "HsWord8"))) []
                       [word8DataCon]
 word8DataCon :: DataCon
 word8DataCon = pcDataCon word8DataConName [] [wordPrimTy] word8TyCon
@@ -1222,7 +1225,8 @@ floatTy = mkTyConTy floatTyCon
 
 floatTyCon :: TyCon
 floatTyCon   = pcNonEnumTyCon floatTyConName
-                      (Just (CType "" Nothing ("HsFloat", fsLit "HsFloat"))) []
+                      (Just (CType NoSourceText Nothing
+                             (NoSourceText, fsLit "HsFloat"))) []
                       [floatDataCon]
 floatDataCon :: DataCon
 floatDataCon = pcDataCon         floatDataConName [] [floatPrimTy] floatTyCon
@@ -1232,7 +1236,8 @@ doubleTy = mkTyConTy doubleTyCon
 
 doubleTyCon :: TyCon
 doubleTyCon = pcNonEnumTyCon doubleTyConName
-                      (Just (CType "" Nothing ("HsDouble",fsLit "HsDouble"))) []
+                      (Just (CType NoSourceText Nothing
+                             (NoSourceText,fsLit "HsDouble"))) []
                       [doubleDataCon]
 
 doubleDataCon :: DataCon
@@ -1293,7 +1298,8 @@ boolTy = mkTyConTy boolTyCon
 
 boolTyCon :: TyCon
 boolTyCon = pcTyCon True boolTyConName
-                    (Just (CType "" Nothing ("HsBool", fsLit "HsBool")))
+                    (Just (CType NoSourceText Nothing
+                           (NoSourceText, fsLit "HsBool")))
                     [] [falseDataCon, trueDataCon]
 
 falseDataCon, trueDataCon :: DataCon
index 801bc27..f8969a8 100644 (file)
@@ -75,7 +75,8 @@ import DataCon
 import TyCon
 import PrelNames        ( mkUnboundName, isUnboundName, rOOT_MAIN, forall_tv_RDR )
 import ErrUtils         ( MsgDoc )
-import BasicTypes       ( Fixity(..), FixityDirection(..), minPrecedence, defaultFixity )
+import BasicTypes       ( Fixity(..), FixityDirection(..), minPrecedence,
+                          defaultFixity, pprWarningTxtForMsg, SourceText(..) )
 import SrcLoc
 import Outputable
 import Util
@@ -1072,7 +1073,7 @@ warnIfDeprecated gre@(GRE { gre_name = name, gre_imp = iss })
                     <+> pprNonVarNameSpace (occNameSpace occ)
                     <+> quotes (ppr occ)
                   , parens imp_msg <> colon ]
-            , ppr txt ]
+            , pprWarningTxtForMsg txt ]
       where
         imp_mod  = importSpecModule imp_spec
         imp_msg  = text "imported from" <+> ppr imp_mod <> extra
@@ -1438,7 +1439,7 @@ lookupFixityRn_help' :: Name
                      -> RnM (Bool, Fixity)
 lookupFixityRn_help' name occ
   | isUnboundName name
-  = return (False, Fixity (show minPrecedence) minPrecedence InfixL)
+  = return (False, Fixity NoSourceText minPrecedence InfixL)
     -- Minimise errors from ubound names; eg
     --    a>0 `foo` b>0
     -- where 'foo' is not in scope, should not give an error (Trac #7937)
@@ -1517,7 +1518,7 @@ lookupFieldFixityRn (Ambiguous   (L _ rdr) _) = get_ambiguous_fixity rdr
         [] -> panic "get_ambiguous_fixity: no candidates for a given RdrName"
         [ (_, fix):_ ] -> return fix
         ambigs -> addErr (ambiguous_fixity_err rdr_name ambigs)
-                  >> return (Fixity(show minPrecedence) minPrecedence InfixL)
+                  >> return (Fixity NoSourceText minPrecedence InfixL)
 
     lookup_gre_fixity gre = lookupFixityRn' (gre_name gre) (greOccName gre)
 
index 991162d..7cafc2b 100644 (file)
@@ -168,7 +168,7 @@ rnExpr (OpApp e1 op  _ e2)
         ; fixity <- case op' of
               L _ (HsVar (L _ n)) -> lookupFixityRn n
               L _ (HsRecFld f)    -> lookupFieldFixityRn f
-              _ -> return (Fixity (show minPrecedence) minPrecedence InfixL)
+              _ -> return (Fixity NoSourceText minPrecedence InfixL)
                    -- c.f. lookupFixity for unbound
 
         ; final_e <- mkOpAppRn e1' op' fixity e2'
@@ -474,7 +474,7 @@ rnCmd (HsCmdArrApp arrow arg _ ho rtl)
         -- inside 'arrow'.  In the higher-order case (-<<), they are.
 
 -- infix form
-rnCmd (HsCmdArrForm op (Just _) [arg1, arg2])
+rnCmd (HsCmdArrForm op (Just _) [arg1, arg2])
   = do { (op',fv_op) <- escapeArrowScope (rnLExpr op)
        ; let L _ (HsVar (L _ op_name)) = op'
        ; (arg1',fv_arg1) <- rnCmdTop arg1
@@ -484,10 +484,10 @@ rnCmd (HsCmdArrForm op (Just _) [arg1, arg2])
        ; final_e <- mkOpFormRn arg1' op' fixity arg2'
        ; return (final_e, fv_arg1 `plusFV` fv_op `plusFV` fv_arg2) }
 
-rnCmd (HsCmdArrForm op fixity cmds)
+rnCmd (HsCmdArrForm op f fixity cmds)
   = do { (op',fvOp) <- escapeArrowScope (rnLExpr op)
        ; (cmds',fvCmds) <- rnCmdArgs cmds
-       ; return (HsCmdArrForm op' fixity cmds', fvOp `plusFV` fvCmds) }
+       ; return (HsCmdArrForm op' f fixity cmds', fvOp `plusFV` fvCmds) }
 
 rnCmd (HsCmdApp fun arg)
   = do { (fun',fvFun) <- rnLCmd  fun
index e67be63..2122c70 100644 (file)
@@ -817,7 +817,7 @@ rnLit _ = return ()
 -- Integer-looking literal.
 generalizeOverLitVal :: OverLitVal -> OverLitVal
 generalizeOverLitVal (HsFractional (FL {fl_text=src,fl_value=val}))
-    | denominator val == 1 = HsIntegral src (numerator val)
+    | denominator val == 1 = HsIntegral (SourceText src) (numerator val)
 generalizeOverLitVal lit = lit
 
 rnOverLit :: HsOverLit t -> RnM (HsOverLit Name, FreeVars)
index 57c3587..0c41ed3 100644 (file)
@@ -22,7 +22,7 @@ import Kind
 import RnEnv
 import RnSource         ( rnSrcDecls, findSplice )
 import RnPat            ( rnPat )
-import BasicTypes       ( TopLevelFlag, isTopLevel )
+import BasicTypes       ( TopLevelFlag, isTopLevel, SourceText(..) )
 import Outputable
 import Module
 import SrcLoc
@@ -309,7 +309,7 @@ runRnSplice flavour run_meta ppr_res splice
   = do { splice' <- getHooked runRnSpliceHook return >>= ($ splice)
 
        ; let the_expr = case splice' of
-                  HsUntypedSplice _ e     ->  e
+                  HsUntypedSplice _ _ e   ->  e
                   HsQuasiQuote _ q qs str -> mkQuasiQuoteExpr flavour q qs str
                   HsTypedSplice {}        -> pprPanic "runRnSplice" (ppr splice)
                   HsSpliced {}            -> pprPanic "runRnSplice" (ppr splice)
@@ -350,7 +350,7 @@ runRnSplice flavour run_meta ppr_res splice
 makePending :: UntypedSpliceFlavour
             -> HsSplice Name
             -> PendingRnSplice
-makePending flavour (HsUntypedSplice n e)
+makePending flavour (HsUntypedSplice n e)
   = PendingRnSplice flavour n e
 makePending flavour (HsQuasiQuote n quoter q_span quote)
   = PendingRnSplice flavour n (mkQuasiQuoteExpr flavour quoter q_span quote)
@@ -370,7 +370,7 @@ mkQuasiQuoteExpr flavour quoter q_span quote
                      quoteExpr
   where
     quoterExpr = L q_span $! HsVar $! (L q_span quoter)
-    quoteExpr  = L q_span $! HsLit $! HsString "" quote
+    quoteExpr  = L q_span $! HsLit $! HsString NoSourceText quote
     quote_selector = case flavour of
                        UntypedExpSplice  -> quoteExpName
                        UntypedPatSplice  -> quotePatName
@@ -380,19 +380,19 @@ mkQuasiQuoteExpr flavour quoter q_span quote
 ---------------------
 rnSplice :: HsSplice RdrName -> RnM (HsSplice Name, FreeVars)
 -- Not exported...used for all
-rnSplice (HsTypedSplice splice_name expr)
+rnSplice (HsTypedSplice hasParen splice_name expr)
   = do  { checkTH expr "Template Haskell typed splice"
         ; loc  <- getSrcSpanM
         ; n' <- newLocalBndrRn (L loc splice_name)
         ; (expr', fvs) <- rnLExpr expr
-        ; return (HsTypedSplice n' expr', fvs) }
+        ; return (HsTypedSplice hasParen n' expr', fvs) }
 
-rnSplice (HsUntypedSplice splice_name expr)
+rnSplice (HsUntypedSplice hasParen splice_name expr)
   = do  { checkTH expr "Template Haskell untyped splice"
         ; loc  <- getSrcSpanM
         ; n' <- newLocalBndrRn (L loc splice_name)
         ; (expr', fvs) <- rnLExpr expr
-        ; return (HsUntypedSplice n' expr', fvs) }
+        ; return (HsUntypedSplice hasParen n' expr', fvs) }
 
 rnSplice (HsQuasiQuote splice_name quoter q_loc quote)
   = do  { checkTH quoter "Template Haskell quasi-quote"
index c548c4d..00e2715 100644 (file)
@@ -464,9 +464,9 @@ rnHsTyKi env ty@(HsQualTy { hst_ctxt = lctxt, hst_body = tau })
        ; return (HsQualTy { hst_ctxt = ctxt', hst_body =  tau' }
                 , fvs1 `plusFV` fvs2) }
 
-rnHsTyKi env (HsTyVar (L loc rdr_name))
+rnHsTyKi env (HsTyVar ip (L loc rdr_name))
   = do { name <- rnTyVar env rdr_name
-       ; return (HsTyVar (L loc name), unitFV name) }
+       ; return (HsTyVar ip (L loc name), unitFV name) }
 
 rnHsTyKi env ty@(HsOpTy ty1 l_op ty2)
   = setSrcSpan (getLoc l_op) $
@@ -586,7 +586,8 @@ rnHsTyKi env overall_ty@(HsAppsTy tys)
                    (non_syms1 : non_syms2 : non_syms) (L loc star : ops)
       | star `hasKey` starKindTyConKey || star `hasKey` unicodeStarKindTyConKey
       = deal_with_star acc1 acc2
-                       ((non_syms1 ++ L loc (HsTyVar (L loc star)) : non_syms2) : non_syms)
+                       ((non_syms1 ++ L loc (HsTyVar NotPromoted (L loc star))
+                            : non_syms2) : non_syms)
                        ops
     deal_with_star acc1 acc2 (non_syms1 : non_syms) (op1 : ops)
       = deal_with_star (non_syms1 : acc1) (op1 : acc2) non_syms ops
@@ -643,12 +644,12 @@ rnHsTyKi _ (HsCoreTy ty)
     -- The emptyFVs probably isn't quite right
     -- but I don't think it matters
 
-rnHsTyKi env ty@(HsExplicitListTy k tys)
+rnHsTyKi env ty@(HsExplicitListTy ip k tys)
   = do { checkTypeInType env ty
        ; data_kinds <- xoptM LangExt.DataKinds
        ; unless data_kinds (addErr (dataKindsErr env ty))
        ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys
-       ; return (HsExplicitListTy k tys', fvs) }
+       ; return (HsExplicitListTy ip k tys', fvs) }
 
 rnHsTyKi env ty@(HsExplicitTupleTy kis tys)
   = do { checkTypeInType env ty
@@ -1034,7 +1035,7 @@ collectAnonWildCards lty = go lty
       HsDocTy ty _                 -> go ty
       HsBangTy _ ty                -> go ty
       HsRecTy flds                 -> gos $ map (cd_fld_type . unLoc) flds
-      HsExplicitListTy _ tys       -> gos tys
+      HsExplicitListTy _ _ tys     -> gos tys
       HsExplicitTupleTy _ tys      -> gos tys
       HsForAllTy { hst_bndrs = bndrs
                  , hst_body = ty } -> collectAnonWildCardsBndrs bndrs
@@ -1247,15 +1248,16 @@ mkOpFormRn :: LHsCmdTop Name            -- Left operand; already rearranged
           -> RnM (HsCmd Name)
 
 -- (e11 `op1` e12) `op2` e2
-mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsCmdArrForm op1 (Just fix1) [a11,a12])) _ _ _))
+mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsCmdArrForm op1 f (Just fix1)
+                                     [a11,a12])) _ _ _))
         op2 fix2 a2
   | nofix_error
   = do precParseErr (get_op op1,fix1) (get_op op2,fix2)
-       return (HsCmdArrForm op2 (Just fix2) [a1, a2])
+       return (HsCmdArrForm op2 (Just fix2) [a1, a2])
 
   | associate_right
   = do new_c <- mkOpFormRn a12 op2 fix2 a2
-       return (HsCmdArrForm op1 (Just fix1)
+       return (HsCmdArrForm op1 (Just fix1)
                [a11, L loc (HsCmdTop (L loc new_c)
                placeHolderType placeHolderType [])])
         -- TODO: locs are wrong
@@ -1264,7 +1266,7 @@ mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsCmdArrForm op1 (Just fix1) [a11,a12])) _
 
 --      Default case
 mkOpFormRn arg1 op fix arg2                     -- Default case, no rearrangment
-  = return (HsCmdArrForm op (Just fix) [arg1, arg2])
+  = return (HsCmdArrForm op Infix (Just fix) [arg1, arg2])
 
 
 --------------------------------------
@@ -1600,7 +1602,7 @@ extract_lkind = extract_lty KindLevel
 extract_lty :: TypeOrKind -> LHsType RdrName -> FreeKiTyVars -> RnM FreeKiTyVars
 extract_lty t_or_k (L _ ty) acc
   = case ty of
-      HsTyVar ltv               -> extract_tv t_or_k ltv acc
+      HsTyVar _  ltv            -> extract_tv t_or_k ltv acc
       HsBangTy _ ty             -> extract_lty t_or_k ty acc
       HsRecTy flds              -> foldrM (extract_lty t_or_k
                                            . cd_fld_type . unLoc) acc
@@ -1624,7 +1626,7 @@ extract_lty t_or_k (L _ ty) acc
       HsCoreTy {}               -> return acc  -- The type is closed
       HsSpliceTy {}             -> return acc  -- Type splices mention no tvs
       HsDocTy ty _              -> extract_lty t_or_k ty acc
-      HsExplicitListTy _ tys    -> extract_ltys t_or_k tys acc
+      HsExplicitListTy _ _ tys  -> extract_ltys t_or_k tys acc
       HsExplicitTupleTy _ tys   -> extract_ltys t_or_k tys acc
       HsTyLit _                 -> return acc
       HsKindSig ty ki           -> extract_lty t_or_k ty =<<
index 9acc461..2db3a71 100644 (file)
@@ -371,7 +371,7 @@ splitFun dflags fam_envs fn_id fn_info wrap_dmds res_info rhs
       Just (work_demands, wrap_fn, work_fn) -> do
         work_uniq <- getUniqueM
         let work_rhs = work_fn rhs
-            work_prag = InlinePragma { inl_src = "{-# INLINE"
+            work_prag = InlinePragma { inl_src = SourceText "{-# INLINE"
                                      , inl_inline = inl_inline inl_prag
                                      , inl_sat    = Nothing
                                      , inl_act    = wrap_act
@@ -410,9 +410,9 @@ splitFun dflags fam_envs fn_id fn_info wrap_dmds res_info rhs
 
                                 -- arity is consistent with the demand type goes through
 
-            wrap_act  = ActiveAfter "0" 0
+            wrap_act  = ActiveAfter NoSourceText 0
             wrap_rhs  = wrap_fn work_id
-            wrap_prag = InlinePragma { inl_src = "{-# INLINE"
+            wrap_prag = InlinePragma { inl_src = SourceText "{-# INLINE"
                                      , inl_inline = Inline
                                      , inl_sat    = Nothing
                                      , inl_act    = wrap_act
index 5015913..3069d80 100644 (file)
@@ -34,6 +34,7 @@ module Inst (
 import {-# SOURCE #-}   TcExpr( tcPolyExpr, tcSyntaxOp )
 import {-# SOURCE #-}   TcUnify( unifyType, unifyKind, noThing )
 
+import BasicTypes ( SourceText(..) )
 import FastString
 import HsSyn
 import TcHsSyn
@@ -639,9 +640,9 @@ getOverlapFlag overlap_mode
               incoherent_ok = xopt LangExt.IncoherentInstances  dflags
               use x = OverlapFlag { isSafeOverlap = safeLanguageOn dflags
                                   , overlapMode   = x }
-              default_oflag | incoherent_ok = use (Incoherent "")
-                            | overlap_ok    = use (Overlaps "")
-                            | otherwise     = use (NoOverlap "")
+              default_oflag | incoherent_ok = use (Incoherent NoSourceText)
+                            | overlap_ok    = use (Overlaps NoSourceText)
+                            | otherwise     = use (NoOverlap NoSourceText)
 
               final_oflag = setOverlapModeMaybe default_oflag overlap_mode
         ; return final_oflag }
index 33eb83b..ddd29b1 100644 (file)
@@ -65,6 +65,6 @@ annProvenanceToTarget _   (TypeAnnProvenance (L _ name))  = NamedTarget name
 annProvenanceToTarget mod ModuleAnnProvenance             = ModuleTarget mod
 #endif
 
-annCtxt :: (OutputableBndrId id) => AnnDecl id -> SDoc
+annCtxt :: (OutputableBndrId id, HasOccNameId id) => AnnDecl id -> SDoc
 annCtxt ann
   = hang (text "In the annotation:") 2 (ppr ann)
index 8285276..7bb863d 100644 (file)
@@ -293,7 +293,7 @@ tc_cmd env (HsCmdDo (L l stmts) _) (cmd_stk, res_ty)
 --      ----------------------------------------------
 --      D; G |-a  (| e c1 ... cn |)  :  stk --> t
 
-tc_cmd env cmd@(HsCmdArrForm expr fixity cmd_args) (cmd_stk, res_ty)
+tc_cmd env cmd@(HsCmdArrForm expr f fixity cmd_args) (cmd_stk, res_ty)
   = addErrCtxt (cmdCtxt cmd)    $
     do  { (cmd_args', cmd_tys) <- mapAndUnzipM tc_cmd_arg cmd_args
                               -- We use alphaTyVar for 'w'
@@ -301,7 +301,7 @@ tc_cmd env cmd@(HsCmdArrForm expr fixity cmd_args) (cmd_stk, res_ty)
                      mkFunTys cmd_tys $
                      mkCmdArrTy env (mkPairTy alphaTy cmd_stk) res_ty
         ; expr' <- tcPolyExpr expr e_ty
-        ; return (HsCmdArrForm expr' fixity cmd_args') }
+        ; return (HsCmdArrForm expr' f fixity cmd_args') }
 
   where
     tc_cmd_arg :: LHsCmdTop Name -> TcM (LHsCmdTop TcId, TcType)
index 2206480..31d650d 100644 (file)
@@ -1703,7 +1703,7 @@ the common case.) -}
 
 -- This one is called on LHS, when pat and grhss are both Name
 -- and on RHS, when pat is TcId and grhss is still Name
-patMonoBindsCtxt :: (OutputableBndrId id, Outputable body)
+patMonoBindsCtxt :: (OutputableBndrId id, HasOccNameId id, Outputable body)
                  => LPat id -> GRHSs Name body -> SDoc
 patMonoBindsCtxt pat grhss
   = hang (text "In a pattern binding:") 2 (pprPatBind pat grhss)
index 6135800..0d4b8f5 100644 (file)
@@ -827,10 +827,11 @@ data InstBindings a
            --          Used only to improve error messages
       }
 
-instance (OutputableBndrId a) => Outputable (InstInfo a) where
+instance (OutputableBndrId a, HasOccNameId a) => Outputable (InstInfo a) where
     ppr = pprInstInfoDetails
 
-pprInstInfoDetails :: (OutputableBndrId a) => InstInfo a -> SDoc
+pprInstInfoDetails :: (OutputableBndrId a, HasOccNameId a)
+                   => InstInfo a -> SDoc
 pprInstInfoDetails info
    = hang (pprInstanceHdr (iSpec info) <+> text "where")
         2 (details (iBinds info))
index 672f4b3..84ee6a1 100644 (file)
@@ -198,8 +198,8 @@ gen_Eq_binds loc tycon
     ------------------------------------------------------------------
     pats_etc data_con
       = let
-            con1_pat = nlConVarPat data_con_RDR as_needed
-            con2_pat = nlConVarPat data_con_RDR bs_needed
+            con1_pat = nlParPat $ nlConVarPat data_con_RDR as_needed
+            con2_pat = nlParPat $ nlConVarPat data_con_RDR bs_needed
 
             data_con_RDR = getRdrName data_con
             con_arity   = length tys_needed
@@ -439,7 +439,7 @@ gen_Ord_binds loc tycon
                                  , mkHsCaseAlt nlWildPat (gtResult op) ]
       where
         tag     = get_tag data_con
-        tag_lit = noLoc (HsLit (HsIntPrim "" (toInteger tag)))
+        tag_lit = noLoc (HsLit (HsIntPrim NoSourceText (toInteger tag)))
 
     mkInnerEqAlt :: OrdOp -> DataCon -> LMatch RdrName (LHsExpr RdrName)
     -- First argument 'a' known to be built with K
@@ -602,7 +602,7 @@ gen_Enum_binds loc tycon
              (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration")
              (nlHsApp (nlHsVar (tag2con_RDR tycon))
                            (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
-                                               nlHsLit (HsInt "-1" (-1))]))
+                                           nlHsLit (HsInt NoSourceText (-1))]))
 
     to_enum
       = mk_easy_FunBind loc toEnum_RDR [a_Pat] $
@@ -1118,7 +1118,7 @@ gen_Show_binds get_fixity loc tycon
       | otherwise   =
          ([a_Pat, con_pat],
           showParen_Expr (genOpApp a_Expr ge_RDR
-                              (nlHsLit (HsInt "" con_prec_plus_one)))
+                              (nlHsLit (HsInt NoSourceText con_prec_plus_one)))
                          (nlHsPar (nested_compose_Expr show_thingies)))
         where
              data_con_RDR  = getRdrName data_con
@@ -1201,7 +1201,8 @@ mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString st
 
 -- | showsPrec :: Show a => Int -> a -> ShowS
 mk_showsPrec_app :: Integer -> LHsExpr RdrName -> LHsExpr RdrName
-mk_showsPrec_app p x = nlHsApps showsPrec_RDR [nlHsLit (HsInt "" p), x]
+mk_showsPrec_app p x
+  = nlHsApps showsPrec_RDR [nlHsLit (HsInt NoSourceText p), x]
 
 -- | shows :: Show a => a -> ShowS
 mk_shows_app :: LHsExpr RdrName -> LHsExpr RdrName
@@ -1359,7 +1360,7 @@ gen_data dflags data_type_name constr_names loc rep_tc
                         -- redundant test, and annoying warning
       | tag-fIRST_TAG == n_cons-1 = nlWildPat   -- Last constructor
       | otherwise = nlConPat intDataCon_RDR
-                             [nlLitPat (HsIntPrim "" (toInteger tag))]
+                             [nlLitPat (HsIntPrim NoSourceText (toInteger tag))]
       where
         tag = dataConTag dc
 
@@ -1684,7 +1685,7 @@ gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty
 nlHsAppType :: LHsExpr RdrName -> Type -> LHsExpr RdrName
 nlHsAppType e s = noLoc (e `HsAppType` hs_ty)
   where
-    hs_ty = mkHsWildCardBndrs (typeToLHsType s)
+    hs_ty = mkHsWildCardBndrs $ nlHsParTy (typeToLHsType s)
 
 nlExprWithTySig :: LHsExpr RdrName -> Type -> LHsExpr RdrName
 nlExprWithTySig e s = noLoc (e `ExprWithTySig` hs_ty)
@@ -1755,7 +1756,7 @@ genAuxBindSpec loc (DerivCon2Tag tycon)
 
     mk_eqn :: DataCon -> ([LPat RdrName], LHsExpr RdrName)
     mk_eqn con = ([nlWildConPat con],
-                  nlHsLit (HsIntPrim ""
+                  nlHsLit (HsIntPrim NoSourceText
                                     (toInteger ((dataConTag con) - fIRST_TAG))))
 
 genAuxBindSpec loc (DerivTag2Con tycon)
@@ -1776,7 +1777,8 @@ genAuxBindSpec loc (DerivMaxTag tycon)
   where
     rdr_name = maxtag_RDR tycon
     sig_ty = mkLHsSigWcType (L loc (HsCoreTy intTy))
-    rhs = nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim "" max_tag))
+    rhs = nlHsApp (nlHsVar intDataCon_RDR)
+                  (nlHsLit (HsIntPrim NoSourceText max_tag))
     max_tag =  case (tyConDataCons tycon) of
                  data_cons -> toInteger ((length data_cons) - fIRST_TAG)
 
index c577403..96dfd4c 100644 (file)
@@ -310,7 +310,10 @@ mkSimpleConMatch :: Monad m => HsMatchContext RdrName
 mkSimpleConMatch ctxt fold extra_pats con insides = do
     let con_name = getRdrName con
     let vars_needed = takeList insides as_RDRs
-    let pat = nlConVarPat con_name vars_needed
+    let bare_pat = nlConVarPat con_name vars_needed
+    let pat = if null vars_needed
+          then bare_pat
+          else nlParPat bare_pat
     rhs <- fold con_name (zipWith nlHsApp insides (map nlHsVar vars_needed))
     return $ mkMatch ctxt (extra_pats ++ [pat]) rhs
                      (noLoc emptyLocalBinds)
index 0c65f68..66cf122 100644 (file)
@@ -760,8 +760,8 @@ genLR_P :: Int -> Int -> LPat RdrName -> LPat RdrName
 genLR_P i n p
   | n == 0       = error "impossible"
   | n == 1       = p
-  | i <= div n 2 = nlConPat l1DataCon_RDR [genLR_P i     (div n 2) p]
-  | otherwise    = nlConPat r1DataCon_RDR [genLR_P (i-m) (n-m)     p]
+  | i <= div n 2 = nlParPat $ nlConPat l1DataCon_RDR [genLR_P i     (div n 2) p]
+  | otherwise    = nlParPat $ nlConPat r1DataCon_RDR [genLR_P (i-m) (n-m)     p]
                      where m = div n 2
 
 -- Generates the L1/R1 sum expression
@@ -832,12 +832,12 @@ mkProd_P gk _ varTys = mkM1_P (foldBal prod appVars)
                      -- These M1s are meta-information for the constructor
   where
     appVars = unzipWith (wrapArg_P gk) varTys
-    prod a b = prodDataCon_RDR `nlConPat` [a,b]
+    prod a b = nlParPat $ prodDataCon_RDR `nlConPat` [a,b]
 
 wrapArg_P :: GenericKind -> RdrName -> Type -> LPat RdrName
-wrapArg_P Gen0 v ty = mkM1_P (boxRepRDR ty `nlConVarPat` [v])
+wrapArg_P Gen0 v ty = mkM1_P (nlParPat $ boxRepRDR ty `nlConVarPat` [v])
                    -- This M1 is meta-information for the selector
-wrapArg_P Gen1 v _  = m1DataCon_RDR `nlConVarPat` [v]
+wrapArg_P Gen1 v _  = nlParPat $ m1DataCon_RDR `nlConVarPat` [v]
 
 mkGenericLocal :: US -> RdrName
 mkGenericLocal u = mkVarUnqual (mkFastString ("g" ++ show u))
@@ -855,7 +855,7 @@ mkM1_E :: LHsExpr RdrName -> LHsExpr RdrName
 mkM1_E e = nlHsVar m1DataCon_RDR `nlHsApp` e
 
 mkM1_P :: LPat RdrName -> LPat RdrName
-mkM1_P p = m1DataCon_RDR `nlConPat` [p]
+mkM1_P p = nlParPat $ m1DataCon_RDR `nlConPat` [p]
 
 nlHsCompose :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
 nlHsCompose x y = compose_RDR `nlHsApps` [x, y]
index 3926532..9f320f5 100644 (file)
@@ -874,10 +874,10 @@ zonkCmd env (HsCmdArrApp e1 e2 ty ho rl)
        new_ty <- zonkTcTypeToType env ty
        return (HsCmdArrApp new_e1 new_e2 new_ty ho rl)
 
-zonkCmd env (HsCmdArrForm op fixity args)
+zonkCmd env (HsCmdArrForm op f fixity args)
   = do new_op <- zonkLExpr env op
        new_args <- mapM (zonkCmdTop env) args
-       return (HsCmdArrForm new_op fixity new_args)
+       return (HsCmdArrForm new_op f fixity new_args)
 
 zonkCmd env (HsCmdApp c e)
   = do new_c <- zonkLCmd env c
index 96d598e..d96e74e 100644 (file)
@@ -430,7 +430,7 @@ tc_infer_lhs_type mode (L span ty)
 -- | Infer the kind of a type and desugar. This is the "up" type-checker,
 -- as described in Note [Bidirectional type checking]
 tc_infer_hs_type :: TcTyMode -> HsType Name -> TcM (TcType, TcKind)
-tc_infer_hs_type mode (HsTyVar (L _ tv)) = tcTyVar mode tv
+tc_infer_hs_type mode (HsTyVar (L _ tv)) = tcTyVar mode tv
 tc_infer_hs_type mode (HsAppTy ty1 ty2)
   = do { let (fun_ty, arg_tys) = splitHsAppTys ty1 [ty2]
        ; (fun_ty', fun_kind) <- tc_infer_lhs_type mode fun_ty
@@ -602,7 +602,7 @@ tc_hs_type mode (HsSumTy hs_tys) exp_kind
        }
 
 --------- Promoted lists and tuples
-tc_hs_type mode (HsExplicitListTy _k tys) exp_kind
+tc_hs_type mode (HsExplicitListTy _ _k tys) exp_kind
   = do { tks <- mapM (tc_infer_lhs_type mode) tys
        ; (taus', kind) <- unifyKinds tks
        ; let ty = (foldr (mk_cons kind) (mk_nil kind) taus')
index dc951b9..623458a 100644 (file)
@@ -1293,7 +1293,7 @@ tcMethods dfun_id clas tyvars dfun_ev_vars inst_tys
                                 [ getRuntimeRep "tcInstanceMethods.tc_default" meth_tau
                                 , meth_tau])
                               nO_METHOD_BINDING_ERROR_ID
-        error_msg dflags = L inst_loc (HsLit (HsStringPrim ""
+        error_msg dflags = L inst_loc (HsLit (HsStringPrim NoSourceText
                                               (unsafeMkByteString (error_string dflags))))
         meth_tau     = funResultTy (piResultTys (idType sel_id) inst_tys)
         error_string dflags = showSDoc dflags
index b1d444a..10e50d4 100644 (file)
@@ -1186,7 +1186,8 @@ polyPatSig sig_ty
   = hang (text "Illegal polymorphic type signature in pattern:")
        2 (ppr sig_ty)
 
-lazyUnliftedPatErr :: (OutputableBndrId name) => Pat name -> TcM ()
+lazyUnliftedPatErr :: (OutputableBndrId name, HasOccNameId name)
+                   => Pat name -> TcM ()
 lazyUnliftedPatErr pat
   = failWithTc $
     hang (text "A lazy (~) pattern cannot contain unlifted types:")
index 47a27b3..3e68971 100644 (file)
@@ -764,19 +764,22 @@ tcCheckPatSynPat = go
     go1   SigPatOut{}         = panic "SigPatOut in output of renamer"
     go1   CoPat{}             = panic "CoPat in output of renamer"
 
-asPatInPatSynErr :: (OutputableBndrId name) => Pat name -> TcM a
+asPatInPatSynErr :: (OutputableBndrId name, HasOccNameId name)
+                 => Pat name -> TcM a
 asPatInPatSynErr pat
   = failWithTc $
     hang (text "Pattern synonym definition cannot contain as-patterns (@):")
        2 (ppr pat)
 
-thInPatSynErr :: (OutputableBndrId name) => Pat name -> TcM a
+thInPatSynErr :: (OutputableBndrId name, HasOccNameId name)
+              => Pat name -> TcM a
 thInPatSynErr pat
   = failWithTc $
     hang (text "Pattern synonym definition cannot contain Template Haskell:")
        2 (ppr pat)
 
-nPlusKPatInPatSynErr :: (OutputableBndrId name) => Pat name -> TcM a
+nPlusKPatInPatSynErr :: (OutputableBndrId name, HasOccNameId name)
+                     => Pat name -> TcM a
 nPlusKPatInPatSynErr pat
   = failWithTc $
     hang (text "Pattern synonym definition cannot contain n+k-pattern:")
index dd5c9f3..a0838ee 100644 (file)
@@ -441,7 +441,7 @@ When a variable is used, we compare
 ************************************************************************
 -}
 
-tcSpliceExpr splice@(HsTypedSplice name expr) res_ty
+tcSpliceExpr splice@(HsTypedSplice name expr) res_ty
   = addErrCtxt (spliceCtxtDoc splice) $
     setSrcSpan (getLoc expr)    $ do
     { stage <- getStage
index b9bc595..24666cf 100644 (file)
@@ -1157,7 +1157,7 @@ kcDataDefn fam_name (HsIB { hsib_body = pats })
             Just k  -> do { k' <- tcLHsKind k
                           ; unifyKind (Just hs_ty_pats) res_k k' } }
   where
-    hs_ty_pats = mkHsAppTys (noLoc $ HsTyVar (noLoc fam_name)) pats
+    hs_ty_pats = mkHsAppTys (noLoc $ HsTyVar NotPromoted (noLoc fam_name)) pats
 
 {-
 Kind check type patterns and kind annotate the embedded type variables.
index f2a868d..e8046c7 100644 (file)
@@ -885,7 +885,7 @@ mkOneRecordSelector all_cons idDetails fl
     inst_tys = substTyVars eq_subst univ_tvs
 
     unit_rhs = mkLHsTupleExpr []
-    msg_lit = HsStringPrim "" (fastStringToByteString lbl)
+    msg_lit = HsStringPrim NoSourceText (fastStringToByteString lbl)
 
 {-
 Note [Polymorphic selectors]
index 04d07d1..dd8ed86 100644 (file)
@@ -8,6 +8,7 @@
 module TcTypeable(mkTypeableBinds) where
 
 
+import BasicTypes ( SourceText(..) )
 import TcBinds( addTypecheckedBinds )
 import IfaceEnv( newGlobalBinder )
 import TcEnv
@@ -286,5 +287,6 @@ mkTyConRepRHS (Stuff {..}) tycon = rep_rhs
     Fingerprint high low = fingerprintString hashThis
 
     word64 :: Word64 -> HsLit
-    word64 | wORD_SIZE dflags == 4 = \n -> HsWord64Prim (show n) (toInteger n)
-           | otherwise             = \n -> HsWordPrim   (show n) (toInteger n)
+    word64
+      | wORD_SIZE dflags == 4 = \n -> HsWord64Prim NoSourceText (toInteger n)
+      | otherwise             = \n -> HsWordPrim   NoSourceText (toInteger n)
index 26a4d19..07eb3bc 100644 (file)
@@ -980,3 +980,18 @@ instance Binary Serialized where
         the_type <- get bh
         bytes <- get bh
         return (Serialized the_type bytes)
+
+instance Binary SourceText where
+  put_ bh NoSourceText = putByte bh 0
+  put_ bh (SourceText s) = do
+        putByte bh 1
+        put_ bh s
+
+  get bh = do
+    h <- getByte bh
+    case h of
+      0 -> return NoSourceText
+      1 -> do
+        s <- get bh
+        return (SourceText s)
+      _ -> panic $ "Binary SourceText:" ++ show h
index 4764b1b..ec9a889 100644 (file)
@@ -23,6 +23,7 @@ import MonadUtils
 import Outputable
 import Binary
 import SrcLoc
+import OccName ( HasOccName(..), isSymOcc )
 
 ----------------------------------------------------------------------
 -- Boolean formula type and smart constructors
@@ -200,8 +201,19 @@ pprBooleanFormulaNice = pprBooleanFormula' pprVar pprAnd pprOr 0
   pprAnd' xs@(_:_) = fsep (punctuate comma (init xs)) <> text ", and" <+> last xs
   pprOr p xs = cparen (p > 1) $ text "either" <+> sep (intersperse (text "or") xs)
 
-instance Outputable a => Outputable (BooleanFormula a) where
-  pprPrec = pprBooleanFormula pprPrec
+instance (Outputable a, HasOccName a) => Outputable (BooleanFormula a) where
+  ppr = pprBooleanFormulaNormal
+
+pprBooleanFormulaNormal :: (Outputable a, HasOccName a)
+                        => BooleanFormula a -> SDoc
+pprBooleanFormulaNormal = go
+  where
+    go (Var x)    = pprPrefixVar (isSymOcc (occName x)) (ppr x)
+    go (And xs)   = fsep $ punctuate comma (map (go . unLoc) xs)
+    go (Or [])    = keyword $ text "FALSE"
+    go (Or xs)    = fsep $ intersperse vbar (map (go . unLoc) xs)
+    go (Parens x) = parens (go $ unLoc x)
+
 
 ----------------------------------------------------------------------
 -- Binary
index 1231ab0..16f257e 100644 (file)
@@ -53,7 +53,9 @@ module Outputable (
         pprInfixVar, pprPrefixVar,
         pprHsChar, pprHsString, pprHsBytes,
 
-        primFloatSuffix, primDoubleSuffix,
+        primFloatSuffix, primCharSuffix, primWordSuffix, primDoubleSuffix,
+        primInt64Suffix, primWord64Suffix, primIntSuffix,
+
         pprPrimChar, pprPrimInt, pprPrimWord, pprPrimInt64, pprPrimWord64,
 
         pprFastFilePath,
index e5b94b1..4560c83 100644 (file)
@@ -14,6 +14,7 @@ import Vectorise.Generic.Description
 import Vectorise.Utils
 import Vectorise.Env( GlobalEnv( global_fam_inst_env ) )
 
+import BasicTypes ( SourceText(..) )
 import BuildTyCl
 import DataCon
 import TyCon
@@ -89,7 +90,7 @@ buildPDataDataCon orig_name vect_tc repr_tc repr
                             (mkFamilyTyConApp repr_tc (mkTyVarTys tvs))
                             repr_tc
   where
-    no_bang = HsSrcBang Nothing NoSrcUnpack NoSrcStrict
+    no_bang = HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict
 
 
 -- buildPDatasTyCon -----------------------------------------------------------
@@ -133,7 +134,7 @@ buildPDatasDataCon orig_name vect_tc repr_tc repr
                             (mkFamilyTyConApp repr_tc (mkTyVarTys tvs))
                             repr_tc
   where
-     no_bang = HsSrcBang Nothing NoSrcUnpack NoSrcStrict
+     no_bang = HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict
 
 
 -- Utils ----------------------------------------------------------------------
diff --git a/ghc.mk b/ghc.mk
index 792bd21..139b6d1 100644 (file)
--- a/ghc.mk
+++ b/ghc.mk
@@ -563,6 +563,7 @@ ghc/stage2/package-data.mk: compiler/stage2/package-data.mk
 utils/haddock/dist/package-data.mk: compiler/stage2/package-data.mk
 utils/ghctags/dist-install/package-data.mk: compiler/stage2/package-data.mk
 utils/check-api-annotations/dist-install/package-data.mk: compiler/stage2/package-data.mk
+utils/check-ppr/dist-install/package-data.mk: compiler/stage2/package-data.mk
 utils/mkUserGuidePart/dist/package-data.mk: compiler/stage2/package-data.mk
 
 # add the final package.conf dependency: ghc-prim depends on RTS
@@ -681,6 +682,7 @@ BUILD_DIRS += utils/ghc-pkg
 BUILD_DIRS += utils/testremove
 BUILD_DIRS += utils/ghctags
 BUILD_DIRS += utils/check-api-annotations
+BUILD_DIRS += utils/check-ppr
 BUILD_DIRS += utils/dll-split
 BUILD_DIRS += utils/ghc-cabal
 BUILD_DIRS += utils/hpc
@@ -734,6 +736,7 @@ ifneq "$(CrossCompiling) $(Stage1Only)" "NO NO"
 # See Note [Stage1Only vs stage=1] in mk/config.mk.in.
 BUILD_DIRS := $(filter-out utils/ghctags,$(BUILD_DIRS))
 BUILD_DIRS := $(filter-out utils/check-api-annotations,$(BUILD_DIRS))
+BUILD_DIRS := $(filter-out utils/check-ppr,$(BUILD_DIRS))
 endif
 endif # CLEANING
 
index 93b4f01..0b684c7 100644 (file)
@@ -220,6 +220,7 @@ RM = rm -f
 PYTHON = python3
 
 CHECK_API_ANNOTATIONS := $(abspath $(TOP)/../inplace/bin/check-api-annotations)
+CHECK_PPR             := $(abspath $(TOP)/../inplace/bin/check-ppr)
 
 # -----------------------------------------------------------------------------
 # configuration of TEST_HC
index fe730f6..c2fb6b6 100644 (file)
@@ -6,9 +6,9 @@ ado002.hs:8:8: error:
       but its type ‘IO Char’ has none
       In a stmt of a 'do' block: y <- getChar 'a'
       In the expression:
-        do { x <- getChar;
-             y <- getChar 'a';
-             print (x, y) }
+        do x <- getChar
+           y <- getChar 'a'
+           print (x, y)
 
 ado002.hs:9:3: error:
     • Couldn't match type ‘()’ with ‘Int’
@@ -16,31 +16,31 @@ ado002.hs:9:3: error:
         Actual type: IO ()
     • In a stmt of a 'do' block: print (x, y)
       In the expression:
-        do { x <- getChar;
-             y <- getChar 'a';
-             print (x, y) }
+        do x <- getChar
+           y <- getChar 'a'
+           print (x, y)
       In an equation for ‘f’:
-          f = do { x <- getChar;
-                   y <- getChar 'a';
-                   print (x, y) }
+          f = do x <- getChar
+                 y <- getChar 'a'
+                 print (x, y)
 
 ado002.hs:15:11: error:
     • Couldn't match expected type ‘Int’ with actual type ‘Char’
     • In the expression: y
       In a stmt of a 'do' block: return (y, x)
       In the expression:
-        do { x <- getChar;
-             y <- getChar;
-             return (y, x) }
+        do x <- getChar
+           y <- getChar
+           return (y, x)
 
 ado002.hs:15:13: error:
     • Couldn't match expected type ‘Int’ with actual type ‘Char’
     • In the expression: x
       In a stmt of a 'do' block: return (y, x)
       In the expression:
-        do { x <- getChar;
-             y <- getChar;
-             return (y, x) }
+        do x <- getChar
+           y <- getChar
+           return (y, x)
 
 ado002.hs:23:9: error:
     • Couldn't match expected type ‘Char -> IO t0’
@@ -49,33 +49,33 @@ ado002.hs:23:9: error:
       but its type ‘IO Char’ has none
       In a stmt of a 'do' block: x5 <- getChar x4
       In the expression:
-        do { x1 <- getChar;
-             x2 <- getChar;
-             x3 <- const (return ()) x1;
-             x4 <- getChar;
-             x5 <- getChar x4;
-             return (x2, x4) }
+        do x1 <- getChar
+           x2 <- getChar
+           x3 <- const (return ()) x1
+           x4 <- getChar
+           x5 <- getChar x4
+           return (x2, x4)
 
 ado002.hs:24:11: error:
     • Couldn't match expected type ‘Int’ with actual type ‘Char’
     • In the expression: x2
       In a stmt of a 'do' block: return (x2, x4)
       In the expression:
-        do { x1 <- getChar;
-             x2 <- getChar;
-             x3 <- const (return ()) x1;
-             x4 <- getChar;
-             x5 <- getChar x4;
-             return (x2, x4) }
+        do x1 <- getChar
+           x2 <- getChar
+           x3 <- const (return ()) x1
+           x4 <- getChar
+           x5 <- getChar x4
+           return (x2, x4)
 
 ado002.hs:24:14: error:
     • Couldn't match expected type ‘Int’ with actual type ‘Char’
     • In the expression: x4
       In a stmt of a 'do' block: return (x2, x4)
       In the expression:
-        do { x1 <- getChar;
-             x2 <- getChar;
-             x3 <- const (return ()) x1;
-             x4 <- getChar;
-             x5 <- getChar x4;
-             return (x2, x4) }
+        do x1 <- getChar
+           x2 <- getChar
+           x3 <- const (return ()) x1
+           x4 <- getChar
+           x5 <- getChar x4
+           return (x2, x4)
index 5d04f15..cdc5c59 100644 (file)
@@ -4,6 +4,6 @@ ado003.hs:7:3: error:
     In the pattern: 'a'
     In a stmt of a 'do' block: 'a' <- return (3 :: Int)
     In the expression:
-      do { x <- getChar;
-           'a' <- return (3 :: Int);
-           return () }
+      do x <- getChar
+         'a' <- return (3 :: Int)
+         return ()
index 4bfc79e..90d0b02 100644 (file)
@@ -11,11 +11,11 @@ ado005.hs:8:3: error:
           test :: Applicative f => (Int -> f Int) -> f Int
     In a stmt of a 'do' block: x <- f 3
     In the expression:
-      do { x <- f 3;
-           y <- f x;
-           return (x + y) }
+      do x <- f 3
+         y <- f x
+         return (x + y)
     In an equation for ‘test’:
         test f
-          = do { x <- f 3;
-                 y <- f x;
-                 return (x + y) }
+          = do x <- f 3
+               y <- f x
+               return (x + y)
index 1386d14..e479369 100644 (file)
@@ -2,6 +2,6 @@
 arrowfail004.hs:12:15:
     Proc patterns cannot use existential or GADT data constructors
     In the pattern: T x
-    In the expression: proc (T x) -> do { returnA -< T x }
+    In the expression: proc (T x) -> do returnA -< T x
     In an equation for ‘panic’:
-        panic = proc (T x) -> do { returnA -< T x }
+        panic = proc (T x) -> do returnA -< T x
index 053a3bc..75a8e0c 100644 (file)
@@ -13,6 +13,6 @@ Base1.hs:25:39: error:
     • In the expression: Just (x, y)
       In a case alternative: MRight y -> Just (x, y)
       In the expression:
-        case m of {
+        case m of
           MRight y -> Just (x, y)
-          _ -> Nothing }
+          _ -> Nothing
index 544124e..f068330 100644 (file)
@@ -1,6 +1,5 @@
 
 PromotedClass.hs:10:15: error:
     • Illegal constraint in a type: Show a0
-    • In the first argument of ‘Proxy’, namely ‘MkX True’
-      In the type signature:
-        foo :: Proxy (MkX True)
+    • In the first argument of ‘Proxy’, namely ‘( 'MkX  'True)’
+      In the type signature: foo :: Proxy ( 'MkX  'True)
index 1a54c7d..cb94dd2 100644 (file)
@@ -15,5 +15,5 @@ RAE_T32a.hs:28:20: error:
 
 RAE_T32a.hs:28:27: error:
     Expected kind ‘Sigma’, but ‘Sigma p r’ has kind ‘*’
-    In the second argument of ‘Sing’, namely ‘Sigma p r
+    In the second argument of ‘Sing’, namely ‘(Sigma p r)
     In the data instance declaration for ‘Sing’
index 8f4251b..effdf20 100644 (file)
@@ -3,22 +3,22 @@ T11334b.hs:8:14: error:
     • Cannot default kind variable ‘f0’
       of kind: k0 -> *
       Perhaps enable PolyKinds or add a kind signature
-    • In an expression type signature: Proxy Compose
-      In the expression: Proxy :: Proxy Compose
-      In an equation for ‘p’: p = Proxy :: Proxy Compose
+    • In an expression type signature: Proxy 'Compose
+      In the expression: Proxy :: Proxy 'Compose
+      In an equation for ‘p’: p = Proxy :: Proxy 'Compose
 
 T11334b.hs:8:14: error:
     • Cannot default kind variable ‘g0’
       of kind: k10 -> k0
       Perhaps enable PolyKinds or add a kind signature
-    • In an expression type signature: Proxy Compose
-      In the expression: Proxy :: Proxy Compose
-      In an equation for ‘p’: p = Proxy :: Proxy Compose
+    • In an expression type signature: Proxy 'Compose
+      In the expression: Proxy :: Proxy 'Compose
+      In an equation for ‘p’: p = Proxy :: Proxy 'Compose
 
 T11334b.hs:8:14: error:
     • Cannot default kind variable ‘a0’
       of kind: k10
       Perhaps enable PolyKinds or add a kind signature
-    • In an expression type signature: Proxy Compose
-      In the expression: Proxy :: Proxy Compose
-      In an equation for ‘p’: p = Proxy :: Proxy Compose
+    • In an expression type signature: Proxy 'Compose
+      In the expression: Proxy :: Proxy 'Compose
+      In an equation for ‘p’: p = Proxy :: Proxy 'Compose
index fae0f50..3421467 100644 (file)
@@ -4,4 +4,4 @@ T10461.hs:6:1: error:
       ‘Word#’ cannot be marshalled in a foreign call
       To marshal unlifted types, use UnliftedFFITypes
     When checking declaration:
-      foreign import prim safe "static cheneycopy" cheneycopy :: Any -> Word#
+      foreign import prim safe cheneycopy :: Any -> Word#
index e6d292d..3b6c3f9 100644 (file)
@@ -3,5 +3,4 @@ T3066.hs:6:1:
     Unacceptable argument type in foreign declaration:
       ‘forall u. Ptr ()’ is not a data type
     When checking declaration:
-      foreign import ccall safe "static bla" bla
-        :: (forall u. X u) -> IO ()
+      foreign import ccall safe bla :: (forall u. X u) -> IO ()
index dd893df..9a1aa25 100644 (file)
@@ -4,5 +4,5 @@ T7506.hs:6:1:
       ‘Int -> IO ()’ cannot be marshalled in a foreign call
       A foreign-imported address (via &foo) must have type (Ptr a) or (FunPtr a)
     When checking declaration:
-      foreign import ccall safe "static stdio.h &putchar" c_putchar
+      foreign import ccall safe "stdio.h &putchar" c_putchar
         :: Int -> IO ()
index 99ffad6..6732c5c 100644 (file)
@@ -2,5 +2,4 @@
 capi_value_function.hs:8:1:
     `value' imports cannot have function types
     When checking declaration:
-      foreign import capi safe "static math.h value sqrt" f
-        :: CInt -> CInt
+      foreign import capi safe "math.h value sqrt" f :: CInt -> CInt
index e890041..01c7ea5 100644 (file)
@@ -3,5 +3,4 @@ ccfail001.hs:10:1:
     Unacceptable result type in foreign declaration:
       ‘State# RealWorld’ cannot be marshalled in a foreign call
     When checking declaration:
-      foreign import ccall safe "static foo" foo
-        :: Int -> State# RealWorld
+      foreign import ccall safe foo :: Int -> State# RealWorld
index 309fa52..c3c04e2 100644 (file)
@@ -3,5 +3,5 @@ ccfail002.hs:10:1:
     Unacceptable result type in foreign declaration:
       ‘(# Int#, Int#, Int# #)’ cannot be marshalled in a foreign call
     When checking declaration:
-      foreign import ccall unsafe "static foo" foo
+      foreign import ccall unsafe "foo" foo
         :: Int# -> Int# -> Int# -> (# Int#, Int#, Int# #)
index 825c47c..60aaf30 100644 (file)
@@ -5,7 +5,7 @@ ccfail004.hs:9:1:
         because its data constructor is not in scope
         Possible fix: import the data constructor to bring it into scope
     When checking declaration:
-      foreign import ccall safe "static f1" f1 :: NInt -> IO Int
+       foreign import ccall safe f1 :: NInt -> IO Int
 
 ccfail004.hs:10:1:
     Unacceptable result type in foreign declaration:
@@ -13,7 +13,7 @@ ccfail004.hs:10:1:
         because its data constructor is not in scope
         Possible fix: import the data constructor to bring it into scope
     When checking declaration:
-      foreign import ccall safe "static f2" f2 :: Int -> IO NInt
+       foreign import ccall safe f2 :: Int -> IO NInt
 
 ccfail004.hs:11:1:
     Unacceptable result type in foreign declaration:
@@ -21,16 +21,16 @@ ccfail004.hs:11:1:
         because the data constructor for ‘NIO’ is not in scope
         Possible fix: import the data constructor to bring it into scope
     When checking declaration:
-      foreign import ccall safe "static f3" f3 :: Int -> NIO Int
+      foreign import ccall safe f3 :: Int -> NIO Int
 
 ccfail004.hs:14:1:
     Unacceptable argument type in foreign declaration:
       ‘[NT]’ cannot be marshalled in a foreign call
     When checking declaration:
-      foreign import ccall safe "static f4" f4 :: NT -> IO ()
+      foreign import ccall safe f4 :: NT -> IO ()
 
 ccfail004.hs:15:1:
     Unacceptable result type in foreign declaration:
       ‘[NT]’ cannot be marshalled in a foreign call
     When checking declaration:
-      foreign import ccall safe "static f5" f5 :: IO NT
+      foreign import ccall safe f5 :: IO NT
index 413faa7..d5e2a27 100644 (file)
@@ -2,11 +2,9 @@
 ccfail005.hs:14:1:
     Unacceptable argument type in foreign declaration:
       ‘D’ cannot be marshalled in a foreign call
-    When checking declaration:
-      foreign import ccall safe "static f1" f1 :: F Bool
+    When checking declaration: foreign import ccall safe f1 :: F Bool
 
 ccfail005.hs:15:1:
     Unacceptable result type in foreign declaration:
       ‘D’ cannot be marshalled in a foreign call
-    When checking declaration:
-      foreign import ccall safe "static f2" f2 :: F Char
+    When checking declaration: foreign import ccall safe f2 :: F Char
index 65dcadb..3e1f175 100644 (file)
@@ -4,7 +4,7 @@ Derived class instances:
   instance GHC.Generics.Generic (GenDerivOutput.List a) where
     GHC.Generics.from x
       = GHC.Generics.M1
-          (case x of {
+          (case x of
              GenDerivOutput.Nil
                -> GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1)
              GenDerivOutput.Cons g1 g2
@@ -12,19 +12,19 @@ Derived class instances:
                     (GHC.Generics.M1
                        ((GHC.Generics.:*:)
                           (GHC.Generics.M1 (GHC.Generics.K1 g1))
-                          (GHC.Generics.M1 (GHC.Generics.K1 g2)))) })
+                          (GHC.Generics.M1 (GHC.Generics.K1 g2)))))
     GHC.Generics.to (GHC.Generics.M1 x)
-      = case x of {
-          GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1)
+      = case x of
+          (GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1))
             -> GenDerivOutput.Nil
-          GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g1))
-                                                               (GHC.Generics.M1 (GHC.Generics.K1 g2))))
-            -> GenDerivOutput.Cons g1 g2 }
+          (GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g1))
+                                                                (GHC.Generics.M1 (GHC.Generics.K1 g2)))))
+            -> GenDerivOutput.Cons g1 g2
   
   instance GHC.Generics.Generic1 GenDerivOutput.List where
     GHC.Generics.from1 x
       = GHC.Generics.M1
-          (case x of {
+          (case x of
              GenDerivOutput.Nil
                -> GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1)
              GenDerivOutput.Cons g1 g2
@@ -32,15 +32,15 @@ Derived class instances:
                     (GHC.Generics.M1
                        ((GHC.Generics.:*:)
                           (GHC.Generics.M1 (GHC.Generics.Par1 g1))
-                          (GHC.Generics.M1 (GHC.Generics.Rec1 g2)))) })
+                          (GHC.Generics.M1 (GHC.Generics.Rec1 g2)))))
     GHC.Generics.to1 (GHC.Generics.M1 x)
-      = case x of {
-          GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1)
+      = case x of
+          (GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1))
             -> GenDerivOutput.Nil
-          GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 g1)
-                                                               (GHC.Generics.M1 g2)))
+          (GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 g1)
+                                                                (GHC.Generics.M1 g2))))
             -> GenDerivOutput.Cons
-                 (GHC.Generics.unPar1 g1) (GHC.Generics.unRec1 g2) }
+                 (GHC.Generics.unPar1 g1) (GHC.Generics.unRec1 g2)
   
   instance GHC.Base.Functor GenDerivOutput.List where
     GHC.Base.fmap f GenDerivOutput.Nil = GenDerivOutput.Nil
@@ -50,7 +50,7 @@ Derived class instances:
   instance GHC.Generics.Generic (GenDerivOutput.Rose a) where
     GHC.Generics.from x
       = GHC.Generics.M1
-          (case x of {
+          (case x of
              GenDerivOutput.Empty
                -> GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1)
              GenDerivOutput.Rose g1 g2
@@ -58,19 +58,19 @@ Derived class instances:
                     (GHC.Generics.M1
                        ((GHC.Generics.:*:)
                           (GHC.Generics.M1 (GHC.Generics.K1 g1))
-                          (GHC.Generics.M1 (GHC.Generics.K1 g2)))) })
+                          (GHC.Generics.M1 (GHC.Generics.K1 g2)))))
     GHC.Generics.to (GHC.Generics.M1 x)
-      = case x of {
-          GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1)
+      = case x of
+          (GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1))
             -> GenDerivOutput.Empty
-          GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g1))
-                                                               (GHC.Generics.M1 (GHC.Generics.K1 g2))))
-            -> GenDerivOutput.Rose g1 g2 }
+          (GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g1))
+                                                                (GHC.Generics.M1 (GHC.Generics.K1 g2)))))
+            -> GenDerivOutput.Rose g1 g2
   
   instance GHC.Generics.Generic1 GenDerivOutput.Rose where
     GHC.Generics.from1 x
       = GHC.Generics.M1
-          (case x of {
+          (case x of
              GenDerivOutput.Empty
                -> GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1)
              GenDerivOutput.Rose g1 g2
@@ -80,17 +80,17 @@ Derived class instances:
                           (GHC.Generics.M1 (GHC.Generics.Par1 g1))
                           (GHC.Generics.M1
                              ((GHC.Base..)
-                                GHC.Generics.Comp1 (GHC.Base.fmap GHC.Generics.Rec1) g2)))) })
+                                GHC.Generics.Comp1 (GHC.Base.fmap GHC.Generics.Rec1) g2)))))
     GHC.Generics.to1 (GHC.Generics.M1 x)
-      = case x of {
-          GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1)
+      = case x of
+          (GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1))
             -> GenDerivOutput.Empty
-          GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 g1)
-                                                               (GHC.Generics.M1 g2)))
+          (GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 g1)
+                                                                (GHC.Generics.M1 g2))))
             -> GenDerivOutput.Rose
                  (GHC.Generics.unPar1 g1)
                  ((GHC.Base..)
-                    (GHC.Base.fmap GHC.Generics.unRec1) GHC.Generics.unComp1 g2) }
+                    (GHC.Base.fmap GHC.Generics.unRec1) GHC.Generics.unComp1 g2)
   
 
 Derived type family instances:
index 162fa0f..bf9cf15 100644 (file)
@@ -4,7 +4,7 @@ Derived class instances:
   instance GHC.Generics.Generic1 GenDerivOutput1_0.List where
     GHC.Generics.from1 x
       = GHC.Generics.M1
-          (case x of {
+          (case x of
              GenDerivOutput1_0.Nil
                -> GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1)
              GenDerivOutput1_0.Cons g1 g2
@@ -12,15 +12,15 @@ Derived class instances:
                     (GHC.Generics.M1
                        ((GHC.Generics.:*:)
                           (GHC.Generics.M1 (GHC.Generics.Par1 g1))
-                          (GHC.Generics.M1 (GHC.Generics.Rec1 g2)))) })
+                          (GHC.Generics.M1 (GHC.Generics.Rec1 g2)))))
     GHC.Generics.to1 (GHC.Generics.M1 x)
-      = case x of {
-          GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1)
+      = case x of
+          (GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1))
             -> GenDerivOutput1_0.Nil
-          GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 g1)
-                                                               (GHC.Generics.M1 g2)))
+          (GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 g1)
+                                                                (GHC.Generics.M1 g2))))
             -> GenDerivOutput1_0.Cons
-                 (GHC.Generics.unPar1 g1) (GHC.Generics.unRec1 g2) }
+                 (GHC.Generics.unPar1 g1) (GHC.Generics.unRec1 g2)
   
 
 Derived type family instances:
index 31a9e43..5f4e7e2 100644 (file)
@@ -4,7 +4,7 @@ Derived class instances:
   instance GHC.Generics.Generic1 CanDoRep1_1.Dd where
     GHC.Generics.from1 x
       = GHC.Generics.M1
-          (case x of {
+          (case x of
              CanDoRep1_1.D0d
                -> GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1)
              CanDoRep1_1.D1d g1 g2
@@ -12,20 +12,20 @@ Derived class instances:
                     (GHC.Generics.M1
                        ((GHC.Generics.:*:)
                           (GHC.Generics.M1 (GHC.Generics.Par1 g1))
-                          (GHC.Generics.M1 (GHC.Generics.Rec1 g2)))) })
+                          (GHC.Generics.M1 (GHC.Generics.Rec1 g2)))))
     GHC.Generics.to1 (GHC.Generics.M1 x)
-      = case x of {
-          GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1)
+      = case x of
+          (GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1))
             -> CanDoRep1_1.D0d
-          GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 g1)
-                                                               (GHC.Generics.M1 g2)))
+          (GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 g1)
+                                                                (GHC.Generics.M1 g2))))
             -> CanDoRep1_1.D1d
-                 (GHC.Generics.unPar1 g1) (GHC.Generics.unRec1 g2) }
+                 (GHC.Generics.unPar1 g1) (GHC.Generics.unRec1 g2)
   
   instance GHC.Generics.Generic (CanDoRep1_1.Dd a) where
     GHC.Generics.from x
       = GHC.Generics.M1
-          (case x of {
+          (case x of
              CanDoRep1_1.D0d
                -> GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1)
              CanDoRep1_1.D1d g1 g2
@@ -33,19 +33,19 @@ Derived class instances:
                     (GHC.Generics.M1
                        ((GHC.Generics.:*:)
                           (GHC.Generics.M1 (GHC.Generics.K1 g1))
-                          (GHC.Generics.M1 (GHC.Generics.K1 g2)))) })
+                          (GHC.Generics.M1 (GHC.Generics.K1 g2)))))
     GHC.Generics.to (GHC.Generics.M1 x)
-      = case x of {
-          GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1)
+      = case x of
+          (GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1))
             -> CanDoRep1_1.D0d
-          GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g1))
-                                                               (GHC.Generics.M1 (GHC.Generics.K1 g2))))
-            -> CanDoRep1_1.D1d g1 g2 }
+          (GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g1))
+                                                                (GHC.Generics.M1 (GHC.Generics.K1 g2)))))
+            -> CanDoRep1_1.D1d g1 g2
   
   instance GHC.Generics.Generic (CanDoRep1_1.Dc a) where
     GHC.Generics.from x
       = GHC.Generics.M1
-          (case x of {
+          (case x of
              CanDoRep1_1.D0c
                -> GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1)
              CanDoRep1_1.D1c g1 g2
@@ -53,19 +53,19 @@ Derived class instances:
                     (GHC.Generics.M1
                        ((GHC.Generics.:*:)
                           (GHC.Generics.M1 (GHC.Generics.K1 g1))
-                          (GHC.Generics.M1 (GHC.Generics.K1 g2)))) })
+                          (GHC.Generics.M1 (GHC.Generics.K1 g2)))))
     GHC.Generics.to (GHC.Generics.M1 x)
-      = case x of {
-          GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1)
+      = case x of
+          (GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1))
             -> CanDoRep1_1.D0c
-          GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g1))
-                                                               (GHC.Generics.M1 (GHC.Generics.K1 g2))))
-            -> CanDoRep1_1.D1c g1 g2 }
+          (GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g1))
+                                                                (GHC.Generics.M1 (GHC.Generics.K1 g2)))))
+            -> CanDoRep1_1.D1c g1 g2
   
   instance GHC.Generics.Generic1 CanDoRep1_1.Db where
     GHC.Generics.from1 x
       = GHC.Generics.M1
-          (case x of {
+          (case x of
              CanDoRep1_1.D0b
                -> GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1)
              CanDoRep1_1.D1b g1 g2
@@ -73,57 +73,58 @@ Derived class instances:
                     (GHC.Generics.M1
                        ((GHC.Generics.:*:)
                           (GHC.Generics.M1 (GHC.Generics.Par1 g1))
-                          (GHC.Generics.M1 (GHC.Generics.Rec1 g2)))) })
+                          (GHC.Generics.M1 (GHC.Generics.Rec1 g2)))))
     GHC.Generics.to1 (GHC.Generics.M1 x)
-      = case x of {
-          GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1)
+      = case x of
+          (GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1))
             -> CanDoRep1_1.D0b
-          GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 g1)
-                                                               (GHC.Generics.M1 g2)))
+          (GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 g1)
+                                                                (GHC.Generics.M1 g2))))
             -> CanDoRep1_1.D1b
-                 (GHC.Generics.unPar1 g1) (GHC.Generics.unRec1 g2) }
+                 (GHC.Generics.unPar1 g1) (GHC.Generics.unRec1 g2)
   
   instance GHC.Generics.Generic (CanDoRep1_1.Da a) where
     GHC.Generics.from x
       = GHC.Generics.M1
-          (case x of {
+          (case x of
              CanDoRep1_1.D0 -> GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1)
              CanDoRep1_1.D1 g1 g2
                -> GHC.Generics.R1
                     (GHC.Generics.M1
                        ((GHC.Generics.:*:)
                           (GHC.Generics.M1 (GHC.Generics.K1 g1))
-                          (GHC.Generics.M1 (GHC.Generics.K1 g2)))) })
+                          (GHC.Generics.M1 (GHC.Generics.K1 g2)))))
     GHC.Generics.to (GHC.Generics.M1 x)
-      = case x of {
-          GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1) -> CanDoRep1_1.D0
-          GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g1))
-                                                               (GHC.Generics.M1 (GHC.Generics.K1 g2))))
-            -> CanDoRep1_1.D1 g1 g2 }
+      = case x of
+          (GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1))
+            -> CanDoRep1_1.D0
+          (GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g1))
+                                                                (GHC.Generics.M1 (GHC.Generics.K1 g2)))))
+            -> CanDoRep1_1.D1 g1 g2
   
   instance GHC.Generics.Generic1 CanDoRep1_1.Da where
     GHC.Generics.from1 x
       = GHC.Generics.M1
-          (case x of {
+          (case x of
              CanDoRep1_1.D0 -> GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1)
              CanDoRep1_1.D1 g1 g2
                -> GHC.Generics.R1
                     (GHC.Generics.M1
                        ((GHC.Generics.:*:)
                           (GHC.Generics.M1 (GHC.Generics.Par1 g1))
-                          (GHC.Generics.M1 (GHC.Generics.Rec1 g2)))) })
+                          (GHC.Generics.M1 (GHC.Generics.Rec1 g2)))))
     GHC.Generics.to1 (GHC.Generics.M1 x)
-      = case x of {
-          GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1) -> CanDoRep1_1.D0
-          GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 g1)
-                                                               (GHC.Generics.M1 g2)))
-            -> CanDoRep1_1.D1
-                 (GHC.Generics.unPar1 g1) (GHC.Generics.unRec1 g2) }
+      = case x of
+          (GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1))
+            -> CanDoRep1_1.D0
+          (GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 g1)
+                                                                (GHC.Generics.M1 g2))))
+            -> CanDoRep1_1.D1 (GHC.Generics.unPar1 g1) (GHC.Generics.unRec1 g2)
   
   instance GHC.Generics.Generic (CanDoRep1_1.Db a) where
     GHC.Generics.from x
       = GHC.Generics.M1
-          (case x of {
+          (case x of
              CanDoRep1_1.D0b
                -> GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1)
              CanDoRep1_1.D1b g1 g2
@@ -131,19 +132,19 @@ Derived class instances:
                     (GHC.Generics.M1
                        ((GHC.Generics.:*:)
                           (GHC.Generics.M1 (GHC.Generics.K1 g1))
-                          (GHC.Generics.M1 (GHC.Generics.K1 g2)))) })
+                          (GHC.Generics.M1 (GHC.Generics.K1 g2)))))
     GHC.Generics.to (GHC.Generics.M1 x)
-      = case x of {
-          GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1)
+      = case x of
+          (GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1))
             -> CanDoRep1_1.D0b
-          GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g1))
-                                                               (GHC.Generics.M1 (GHC.Generics.K1 g2))))
-            -> CanDoRep1_1.D1b g1 g2 }
+          (GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g1))
+                                                                (GHC.Generics.M1 (GHC.Generics.K1 g2)))))
+            -> CanDoRep1_1.D1b g1 g2
   
   instance GHC.Generics.Generic1 CanDoRep1_1.Dc where
     GHC.Generics.from1 x
       = GHC.Generics.M1
-          (case x of {
+          (case x of
              CanDoRep1_1.D0c
                -> GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1)
              CanDoRep1_1.D1c g1 g2
@@ -151,15 +152,15 @@ Derived class instances:
                     (GHC.Generics.M1
                        ((GHC.Generics.:*:)
                           (GHC.Generics.M1 (GHC.Generics.Par1 g1))
-                          (GHC.Generics.M1 (GHC.Generics.Rec1 g2)))) })
+                          (GHC.Generics.M1 (GHC.Generics.Rec1 g2)))))
     GHC.Generics.to1 (GHC.Generics.M1 x)
-      = case x of {
-          GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1)
+      = case x of
+          (GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1))
             -> CanDoRep1_1.D0c
-          GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 g1)
-                                                               (GHC.Generics.M1 g2)))
+          (GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 g1)
+                                                                (GHC.Generics.M1 g2))))
             -> CanDoRep1_1.D1c
-                 (GHC.Generics.unPar1 g1) (GHC.Generics.unRec1 g2) }
+                 (GHC.Generics.unPar1 g1) (GHC.Generics.unRec1 g2)
   
 
 Derived type family instances:
index 9576346..d90c273 100644 (file)
@@ -33,7 +33,7 @@ Derived class instances:
              T10604_deriving.Proxy -> GHC.Generics.M1 GHC.Generics.U1 })
     GHC.Generics.to (GHC.Generics.M1 x)
       = case x of {
-          GHC.Generics.M1 GHC.Generics.U1 -> T10604_deriving.Proxy }
+          (GHC.Generics.M1 GHC.Generics.U1) -> T10604_deriving.Proxy }
   
   instance GHC.Generics.Generic1 k (T10604_deriving.Proxy k) where
     GHC.Generics.from1 x
@@ -42,7 +42,7 @@ Derived class instances:
              T10604_deriving.Proxy -> GHC.Generics.M1 GHC.Generics.U1 })
     GHC.Generics.to1 (GHC.Generics.M1 x)
       = case x of {
-          GHC.Generics.M1 GHC.Generics.U1 -> T10604_deriving.Proxy }
+          (GHC.Generics.M1 GHC.Generics.U1) -> T10604_deriving.Proxy }
   
   instance GHC.Generics.Generic (T10604_deriving.Wrap a) where
     GHC.Generics.from x
@@ -52,7 +52,7 @@ Derived class instances:
                -> GHC.Generics.M1 (GHC.Generics.M1 (GHC.Generics.K1 g1)) })
     GHC.Generics.to (GHC.Generics.M1 x)
       = case x of {
-          GHC.Generics.M1 (GHC.Generics.M1 (GHC.Generics.K1 g1))
+          (GHC.Generics.M1 (GHC.Generics.M1 (GHC.Generics.K1 g1)))
             -> T10604_deriving.Wrap g1 }
   
   instance GHC.Generics.Generic1
@@ -64,7 +64,7 @@ Derived class instances:
                -> GHC.Generics.M1 (GHC.Generics.M1 (GHC.Generics.Rec1 g1)) })
     GHC.Generics.to1 (GHC.Generics.M1 x)
       = case x of {
-          GHC.Generics.M1 (GHC.Generics.M1 g1)
+          (GHC.Generics.M1 (GHC.Generics.M1 g1))
             -> T10604_deriving.Wrap (GHC.Generics.unRec1 g1) }
   
   instance forall k (a :: k -> GHC.Types.*).
@@ -76,7 +76,7 @@ Derived class instances:
                -> GHC.Generics.M1 (GHC.Generics.M1 (GHC.Generics.K1 g1)) })
     GHC.Generics.to (GHC.Generics.M1 x)
       = case x of {
-          GHC.Generics.M1 (GHC.Generics.M1 (GHC.Generics.K1 g1))
+          (GHC.Generics.M1 (GHC.Generics.M1 (GHC.Generics.K1 g1)))
             -> T10604_deriving.Wrap2 g1 }
   
   instance GHC.Generics.Generic1
@@ -91,7 +91,7 @@ Derived class instances:
                           GHC.Generics.Comp1 (GHC.Base.fmap GHC.Generics.Rec1) g1)) })
     GHC.Generics.to1 (GHC.Generics.M1 x)
       = case x of {
-          GHC.Generics.M1 (GHC.Generics.M1 g1)
+          (GHC.Generics.M1 (GHC.Generics.M1 g1))
             -> T10604_deriving.Wrap2
                  ((GHC.Base..)
                     (GHC.Base.fmap GHC.Generics.unRec1) GHC.Generics.unComp1 g1) }
@@ -100,7 +100,7 @@ Derived class instances:
            GHC.Generics.Generic (T10604_deriving.SumOfProducts k a) where
     GHC.Generics.from x
       = GHC.Generics.M1
-          (case x of {
+          (case x of
              T10604_deriving.Prod1 g1 g2
                -> GHC.Generics.L1
                     (GHC.Generics.M1
@@ -112,21 +112,21 @@ Derived class instances:
                     (GHC.Generics.M1
                        ((GHC.Generics.:*:)
                           (GHC.Generics.M1 (GHC.Generics.K1 g1))
-                          (GHC.Generics.M1 (GHC.Generics.K1 g2)))) })
+                          (GHC.Generics.M1 (GHC.Generics.K1 g2)))))
     GHC.Generics.to (GHC.Generics.M1 x)
-      = case x of {
-          GHC.Generics.L1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g1))
-                                                               (GHC.Generics.M1 (GHC.Generics.K1 g2))))
+      = case x of
+          (GHC.Generics.L1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g1))
+                                                                (GHC.Generics.M1 (GHC.Generics.K1 g2)))))
             -> T10604_deriving.Prod1 g1 g2
-          GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g1))
-                                                               (GHC.Generics.M1 (GHC.Generics.K1 g2))))
-            -> T10604_deriving.Prod2 g1 g2 }
+          (GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g1))
+                                                                (GHC.Generics.M1 (GHC.Generics.K1 g2)))))
+            -> T10604_deriving.Prod2 g1 g2
   
   instance GHC.Generics.Generic1
              k (T10604_deriving.SumOfProducts k) where
     GHC.Generics.from1 x
       = GHC.Generics.M1
-          (case x of {
+          (case x of
              T10604_deriving.Prod1 g1 g2
                -> GHC.Generics.L1
                     (GHC.Generics.M1
@@ -138,51 +138,51 @@ Derived class instances:
                     (GHC.Generics.M1
                        ((GHC.Generics.:*:)
                           (GHC.Generics.M1 (GHC.Generics.Rec1 g1))
-                          (GHC.Generics.M1 (GHC.Generics.Rec1 g2)))) })
+                          (GHC.Generics.M1 (GHC.Generics.Rec1 g2)))))
     GHC.Generics.to1 (GHC.Generics.M1 x)
-      = case x of {
-          GHC.Generics.L1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 g1)
-                                                               (GHC.Generics.M1 g2)))
+      = case x of
+          (GHC.Generics.L1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 g1)
+                                                                (GHC.Generics.M1 g2))))
             -> T10604_deriving.Prod1
                  (GHC.Generics.unRec1 g1) (GHC.Generics.unRec1 g2)
-          GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 g1)
-                                                               (GHC.Generics.M1 g2)))
+          (GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 g1)
+                                                                (GHC.Generics.M1 g2))))
             -> T10604_deriving.Prod2
-                 (GHC.Generics.unRec1 g1) (GHC.Generics.unRec1 g2) }
+                 (GHC.Generics.unRec1 g1) (GHC.Generics.unRec1 g2)
   
   instance GHC.Generics.Generic (T10604_deriving.Starify a) where
     GHC.Generics.from x
       = GHC.Generics.M1
-          (case x of {
+          (case x of
              T10604_deriving.Starify1 g1
                -> GHC.Generics.L1
                     (GHC.Generics.M1 (GHC.Generics.M1 (GHC.Generics.K1 g1)))
              T10604_deriving.Starify2 g1
                -> GHC.Generics.R1
-                    (GHC.Generics.M1 (GHC.Generics.M1 (GHC.Generics.K1 g1))) })
+                    (GHC.Generics.M1 (GHC.Generics.M1 (GHC.Generics.K1 g1))))
     GHC.Generics.to (GHC.Generics.M1 x)
-      = case x of {
-          GHC.Generics.L1 (GHC.Generics.M1 (GHC.Generics.M1 (GHC.Generics.K1 g1)))
+      = case x&nbs