summaryrefslogtreecommitdiff
path: root/compiler/hsSyn
diff options
context:
space:
mode:
authorAlan Zimmerman <alan.zimm@gmail.com>2016-11-08 21:37:48 +0200
committerAlan Zimmerman <alan.zimm@gmail.com>2016-12-07 21:31:13 +0200
commit499e43824bda967546ebf95ee33ec1f84a114a7c (patch)
tree58b313d734cfba014395ea5876db48e8400296a8 /compiler/hsSyn
parent83d69dca896c7df1f2a36268d5b45c9283985ebf (diff)
downloadhaskell-499e43824bda967546ebf95ee33ec1f84a114a7c.tar.gz
Add HsSyn prettyprinter tests
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
Diffstat (limited to 'compiler/hsSyn')
-rw-r--r--compiler/hsSyn/Convert.hs126
-rw-r--r--compiler/hsSyn/HsBinds.hs75
-rw-r--r--compiler/hsSyn/HsDecls.hs212
-rw-r--r--compiler/hsSyn/HsExpr.hs252
-rw-r--r--compiler/hsSyn/HsExpr.hs-boot24
-rw-r--r--compiler/hsSyn/HsImpExp.hs25
-rw-r--r--compiler/hsSyn/HsLit.hs43
-rw-r--r--compiler/hsSyn/HsPat.hs25
-rw-r--r--compiler/hsSyn/HsPat.hs-boot4
-rw-r--r--compiler/hsSyn/HsSyn.hs3
-rw-r--r--compiler/hsSyn/HsTypes.hs130
-rw-r--r--compiler/hsSyn/HsUtils.hs43
-rw-r--r--compiler/hsSyn/PlaceHolder.hs7
13 files changed, 609 insertions, 360 deletions
diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs
index 6bb71991d4..2c863c75ca 100644
--- a/compiler/hsSyn/Convert.hs
+++ b/compiler/hsSyn/Convert.hs
@@ -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
diff --git a/compiler/hsSyn/HsBinds.hs b/compiler/hsSyn/HsBinds.hs
index 487859249f..eeb446e838 100644
--- a/compiler/hsSyn/HsBinds.hs
+++ b/compiler/hsSyn/HsBinds.hs
@@ -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)
{-
diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs
index 0d6bbf62cc..c82cd8b0f2 100644
--- a/compiler/hsSyn/HsDecls.hs
+++ b/compiler/hsSyn/HsDecls.hs
@@ -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 "#-}"]
diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs
index df60084a50..78ee4e05a0 100644
--- a/compiler/hsSyn/HsExpr.hs
+++ b/compiler/hsSyn/HsExpr.hs
@@ -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"
diff --git a/compiler/hsSyn/HsExpr.hs-boot b/compiler/hsSyn/HsExpr.hs-boot
index 022ca6bbc4..070465e1cc 100644
--- a/compiler/hsSyn/HsExpr.hs-boot
+++ b/compiler/hsSyn/HsExpr.hs-boot
@@ -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
diff --git a/compiler/hsSyn/HsImpExp.hs b/compiler/hsSyn/HsImpExp.hs
index 011a80af22..8641f1ff3f 100644
--- a/compiler/hsSyn/HsImpExp.hs
+++ b/compiler/hsSyn/HsImpExp.hs
@@ -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)
diff --git a/compiler/hsSyn/HsLit.hs b/compiler/hsSyn/HsLit.hs
index 4cf571917c..e513fe9e00 100644
--- a/compiler/hsSyn/HsLit.hs
+++ b/compiler/hsSyn/HsLit.hs
@@ -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
diff --git a/compiler/hsSyn/HsPat.hs b/compiler/hsSyn/HsPat.hs
index ec5578f36d..853e8cb70d 100644
--- a/compiler/hsSyn/HsPat.hs
+++ b/compiler/hsSyn/HsPat.hs
@@ -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
diff --git a/compiler/hsSyn/HsPat.hs-boot b/compiler/hsSyn/HsPat.hs-boot
index aba5686085..8bcaa5a1e0 100644
--- a/compiler/hsSyn/HsPat.hs-boot
+++ b/compiler/hsSyn/HsPat.hs-boot
@@ -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)
diff --git a/compiler/hsSyn/HsSyn.hs b/compiler/hsSyn/HsSyn.hs
index 1e5a4bb273..93e43546a9 100644
--- a/compiler/hsSyn/HsSyn.hs
+++ b/compiler/hsSyn/HsSyn.hs
@@ -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)
diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs
index 6d82f92474..e3e5246f4b 100644
--- a/compiler/hsSyn/HsTypes.hs
+++ b/compiler/hsSyn/HsTypes.hs
@@ -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
--------------------------
diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs
index f1500bb9a0..b49cd98f25 100644
--- a/compiler/hsSyn/HsUtils.hs
+++ b/compiler/hsSyn/HsUtils.hs
@@ -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
diff --git a/compiler/hsSyn/PlaceHolder.hs b/compiler/hsSyn/PlaceHolder.hs
index 2e195df799..c29e8f9cb4 100644
--- a/compiler/hsSyn/PlaceHolder.hs
+++ b/compiler/hsSyn/PlaceHolder.hs
@@ -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)
+ )
View Lorry Controller Status