summaryrefslogtreecommitdiff
path: root/compiler/hsSyn
diff options
context:
space:
mode:
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