summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/GHC/Driver/Errors/Ppr.hs2
-rw-r--r--compiler/GHC/Hs/Decls.hs125
-rw-r--r--compiler/GHC/Hs/Instances.hs10
-rw-r--r--compiler/GHC/HsToCore.hs2
-rw-r--r--compiler/GHC/HsToCore/Foreign/Decl.hs8
-rw-r--r--compiler/GHC/HsToCore/Quote.hs8
-rw-r--r--compiler/GHC/Iface/Ext/Ast.hs14
-rw-r--r--compiler/GHC/Parser.y22
-rw-r--r--compiler/GHC/Parser/PostProcess.hs11
-rw-r--r--compiler/GHC/Rename/Module.hs26
-rw-r--r--compiler/GHC/Tc/Errors/Types.hs12
-rw-r--r--compiler/GHC/Tc/Gen/Annotation.hs2
-rw-r--r--compiler/GHC/Tc/Gen/Foreign.hs34
-rw-r--r--compiler/GHC/Tc/Gen/Rule.hs13
-rw-r--r--compiler/GHC/ThToHs.hs21
-rw-r--r--compiler/Language/Haskell/Syntax/Binds.hs2
-rw-r--r--compiler/Language/Haskell/Syntax/Decls.hs136
-rw-r--r--compiler/Language/Haskell/Syntax/Extension.hs4
18 files changed, 236 insertions, 216 deletions
diff --git a/compiler/GHC/Driver/Errors/Ppr.hs b/compiler/GHC/Driver/Errors/Ppr.hs
index 8fe416196b..ad49f81bcb 100644
--- a/compiler/GHC/Driver/Errors/Ppr.hs
+++ b/compiler/GHC/Driver/Errors/Ppr.hs
@@ -147,7 +147,7 @@ instance Diagnostic DriverMessage where
-> mkSimpleDecorated (text "module" <+> ppr modname <+> text "was not found")
DriverUserDefinedRuleIgnored (HsRule { rd_name = n })
-> mkSimpleDecorated $
- text "Rule \"" <> ftext (snd $ unLoc n) <> text "\" ignored" $+$
+ text "Rule \"" <> ftext (unLoc n) <> text "\" ignored" $+$
text "Defining user rules is disabled under Safe Haskell"
DriverMixedSafetyImport modName
-> mkSimpleDecorated $
diff --git a/compiler/GHC/Hs/Decls.hs b/compiler/GHC/Hs/Decls.hs
index d2b1b6a117..accc349a11 100644
--- a/compiler/GHC/Hs/Decls.hs
+++ b/compiler/GHC/Hs/Decls.hs
@@ -187,6 +187,10 @@ partitionBindsAndSigs = go
-> (bs, ss, ts, tfis, dfis, L l d : docs)
_ -> pprPanic "partitionBindsAndSigs" (ppr decl)
+-- Okay, I need to reconstruct the document comments, but for now:
+instance Outputable (DocDecl name) where
+ ppr _ = text "<document comment>"
+
type instance XCHsGroup (GhcPass _) = NoExtField
type instance XXHsGroup (GhcPass _) = DataConCantHappen
@@ -316,6 +320,11 @@ instance OutputableBndrId p
ppr (SpliceDecl _ (L _ e) DollarSplice) = pprUntypedSplice True Nothing e
ppr (SpliceDecl _ (L _ e) BareSplice) = pprUntypedSplice False Nothing e
+instance Outputable SpliceDecoration where
+ ppr x = text $ show x
+
+
+
{-
************************************************************************
* *
@@ -344,6 +353,17 @@ type instance XXTyClDecl (GhcPass _) = DataConCantHappen
type instance XCTyFamInstDecl (GhcPass _) = EpAnn [AddEpAnn]
type instance XXTyFamInstDecl (GhcPass _) = DataConCantHappen
+------------- Pretty printing FamilyDecls -----------
+
+pprFlavour :: FamilyInfo pass -> SDoc
+pprFlavour DataFamily = text "data"
+pprFlavour OpenTypeFamily = text "type"
+pprFlavour (ClosedTypeFamily {}) = text "type"
+
+instance Outputable (FamilyInfo pass) where
+ ppr info = pprFlavour info <+> text "family"
+
+
-- Dealing with names
tyFamInstDeclName :: Anno (IdGhcP p) ~ SrcSpanAnnN
@@ -591,6 +611,15 @@ instance OutputableBndrId p
Just (L _ via@ViaStrategy{}) -> (empty, ppr via)
_ -> (ppDerivStrategy dcs, empty)
+-- | A short description of a @DerivStrategy'@.
+derivStrategyName :: DerivStrategy a -> SDoc
+derivStrategyName = text . go
+ where
+ go StockStrategy {} = "stock"
+ go AnyclassStrategy {} = "anyclass"
+ go NewtypeStrategy {} = "newtype"
+ go ViaStrategy {} = "via"
+
type instance XDctSingle (GhcPass _) = NoExtField
type instance XDctMulti (GhcPass _) = NoExtField
type instance XXDerivClauseTys (GhcPass _) = DataConCantHappen
@@ -871,6 +900,11 @@ instDeclDataFamInsts inst_decls
do_one (L _ (DataFamInstD { dfid_inst = fam_inst })) = [fam_inst]
do_one (L _ (TyFamInstD {})) = []
+
+instance Outputable NewOrData where
+ ppr NewType = text "newtype"
+ ppr DataType = text "data"
+
{-
************************************************************************
* *
@@ -987,6 +1021,14 @@ type instance XForeignExport GhcTc = Coercion
type instance XXForeignDecl (GhcPass _) = DataConCantHappen
+type instance XCImport (GhcPass _) = Located SourceText -- original source text for the C entity
+type instance XXForeignImport (GhcPass _) = DataConCantHappen
+
+type instance XCExport (GhcPass _) = Located SourceText -- original source text for the C entity
+type instance XXForeignExport (GhcPass _) = DataConCantHappen
+
+-- pretty printing of foreign declarations
+
instance OutputableBndrId p
=> Outputable (ForeignDecl (GhcPass p)) where
ppr (ForeignImport { fd_name = n, fd_sig_ty = ty, fd_fi = fimport })
@@ -996,6 +1038,40 @@ instance OutputableBndrId p
hang (text "foreign export" <+> ppr fexport <+> ppr n)
2 (dcolon <+> ppr ty)
+instance OutputableBndrId p
+ => Outputable (ForeignImport (GhcPass p)) where
+ ppr (CImport (L _ srcText) cconv safety mHeader spec) =
+ ppr cconv <+> ppr safety
+ <+> pprWithSourceText srcText (pprCEntity spec "")
+ where
+ pp_hdr = case mHeader of
+ Nothing -> empty
+ Just (Header _ header) -> ftext header
+
+ 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 OutputableBndrId p
+ => Outputable (ForeignExport (GhcPass p)) where
+ ppr (CExport _ (L _ (CExportStatic _ lbl cconv))) =
+ ppr cconv <+> char '"' <> ppr lbl <> char '"'
+
{-
************************************************************************
* *
@@ -1004,15 +1080,15 @@ instance OutputableBndrId p
************************************************************************
-}
-type instance XCRuleDecls GhcPs = EpAnn [AddEpAnn]
-type instance XCRuleDecls GhcRn = NoExtField
-type instance XCRuleDecls GhcTc = NoExtField
+type instance XCRuleDecls GhcPs = (EpAnn [AddEpAnn], SourceText)
+type instance XCRuleDecls GhcRn = SourceText
+type instance XCRuleDecls GhcTc = SourceText
type instance XXRuleDecls (GhcPass _) = DataConCantHappen
-type instance XHsRule GhcPs = EpAnn HsRuleAnn
-type instance XHsRule GhcRn = HsRuleRn
-type instance XHsRule GhcTc = HsRuleRn
+type instance XHsRule GhcPs = (EpAnn HsRuleAnn, SourceText)
+type instance XHsRule GhcRn = (HsRuleRn, SourceText)
+type instance XHsRule GhcTc = (HsRuleRn, SourceText)
type instance XXRuleDecl (GhcPass _) = DataConCantHappen
@@ -1037,19 +1113,24 @@ type instance XRuleBndrSig (GhcPass _) = EpAnn [AddEpAnn]
type instance XXRuleBndr (GhcPass _) = DataConCantHappen
instance (OutputableBndrId p) => Outputable (RuleDecls (GhcPass p)) where
- ppr (HsRules { rds_src = st
+ ppr (HsRules { rds_ext = ext
, rds_rules = rules })
= pprWithSourceText st (text "{-# RULES")
<+> vcat (punctuate semi (map ppr rules)) <+> text "#-}"
+ where st = case ghcPass @p of
+ GhcPs | (_, st) <- ext -> st
+ GhcRn -> ext
+ GhcTc -> ext
instance (OutputableBndrId p) => Outputable (RuleDecl (GhcPass p)) where
- ppr (HsRule { rd_name = name
+ ppr (HsRule { rd_ext = ext
+ , rd_name = name
, rd_act = act
, rd_tyvs = tys
, rd_tmvs = tms
, rd_lhs = lhs
, rd_rhs = rhs })
- = sep [pprFullRuleName name <+> ppr act,
+ = sep [pprFullRuleName st name <+> ppr act,
nest 4 (pp_forall_ty tys <+> pp_forall_tm tys
<+> pprExpr (unLoc lhs)),
nest 6 (equals <+> pprExpr (unLoc rhs)) ]
@@ -1058,11 +1139,19 @@ instance (OutputableBndrId p) => Outputable (RuleDecl (GhcPass p)) where
pp_forall_ty (Just qtvs) = forAllLit <+> fsep (map ppr qtvs) <> dot
pp_forall_tm Nothing | null tms = empty
pp_forall_tm _ = forAllLit <+> fsep (map ppr tms) <> dot
+ st = case ghcPass @p of
+ GhcPs | (_, st) <- ext -> st
+ GhcRn | (_, st) <- ext -> st
+ GhcTc | (_, st) <- ext -> st
instance (OutputableBndrId p) => Outputable (RuleBndr (GhcPass p)) where
ppr (RuleBndr _ name) = ppr name
ppr (RuleBndrSig _ name ty) = parens (ppr name <> dcolon <> ppr ty)
+pprFullRuleName :: SourceText -> GenLocated a (RuleName) -> SDoc
+pprFullRuleName st (L _ n) = pprWithSourceText st (doubleQuotes $ ftext n)
+
+
{-
************************************************************************
* *
@@ -1071,9 +1160,9 @@ instance (OutputableBndrId p) => Outputable (RuleBndr (GhcPass p)) where
************************************************************************
-}
-type instance XWarnings GhcPs = EpAnn [AddEpAnn]
-type instance XWarnings GhcRn = NoExtField
-type instance XWarnings GhcTc = NoExtField
+type instance XWarnings GhcPs = (EpAnn [AddEpAnn], SourceText)
+type instance XWarnings GhcRn = SourceText
+type instance XWarnings GhcTc = SourceText
type instance XXWarnDecls (GhcPass _) = DataConCantHappen
@@ -1083,9 +1172,13 @@ type instance XXWarnDecl (GhcPass _) = DataConCantHappen
instance OutputableBndrId p
=> Outputable (WarnDecls (GhcPass p)) where
- ppr (Warnings _ (SourceText src) decls)
+ ppr (Warnings ext decls)
= text src <+> vcat (punctuate comma (map ppr decls)) <+> text "#-}"
- ppr (Warnings _ NoSourceText _decls) = panic "WarnDecls"
+ where src = case ghcPass @p of
+ GhcPs | (_, SourceText src) <- ext -> src
+ GhcRn | SourceText src <- ext -> src
+ GhcTc | SourceText src <- ext -> src
+ _ -> panic "WarnDecls"
instance OutputableBndrId p
=> Outputable (WarnDecl (GhcPass p)) where
@@ -1101,11 +1194,11 @@ instance OutputableBndrId p
************************************************************************
-}
-type instance XHsAnnotation (GhcPass _) = EpAnn AnnPragma
+type instance XHsAnnotation (GhcPass _) = (EpAnn AnnPragma, SourceText)
type instance XXAnnDecl (GhcPass _) = DataConCantHappen
instance (OutputableBndrId p) => Outputable (AnnDecl (GhcPass p)) where
- ppr (HsAnnotation _ _ provenance expr)
+ ppr (HsAnnotation _ provenance expr)
= hsep [text "{-#", pprAnnProvenance provenance, pprExpr (unLoc expr), text "#-}"]
pprAnnProvenance :: OutputableBndrId p => AnnProvenance (GhcPass p) -> SDoc
diff --git a/compiler/GHC/Hs/Instances.hs b/compiler/GHC/Hs/Instances.hs
index 0a723cee11..ef849a17bb 100644
--- a/compiler/GHC/Hs/Instances.hs
+++ b/compiler/GHC/Hs/Instances.hs
@@ -231,6 +231,16 @@ deriving instance Data (ForeignDecl GhcPs)
deriving instance Data (ForeignDecl GhcRn)
deriving instance Data (ForeignDecl GhcTc)
+-- deriving instance (DataIdLR p p) => Data (ForeignImport p)
+deriving instance Data (ForeignImport GhcPs)
+deriving instance Data (ForeignImport GhcRn)
+deriving instance Data (ForeignImport GhcTc)
+
+-- deriving instance (DataIdLR p p) => Data (ForeignExport p)
+deriving instance Data (ForeignExport GhcPs)
+deriving instance Data (ForeignExport GhcRn)
+deriving instance Data (ForeignExport GhcTc)
+
-- deriving instance (DataIdLR p p) => Data (RuleDecls p)
deriving instance Data (RuleDecls GhcPs)
deriving instance Data (RuleDecls GhcRn)
diff --git a/compiler/GHC/HsToCore.hs b/compiler/GHC/HsToCore.hs
index 7a21bcb391..0f8ce9fd5b 100644
--- a/compiler/GHC/HsToCore.hs
+++ b/compiler/GHC/HsToCore.hs
@@ -474,7 +474,7 @@ dsRule (L loc (HsRule { rd_name = name
fn_name = idName fn_id
simpl_opts = initSimpleOpts dflags
final_rhs = simpleOptExpr simpl_opts rhs'' -- De-crap it
- rule_name = snd (unLoc name)
+ rule_name = unLoc name
final_bndrs_set = mkVarSet final_bndrs
arg_ids = filterOut (`elemVarSet` final_bndrs_set) $
exprsSomeFreeVarsList isId args
diff --git a/compiler/GHC/HsToCore/Foreign/Decl.hs b/compiler/GHC/HsToCore/Foreign/Decl.hs
index 29bfb689e8..60212b0d23 100644
--- a/compiler/GHC/HsToCore/Foreign/Decl.hs
+++ b/compiler/GHC/HsToCore/Foreign/Decl.hs
@@ -93,8 +93,8 @@ dsForeigns' fos = do
do_decl (ForeignExport { fd_name = L _ id
, fd_e_ext = co
- , fd_fe = CExport
- (L _ (CExportStatic _ ext_nm cconv)) _ }) = do
+ , fd_fe = CExport _
+ (L _ (CExportStatic _ ext_nm cconv)) }) = do
(h, c, _, _) <- dsFExport id co ext_nm cconv False
return (h, c, [id], [])
@@ -126,9 +126,9 @@ because it exposes the boxing to the call site.
dsFImport :: Id
-> Coercion
- -> ForeignImport
+ -> ForeignImport (GhcPass p)
-> DsM ([Binding], CHeader, CStub)
-dsFImport id co (CImport cconv safety mHeader spec _) =
+dsFImport id co (CImport _ cconv safety mHeader spec) =
dsCImport id co spec (unLoc cconv) (unLoc safety) mHeader
{-
diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs
index 57292e47f2..5ba188cbd8 100644
--- a/compiler/GHC/HsToCore/Quote.hs
+++ b/compiler/GHC/HsToCore/Quote.hs
@@ -735,8 +735,8 @@ repDataFamInstD (DataFamInstDecl { dfid_eqn =
repForD :: LForeignDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
repForD (L loc (ForeignImport { fd_name = name, fd_sig_ty = typ
- , fd_fi = CImport (L _ cc)
- (L _ s) mch cis _ }))
+ , fd_fi = CImport _ (L _ cc)
+ (L _ s) mch cis }))
= do MkC name' <- lookupLOcc name
MkC typ' <- repHsSigType typ
MkC cc' <- repCCallConv cc
@@ -816,7 +816,7 @@ repRuleD (L loc (HsRule { rd_name = n
; tm_bndrs' <- repListM ruleBndrTyConName
repRuleBndr
tm_bndrs
- ; n' <- coreStringLit $ unpackFS $ snd $ unLoc n
+ ; n' <- coreStringLit $ unpackFS $ unLoc n
; act' <- repPhases act
; lhs' <- repLE lhs
; rhs' <- repLE rhs
@@ -840,7 +840,7 @@ repRuleBndr (L _ (RuleBndrSig _ n sig))
; rep2 typedRuleVarName [n', ty'] }
repAnnD :: LAnnDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
-repAnnD (L loc (HsAnnotation _ _ ann_prov (L _ exp)))
+repAnnD (L loc (HsAnnotation _ ann_prov (L _ exp)))
= do { target <- repAnnProv ann_prov
; exp' <- repE exp
; dec <- repPragAnn target exp'
diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs
index 553f872c29..43cd29bc1c 100644
--- a/compiler/GHC/Iface/Ext/Ast.hs
+++ b/compiler/GHC/Iface/Ext/Ast.hs
@@ -1999,22 +1999,22 @@ instance ToHie (LocatedA (ForeignDecl GhcRn)) where
, toHie fe
]
-instance ToHie ForeignImport where
- toHie (CImport (L a _) (L b _) _ _ (L c _)) = concatM $
+instance ToHie (ForeignImport GhcRn) where
+ toHie (CImport (L c _) (L a _) (L b _) _ _) = concatM $
[ locOnly a
, locOnly b
, locOnly c
]
-instance ToHie ForeignExport where
- toHie (CExport (L a _) (L b _)) = concatM $
+instance ToHie (ForeignExport GhcRn) where
+ toHie (CExport (L b _) (L a _)) = concatM $
[ locOnly a
, locOnly b
]
instance ToHie (LocatedA (WarnDecls GhcRn)) where
toHie (L span decl) = concatM $ makeNodeA decl span : case decl of
- Warnings _ _ warnings ->
+ Warnings _ warnings ->
[ toHie warnings
]
@@ -2026,7 +2026,7 @@ instance ToHie (LocatedA (WarnDecl GhcRn)) where
instance ToHie (LocatedA (AnnDecl GhcRn)) where
toHie (L span decl) = concatM $ makeNodeA decl span : case decl of
- HsAnnotation _ _ prov expr ->
+ HsAnnotation _ prov expr ->
[ toHie prov
, toHie expr
]
@@ -2038,7 +2038,7 @@ instance ToHie (AnnProvenance GhcRn) where
instance ToHie (LocatedA (RuleDecls GhcRn)) where
toHie (L span decl) = concatM $ makeNodeA decl span : case decl of
- HsRules _ _ rules ->
+ HsRules _ rules ->
[ toHie rules
]
diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y
index 2731c6abd2..f0a7d69251 100644
--- a/compiler/GHC/Parser.y
+++ b/compiler/GHC/Parser.y
@@ -1222,9 +1222,9 @@ topdecl :: { LHsDecl GhcPs }
| 'default' '(' comma_types0 ')' {% acsA (\cs -> sLL $1 $>
(DefD noExtField (DefaultDecl (EpAnn (glR $1) [mj AnnDefault $1,mop $2,mcp $4] cs) $3))) }
| 'foreign' fdecl {% acsA (\cs -> sLL $1 $> ((snd $ unLoc $2) (EpAnn (glR $1) (mj AnnForeign $1:(fst $ unLoc $2)) cs))) }
- | '{-# DEPRECATED' deprecations '#-}' {% acsA (\cs -> sLL $1 $> $ WarningD noExtField (Warnings (EpAnn (glR $1) [mo $1,mc $3] cs) (getDEPRECATED_PRAGs $1) (fromOL $2))) }
- | '{-# WARNING' warnings '#-}' {% acsA (\cs -> sLL $1 $> $ WarningD noExtField (Warnings (EpAnn (glR $1) [mo $1,mc $3] cs) (getWARNING_PRAGs $1) (fromOL $2))) }
- | '{-# RULES' rules '#-}' {% acsA (\cs -> sLL $1 $> $ RuleD noExtField (HsRules (EpAnn (glR $1) [mo $1,mc $3] cs) (getRULES_PRAGs $1) (reverse $2))) }
+ | '{-# DEPRECATED' deprecations '#-}' {% acsA (\cs -> sLL $1 $> $ WarningD noExtField (Warnings ((EpAnn (glR $1) [mo $1,mc $3] cs), (getDEPRECATED_PRAGs $1)) (fromOL $2))) }
+ | '{-# WARNING' warnings '#-}' {% acsA (\cs -> sLL $1 $> $ WarningD noExtField (Warnings ((EpAnn (glR $1) [mo $1,mc $3] cs), (getWARNING_PRAGs $1)) (fromOL $2))) }
+ | '{-# RULES' rules '#-}' {% acsA (\cs -> sLL $1 $> $ RuleD noExtField (HsRules ((EpAnn (glR $1) [mo $1,mc $3] cs), (getRULES_PRAGs $1)) (reverse $2))) }
| annotation { $1 }
| decl_no_th { $1 }
@@ -1840,8 +1840,8 @@ rule :: { LRuleDecl GhcPs }
{%runPV (unECP $4) >>= \ $4 ->
runPV (unECP $6) >>= \ $6 ->
acsA (\cs -> (sLLlA $1 $> $ HsRule
- { rd_ext = EpAnn (glR $1) ((fstOf3 $3) (mj AnnEqual $5 : (fst $2))) cs
- , rd_name = L (noAnnSrcSpan $ gl $1) (getSTRINGs $1, getSTRING $1)
+ { rd_ext = (EpAnn (glR $1) ((fstOf3 $3) (mj AnnEqual $5 : (fst $2))) cs, getSTRINGs $1)
+ , rd_name = L (noAnnSrcSpan $ gl $1) (getSTRING $1)
, rd_act = (snd $2) `orElse` AlwaysActive
, rd_tyvs = sndOf3 $3, rd_tmvs = thdOf3 $3
, rd_lhs = $4, rd_rhs = $6 })) }
@@ -1998,20 +1998,20 @@ stringlist :: { Located (OrdList (Located StringLiteral)) }
annotation :: { LHsDecl GhcPs }
: '{-# ANN' name_var aexp '#-}' {% runPV (unECP $3) >>= \ $3 ->
acsA (\cs -> sLL $1 $> (AnnD noExtField $ HsAnnotation
- (EpAnn (glR $1) (AnnPragma (mo $1) (mc $4) []) cs)
- (getANN_PRAGs $1)
+ ((EpAnn (glR $1) (AnnPragma (mo $1) (mc $4) []) cs),
+ (getANN_PRAGs $1))
(ValueAnnProvenance $2) $3)) }
| '{-# ANN' 'type' otycon aexp '#-}' {% runPV (unECP $4) >>= \ $4 ->
acsA (\cs -> sLL $1 $> (AnnD noExtField $ HsAnnotation
- (EpAnn (glR $1) (AnnPragma (mo $1) (mc $5) [mj AnnType $2]) cs)
- (getANN_PRAGs $1)
+ ((EpAnn (glR $1) (AnnPragma (mo $1) (mc $5) [mj AnnType $2]) cs),
+ (getANN_PRAGs $1))
(TypeAnnProvenance $3) $4)) }
| '{-# ANN' 'module' aexp '#-}' {% runPV (unECP $3) >>= \ $3 ->
acsA (\cs -> sLL $1 $> (AnnD noExtField $ HsAnnotation
- (EpAnn (glR $1) (AnnPragma (mo $1) (mc $4) [mj AnnModule $2]) cs)
- (getANN_PRAGs $1)
+ ((EpAnn (glR $1) (AnnPragma (mo $1) (mc $4) [mj AnnModule $2]) cs),
+ (getANN_PRAGs $1))
ModuleAnnProvenance $3)) }
-----------------------------------------------------------------------------
diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs
index 486517ea2b..97768931e9 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -2650,7 +2650,7 @@ mkImport cconv safety (L loc (StringLiteral esrc entity _), v, ty) =
PsErrMalformedEntityString
Just importSpec -> return importSpec
- isCWrapperImport (CImport _ _ _ CWrapper _) = True
+ isCWrapperImport (CImport _ _ _ _ CWrapper) = True
isCWrapperImport _ = False
-- currently, all the other import conventions only support a symbol name in
@@ -2661,7 +2661,7 @@ mkImport cconv safety (L loc (StringLiteral esrc entity _), v, ty) =
then mkExtName (unLoc v)
else entity
funcTarget = CFunction (StaticTarget esrc entity' Nothing True)
- importSpec = CImport cconv safety Nothing funcTarget (L loc esrc)
+ importSpec = CImport (L loc esrc) cconv safety Nothing funcTarget
returnSpec spec = return $ \ann -> ForD noExtField $ ForeignImport
{ fd_i_ext = ann
@@ -2677,7 +2677,7 @@ mkImport cconv safety (L loc (StringLiteral esrc entity _), v, ty) =
-- that one.
parseCImport :: Located CCallConv -> Located Safety -> FastString -> String
-> Located SourceText
- -> Maybe ForeignImport
+ -> Maybe (ForeignImport (GhcPass p))
parseCImport cconv safety nm str sourceText =
listToMaybe $ map fst $ filter (null.snd) $
readP_to_S parse str
@@ -2704,7 +2704,7 @@ parseCImport cconv safety nm str sourceText =
| id_char c -> pfail
_ -> return ()
- mk h n = CImport cconv safety h n sourceText
+ mk h n = CImport sourceText cconv safety h n
hdr_char c = not (isSpace c)
-- header files are filenames, which can contain
@@ -2739,8 +2739,7 @@ mkExport :: Located CCallConv
mkExport (L lc cconv) (L le (StringLiteral esrc entity _), v, ty)
= return $ \ann -> ForD noExtField $
ForeignExport { fd_e_ext = ann, fd_name = v, fd_sig_ty = ty
- , fd_fe = CExport (L lc (CExportStatic esrc entity' cconv))
- (L le esrc) }
+ , fd_fe = CExport (L le esrc) (L lc (CExportStatic esrc entity' cconv)) }
where
entity' | nullFS entity = mkExtName (unLoc v)
| otherwise = entity
diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs
index be6dd17006..f34235b52d 100644
--- a/compiler/GHC/Rename/Module.hs
+++ b/compiler/GHC/Rename/Module.hs
@@ -319,12 +319,12 @@ findDupRdrNames = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (
-}
rnAnnDecl :: AnnDecl GhcPs -> RnM (AnnDecl GhcRn, FreeVars)
-rnAnnDecl ann@(HsAnnotation _ s provenance expr)
+rnAnnDecl ann@(HsAnnotation (_, s) provenance expr)
= addErrCtxt (annCtxt ann) $
do { (provenance', provenance_fvs) <- rnAnnProvenance provenance
; (expr', expr_fvs) <- setStage (Splice Untyped) $
rnLExpr expr
- ; return (HsAnnotation noAnn s provenance' expr',
+ ; return (HsAnnotation (noAnn, s) provenance' expr',
provenance_fvs `plusFV` expr_fvs) }
rnAnnProvenance :: AnnProvenance GhcPs
@@ -381,7 +381,7 @@ rnHsForeignDecl (ForeignExport { fd_name = name, fd_sig_ty = ty, fd_fe = spec })
; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) TypeLevel ty
; return (ForeignExport { fd_e_ext = noExtField
, fd_name = name', fd_sig_ty = ty'
- , fd_fe = spec }
+ , fd_fe = (\(CExport x c) -> CExport x c) spec }
, fvs `addOneFV` unLoc name') }
-- NB: a foreign export is an *occurrence site* for name, so
-- we add it to the free-variable list. It might, for example,
@@ -392,9 +392,9 @@ rnHsForeignDecl (ForeignExport { fd_name = name, fd_sig_ty = ty, fd_fe = spec })
-- package, so if they get inlined across a package boundary we'll still
-- know where they're from.
--
-patchForeignImport :: Unit -> ForeignImport -> ForeignImport
-patchForeignImport unit (CImport cconv safety fs spec src)
- = CImport cconv safety fs (patchCImportSpec unit spec) src
+patchForeignImport :: Unit -> (ForeignImport GhcPs) -> (ForeignImport GhcRn)
+patchForeignImport unit (CImport ext cconv safety fs spec)
+ = CImport ext cconv safety fs (patchCImportSpec unit spec)
patchCImportSpec :: Unit -> CImportSpec -> CImportSpec
patchCImportSpec unit spec
@@ -1219,15 +1219,15 @@ standaloneDerivErr
-}
rnHsRuleDecls :: RuleDecls GhcPs -> RnM (RuleDecls GhcRn, FreeVars)
-rnHsRuleDecls (HsRules { rds_src = src
+rnHsRuleDecls (HsRules { rds_ext = (_, src)
, rds_rules = rules })
= do { (rn_rules,fvs) <- rnList rnHsRuleDecl rules
- ; return (HsRules { rds_ext = noExtField
- , rds_src = src
+ ; return (HsRules { rds_ext = src
, rds_rules = rn_rules }, fvs) }
rnHsRuleDecl :: RuleDecl GhcPs -> RnM (RuleDecl GhcRn, FreeVars)
-rnHsRuleDecl (HsRule { rd_name = rule_name
+rnHsRuleDecl (HsRule { rd_ext = (_, st)
+ , rd_name = rule_name
, rd_act = act
, rd_tyvs = tyvs
, rd_tmvs = tmvs
@@ -1238,13 +1238,13 @@ rnHsRuleDecl (HsRule { rd_name = rule_name
; checkDupRdrNamesN rdr_names_w_loc
; checkShadowedRdrNames rdr_names_w_loc
; names <- newLocalBndrsRn rdr_names_w_loc
- ; let doc = RuleCtx (snd $ unLoc rule_name)
+ ; let doc = RuleCtx (unLoc rule_name)
; bindRuleTyVars doc tyvs $ \ tyvs' ->
bindRuleTmVars doc tyvs' tmvs names $ \ tmvs' ->
do { (lhs', fv_lhs') <- rnLExpr lhs
; (rhs', fv_rhs') <- rnLExpr rhs
- ; checkValidRule (snd $ unLoc rule_name) names lhs' fv_lhs'
- ; return (HsRule { rd_ext = HsRuleRn fv_lhs' fv_rhs'
+ ; checkValidRule (unLoc rule_name) names lhs' fv_lhs'
+ ; return (HsRule { rd_ext = (HsRuleRn fv_lhs' fv_rhs', st)
, rd_name = rule_name
, rd_act = act
, rd_tyvs = tyvs'
diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs
index 1e52a526fe..e8c3c6e411 100644
--- a/compiler/GHC/Tc/Errors/Types.hs
+++ b/compiler/GHC/Tc/Errors/Types.hs
@@ -1732,7 +1732,7 @@ data TcRnMessage where
Test cases: ffi/should_fail/T20116
-}
- TcRnForeignImportPrimExtNotSet :: ForeignImport -> TcRnMessage
+ TcRnForeignImportPrimExtNotSet :: ForeignImport p -> TcRnMessage
{- TcRnForeignImportPrimSafeAnn is an error declaring that the safe/unsafe
annotation should not be used with @prim@ foreign imports.
@@ -1742,7 +1742,7 @@ data TcRnMessage where
Test cases: None
-}
- TcRnForeignImportPrimSafeAnn :: ForeignImport -> TcRnMessage
+ TcRnForeignImportPrimSafeAnn :: ForeignImport p -> TcRnMessage
{- TcRnForeignFunctionImportAsValue is an error explaining that foreign @value@
imports cannot have function types.
@@ -1752,7 +1752,7 @@ data TcRnMessage where
Test cases: ffi/should_fail/capi_value_function
-}
- TcRnForeignFunctionImportAsValue :: ForeignImport -> TcRnMessage
+ TcRnForeignFunctionImportAsValue :: ForeignImport p -> TcRnMessage
{- TcRnFunPtrImportWithoutAmpersand is a warning controlled by @-Wdodgy-foreign-imports@
that informs the user of a possible missing @&@ in the declaration of a
@@ -1763,7 +1763,7 @@ data TcRnMessage where
Test cases: ffi/should_compile/T1357
-}
- TcRnFunPtrImportWithoutAmpersand :: ForeignImport -> TcRnMessage
+ TcRnFunPtrImportWithoutAmpersand :: ForeignImport p -> TcRnMessage
{- TcRnIllegalForeignDeclBackend is an error occurring when a foreign import declaration
is not compatible with the code generation backend being used.
@@ -1773,7 +1773,7 @@ data TcRnMessage where
Test cases: None
-}
TcRnIllegalForeignDeclBackend
- :: Either ForeignExport ForeignImport
+ :: Either (ForeignExport p) (ForeignImport p)
-> Backend
-> ExpectedBackends
-> TcRnMessage
@@ -1787,7 +1787,7 @@ data TcRnMessage where
Test cases: None
-}
- TcRnUnsupportedCallConv :: Either ForeignExport ForeignImport -> UnsupportedCallConvention -> TcRnMessage
+ TcRnUnsupportedCallConv :: Either (ForeignExport p) (ForeignImport p) -> UnsupportedCallConvention -> TcRnMessage
{- TcRnIllegalForeignType is an error for when a type appears in a foreign
function signature that is not compatible with the FFI.
diff --git a/compiler/GHC/Tc/Gen/Annotation.hs b/compiler/GHC/Tc/Gen/Annotation.hs
index 61c4e192b0..202e18ee74 100644
--- a/compiler/GHC/Tc/Gen/Annotation.hs
+++ b/compiler/GHC/Tc/Gen/Annotation.hs
@@ -48,7 +48,7 @@ warnAnns anns@(L loc _ : _)
; return [] }
tcAnnotation :: LAnnDecl GhcRn -> TcM Annotation
-tcAnnotation (L loc ann@(HsAnnotation _ _ provenance expr)) = do
+tcAnnotation (L loc ann@(HsAnnotation _ provenance expr)) = do
-- Work out what the full target of this annotation was
mod <- getModule
let target = annProvenanceToTarget mod provenance
diff --git a/compiler/GHC/Tc/Gen/Foreign.hs b/compiler/GHC/Tc/Gen/Foreign.hs
index 819c66b2c2..ea251c2bcb 100644
--- a/compiler/GHC/Tc/Gen/Foreign.hs
+++ b/compiler/GHC/Tc/Gen/Foreign.hs
@@ -264,9 +264,9 @@ tcFImport d = pprPanic "tcFImport" (ppr d)
-- ------------ Checking types for foreign import ----------------------
-tcCheckFIType :: [Scaled Type] -> Type -> ForeignImport -> TcM ForeignImport
+tcCheckFIType :: [Scaled Type] -> Type -> ForeignImport GhcRn -> TcM (ForeignImport GhcTc)
-tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) safety mh l@(CLabel _) src)
+tcCheckFIType arg_tys res_ty idecl@(CImport src (L lc cconv) safety mh l@(CLabel _))
-- Foreign import label
= do checkCg (Right idecl) backendValidityOfCImport
-- NB check res_ty not sig_ty!
@@ -274,9 +274,9 @@ tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) safety mh l@(CLabel _)
check (isFFILabelTy (mkVisFunTys arg_tys res_ty))
(TcRnIllegalForeignType Nothing)
cconv' <- checkCConv (Right idecl) cconv
- return (CImport (L lc cconv') safety mh l src)
+ return (CImport src (L lc cconv') safety mh l)
-tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) safety mh CWrapper src) = do
+tcCheckFIType arg_tys res_ty idecl@(CImport src (L lc cconv) safety mh CWrapper) = do
-- Foreign wrapper (former f.e.d.)
-- The type must be of the form ft -> IO (FunPtr ft), where ft is a valid
-- foreign type. For legacy reasons ft -> IO (Ptr ft) is accepted, too.
@@ -292,10 +292,10 @@ tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) safety mh CWrapper src)
where
(arg1_tys, res1_ty) = tcSplitFunTys arg1_ty
_ -> addErrTc (TcRnIllegalForeignType Nothing OneArgExpected)
- return (CImport (L lc cconv') safety mh CWrapper src)
+ return (CImport src (L lc cconv') safety mh CWrapper)
-tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) (L ls safety) mh
- (CFunction target) src)
+tcCheckFIType arg_tys res_ty idecl@(CImport src (L lc cconv) (L ls safety) mh
+ (CFunction target))
| isDynamicTarget target = do -- Foreign import dynamic
checkCg (Right idecl) backendValidityOfCImport
cconv' <- checkCConv (Right idecl) cconv
@@ -310,7 +310,7 @@ tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) (L ls safety) mh
(TcRnIllegalForeignType (Just Arg))
checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty
- return $ CImport (L lc cconv') (L ls safety) mh (CFunction target) src
+ return $ CImport src (L lc cconv') (L ls safety) mh (CFunction target)
| cconv == PrimCallConv = do
dflags <- getDynFlags
checkTc (xopt LangExt.GHCForeignImportPrim dflags)
@@ -322,7 +322,7 @@ tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) (L ls safety) mh
checkForeignArgs (isFFIPrimArgumentTy dflags) arg_tys
-- prim import result is more liberal, allows (#,,#)
checkForeignRes nonIOok checkSafe (isFFIPrimResultTy dflags) res_ty
- return idecl
+ return (CImport src (L lc cconv) (L ls safety) mh (CFunction target))
| otherwise = do -- Normal foreign import
checkCg (Right idecl) backendValidityOfCImport
cconv' <- checkCConv (Right idecl) cconv
@@ -336,18 +336,18 @@ tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) (L ls safety) mh
| not (null arg_tys) ->
addErrTc (TcRnForeignFunctionImportAsValue idecl)
_ -> return ()
- return $ CImport (L lc cconv') (L ls safety) mh (CFunction target) src
+ return $ CImport src (L lc cconv') (L ls safety) mh (CFunction target)
-- This makes a convenient place to check
-- that the C identifier is valid for C
-checkCTarget :: ForeignImport -> CCallTarget -> TcM ()
+checkCTarget :: ForeignImport p -> CCallTarget -> TcM ()
checkCTarget idecl (StaticTarget _ str _ _) = do
checkCg (Right idecl) backendValidityOfCImport
checkTc (isCLabelString str) (TcRnInvalidCIdentifier str)
checkCTarget _ DynamicTarget = panic "checkCTarget DynamicTarget"
-checkMissingAmpersand :: ForeignImport -> [Type] -> Type -> TcM ()
+checkMissingAmpersand :: ForeignImport p -> [Type] -> Type -> TcM ()
checkMissingAmpersand idecl arg_tys res_ty
| null arg_tys && isFunPtrTy res_ty
= addDiagnosticTc $ TcRnFunPtrImportWithoutAmpersand idecl
@@ -413,14 +413,14 @@ tcFExport d = pprPanic "tcFExport" (ppr d)
-- ------------ Checking argument types for foreign export ----------------------
-tcCheckFEType :: Type -> ForeignExport -> TcM ForeignExport
-tcCheckFEType sig_ty edecl@(CExport (L l (CExportStatic esrc str cconv)) src) = do
+tcCheckFEType :: Type -> ForeignExport GhcRn -> TcM (ForeignExport GhcTc)
+tcCheckFEType sig_ty edecl@(CExport src (L l (CExportStatic esrc str cconv))) = do
checkCg (Left edecl) backendValidityOfCExport
checkTc (isCLabelString str) (TcRnInvalidCIdentifier str)
cconv' <- checkCConv (Left edecl) cconv
checkForeignArgs isFFIExternalTy arg_tys
checkForeignRes nonIOok noCheckSafe isFFIExportResultTy res_ty
- return (CExport (L l (CExportStatic esrc str cconv')) src)
+ return (CExport src (L l (CExportStatic esrc str cconv')))
where
-- Drop the foralls before inspecting
-- the structure of the foreign type.
@@ -497,7 +497,7 @@ checkSafe, noCheckSafe :: Bool
checkSafe = True
noCheckSafe = False
-checkCg :: Either ForeignExport ForeignImport -> (Backend -> Validity' ExpectedBackends) -> TcM ()
+checkCg :: Either (ForeignExport p) (ForeignImport p) -> (Backend -> Validity' ExpectedBackends) -> TcM ()
checkCg decl check = do
dflags <- getDynFlags
let bcknd = backend dflags
@@ -508,7 +508,7 @@ checkCg decl check = do
-- Calling conventions
-checkCConv :: Either ForeignExport ForeignImport -> CCallConv -> TcM CCallConv
+checkCConv :: Either (ForeignExport p) (ForeignImport p) -> CCallConv -> TcM CCallConv
checkCConv _ CCallConv = return CCallConv
checkCConv _ CApiConv = return CApiConv
checkCConv decl StdCallConv = do
diff --git a/compiler/GHC/Tc/Gen/Rule.hs b/compiler/GHC/Tc/Gen/Rule.hs
index 1aae9a5ece..38572d7341 100644
--- a/compiler/GHC/Tc/Gen/Rule.hs
+++ b/compiler/GHC/Tc/Gen/Rule.hs
@@ -103,23 +103,22 @@ tcRules :: [LRuleDecls GhcRn] -> TcM [LRuleDecls GhcTc]
tcRules decls = mapM (wrapLocMA tcRuleDecls) decls
tcRuleDecls :: RuleDecls GhcRn -> TcM (RuleDecls GhcTc)
-tcRuleDecls (HsRules { rds_src = src
+tcRuleDecls (HsRules { rds_ext = src
, rds_rules = decls })
= do { tc_decls <- mapM (wrapLocMA tcRule) decls
- ; return $ HsRules { rds_ext = noExtField
- , rds_src = src
+ ; return $ HsRules { rds_ext = src
, rds_rules = tc_decls } }
tcRule :: RuleDecl GhcRn -> TcM (RuleDecl GhcTc)
tcRule (HsRule { rd_ext = ext
- , rd_name = rname@(L _ (_,name))
+ , rd_name = rname@(L _ name)
, rd_act = act
, rd_tyvs = ty_bndrs
, rd_tmvs = tm_bndrs
, rd_lhs = lhs
, rd_rhs = rhs })
= addErrCtxt (ruleCtxt name) $
- do { traceTc "---- Rule ------" (pprFullRuleName rname)
+ do { traceTc "---- Rule ------" (pprFullRuleName (snd ext) rname)
; skol_info <- mkSkolemInfo (RuleSkol name)
-- Note [Typechecking rules]
; (tc_lvl, stuff) <- pushTcLevelM $
@@ -128,7 +127,7 @@ tcRule (HsRule { rd_ext = ext
; let (id_bndrs, lhs', lhs_wanted
, rhs', rhs_wanted, rule_ty) = stuff
- ; traceTc "tcRule 1" (vcat [ pprFullRuleName rname
+ ; traceTc "tcRule 1" (vcat [ pprFullRuleName (snd ext) rname
, ppr lhs_wanted
, ppr rhs_wanted ])
@@ -157,7 +156,7 @@ tcRule (HsRule { rd_ext = ext
quant_cands = forall_tkvs { dv_kvs = weed_out (dv_kvs forall_tkvs)
, dv_tvs = weed_out (dv_tvs forall_tkvs) }
; qtkvs <- quantifyTyVars skol_info DefaultNonStandardTyVars quant_cands
- ; traceTc "tcRule" (vcat [ pprFullRuleName rname
+ ; traceTc "tcRule" (vcat [ pprFullRuleName (snd ext) rname
, text "forall_tkvs:" <+> ppr forall_tkvs
, text "quant_cands:" <+> ppr quant_cands
, text "don't_default:" <+> ppr don't_default
diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs
index 9594927da3..52861159d5 100644
--- a/compiler/GHC/ThToHs.hs
+++ b/compiler/GHC/ThToHs.hs
@@ -758,11 +758,10 @@ cvtForD (ImportF callconv safety from nm ty) =
; if -- the prim and javascript calling conventions do not support headers
-- and are inserted verbatim, analogous to mkImport in GHC.Parser.PostProcess
| callconv == TH.Prim || callconv == TH.JavaScript
- -> mk_imp (CImport (L l (cvt_conv callconv)) (L l safety') Nothing
+ -> mk_imp (CImport (L l $ quotedSourceText from) (L l (cvt_conv callconv)) (L l safety') Nothing
(CFunction (StaticTarget (SourceText from)
(mkFastString from) Nothing
- True))
- (L l $ quotedSourceText from))
+ True)))
| Just impspec <- parseCImport (L l (cvt_conv callconv)) (L l safety')
(mkFastString (TH.nameBase nm))
from (L l $ quotedSourceText from)
@@ -787,10 +786,9 @@ cvtForD (ExportF callconv as nm ty)
= do { nm' <- vNameN nm
; ty' <- cvtSigType ty
; l <- getL
- ; let e = CExport (L l (CExportStatic (SourceText as)
- (mkFastString as)
- (cvt_conv callconv)))
- (L l (SourceText as))
+ ; let e = CExport (L l (SourceText as)) (L l (CExportStatic (SourceText as)
+ (mkFastString as)
+ (cvt_conv callconv)))
; return $ ForeignExport { fd_e_ext = noAnn
, fd_name = nm'
, fd_sig_ty = ty'
@@ -861,14 +859,14 @@ cvtPragmaD (SpecialiseInstP ty)
cvtPragmaD (RuleP nm ty_bndrs tm_bndrs lhs rhs phases)
= do { let nm' = mkFastString nm
- ; rd_name' <- returnLA (quotedSourceText nm,nm')
+ ; rd_name' <- returnLA nm'
; let act = cvtPhases phases AlwaysActive
; ty_bndrs' <- traverse cvtTvs ty_bndrs
; tm_bndrs' <- mapM cvtRuleBndr tm_bndrs
; lhs' <- cvtl lhs
; rhs' <- cvtl rhs
; rule <- returnLA $
- HsRule { rd_ext = noAnn
+ HsRule { rd_ext = (noAnn, quotedSourceText nm)
, rd_name = rd_name'
, rd_act = act
, rd_tyvs = ty_bndrs'
@@ -876,8 +874,7 @@ cvtPragmaD (RuleP nm ty_bndrs tm_bndrs lhs rhs phases)
, rd_lhs = lhs'
, rd_rhs = rhs' }
; returnJustLA $ Hs.RuleD noExtField
- $ HsRules { rds_ext = noAnn
- , rds_src = SourceText "{-# RULES"
+ $ HsRules { rds_ext = (noAnn, SourceText "{-# RULES")
, rds_rules = [rule] }
}
@@ -893,7 +890,7 @@ cvtPragmaD (AnnP target exp)
n' <- vcName n
wrapParLA ValueAnnProvenance n'
; returnJustLA $ Hs.AnnD noExtField
- $ HsAnnotation noAnn (SourceText "{-# ANN") target' exp'
+ $ HsAnnotation (noAnn, (SourceText "{-# ANN")) target' exp'
}
-- NB: This is the only place in GHC.ThToHs that makes use of the `setL`
diff --git a/compiler/Language/Haskell/Syntax/Binds.hs b/compiler/Language/Haskell/Syntax/Binds.hs
index 22f2116b04..c6193af03b 100644
--- a/compiler/Language/Haskell/Syntax/Binds.hs
+++ b/compiler/Language/Haskell/Syntax/Binds.hs
@@ -31,9 +31,9 @@ import {-# SOURCE #-} Language.Haskell.Syntax.Pat
import Language.Haskell.Syntax.Extension
import Language.Haskell.Syntax.Type
-import GHC.Types.Basic (InlinePragma)
import GHC.Types.Fixity
import GHC.Data.Bag
+import GHC.Types.Basic (InlinePragma)
import GHC.Data.BooleanFormula (LBooleanFormula)
import GHC.Types.SourceText (StringLiteral)
diff --git a/compiler/Language/Haskell/Syntax/Decls.hs b/compiler/Language/Haskell/Syntax/Decls.hs
index 0e0f0ff94c..0e013b3eea 100644
--- a/compiler/Language/Haskell/Syntax/Decls.hs
+++ b/compiler/Language/Haskell/Syntax/Decls.hs
@@ -46,7 +46,7 @@ module Language.Haskell.Syntax.Decls (
FamilyDecl(..), LFamilyDecl,
-- ** Instance declarations
- InstDecl(..), LInstDecl, FamilyInfo(..), pprFlavour,
+ InstDecl(..), LInstDecl, FamilyInfo(..),
TyFamInstDecl(..), LTyFamInstDecl,
TyFamDefltDecl, LTyFamDefltDecl,
DataFamInstDecl(..), LDataFamInstDecl,
@@ -57,12 +57,10 @@ module Language.Haskell.Syntax.Decls (
DerivDecl(..), LDerivDecl,
-- ** Deriving strategies
DerivStrategy(..), LDerivStrategy,
- derivStrategyName,
-- ** @RULE@ declarations
LRuleDecls,RuleDecls(..),RuleDecl(..),LRuleDecl,HsRuleRn(..),
RuleBndr(..),LRuleBndr,
collectRuleBndrSigTys,
- pprFullRuleName,
-- ** @default@ declarations
DefaultDecl(..), LDefaultDecl,
-- ** Template haskell declaration splice
@@ -111,15 +109,12 @@ import GHC.Types.Name.Set
import GHC.Types.Fixity
-- others:
-import GHC.Utils.Outputable
import GHC.Utils.Misc
import GHC.Types.SrcLoc
-import GHC.Types.SourceText
import GHC.Core.Type
import GHC.Unit.Module.Warnings
-import Data.Maybe
-import Data.Data hiding (TyCon,Fixity, Infix)
+import Data.Data hiding (TyCon, Fixity, Infix)
import Data.Void
{-
@@ -259,9 +254,6 @@ data SpliceDecoration
| BareSplice -- ^ bare splice
deriving (Data, Eq, Show)
-instance Outputable SpliceDecoration where
- ppr x = text $ show x
-
{-
************************************************************************
* *
@@ -884,18 +876,6 @@ data FamilyInfo pass
| ClosedTypeFamily (Maybe [LTyFamInstEqn pass])
-------------- Pretty printing FamilyDecls -----------
-
-pprFlavour :: FamilyInfo pass -> SDoc
-pprFlavour DataFamily = text "data"
-pprFlavour OpenTypeFamily = text "type"
-pprFlavour (ClosedTypeFamily {}) = text "type"
-
-instance Outputable (FamilyInfo pass) where
- ppr info = pprFlavour info <+> text "family"
-
-
-
{- *********************************************************************
* *
Data types and data constructors
@@ -1231,10 +1211,6 @@ data HsConDeclGADTDetails pass
= PrefixConGADT [HsScaled pass (LBangType pass)]
| RecConGADT (XRec pass [LConDeclField pass]) (LHsUniToken "->" "→" pass)
-instance Outputable NewOrData where
- ppr NewType = text "newtype"
- ppr DataType = text "data"
-
{-
************************************************************************
* *
@@ -1482,14 +1458,6 @@ data DerivStrategy pass
| ViaStrategy (XViaStrategy pass)
-- ^ @-XDerivingVia@
--- | A short description of a @DerivStrategy'@.
-derivStrategyName :: DerivStrategy a -> SDoc
-derivStrategyName = text . go
- where
- go StockStrategy {} = "stock"
- go AnyclassStrategy {} = "anyclass"
- go NewtypeStrategy {} = "newtype"
- go ViaStrategy {} = "via"
{-
************************************************************************
@@ -1538,13 +1506,13 @@ data ForeignDecl pass
{ fd_i_ext :: XForeignImport pass -- Post typechecker, rep_ty ~ sig_ty
, fd_name :: LIdP pass -- defines this name
, fd_sig_ty :: LHsSigType pass -- sig_ty
- , fd_fi :: ForeignImport }
+ , fd_fi :: ForeignImport pass }
| ForeignExport
{ fd_e_ext :: XForeignExport pass -- Post typechecker, rep_ty ~ sig_ty
, fd_name :: LIdP pass -- uses this name
, fd_sig_ty :: LHsSigType pass -- sig_ty
- , fd_fe :: ForeignExport }
+ , fd_fe :: ForeignExport pass }
-- ^
-- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnForeign',
-- 'GHC.Parser.Annotation.AnnImport','GHC.Parser.Annotation.AnnExport',
@@ -1565,27 +1533,26 @@ data ForeignDecl pass
-- Specification Of an imported external entity in dependence on the calling
-- convention
--
-data ForeignImport = -- import of a C entity
- --
- -- * the two strings specifying a header file or library
- -- may be empty, which indicates the absence of a
- -- header or object specification (both are not used
- -- in the case of `CWrapper' and when `CFunction'
- -- has a dynamic target)
- --
- -- * the calling convention is irrelevant for code
- -- generation in the case of `CLabel', but is needed
- -- for pretty printing
- --
- -- * `Safety' is irrelevant for `CLabel' and `CWrapper'
- --
- CImport (Located CCallConv) -- ccall or stdcall
- (Located Safety) -- interruptible, safe or unsafe
- (Maybe Header) -- name of C header
- CImportSpec -- details of the C entity
- (Located SourceText) -- original source text for
- -- the C entity
- deriving Data
+data ForeignImport pass = -- import of a C entity
+ --
+ -- * the two strings specifying a header file or library
+ -- may be empty, which indicates the absence of a
+ -- header or object specification (both are not used
+ -- in the case of `CWrapper' and when `CFunction'
+ -- has a dynamic target)
+ --
+ -- * the calling convention is irrelevant for code
+ -- generation in the case of `CLabel', but is needed
+ -- for pretty printing
+ --
+ -- * `Safety' is irrelevant for `CLabel' and `CWrapper'
+ --
+ CImport (XCImport pass)
+ (Located CCallConv) -- ccall or stdcall
+ (Located Safety) -- interruptible, safe or unsafe
+ (Maybe Header) -- name of C header
+ CImportSpec -- details of the C entity
+ | XForeignImport !(XXForeignImport pass)
-- details of an external C entity
--
@@ -1598,46 +1565,9 @@ data CImportSpec = CLabel CLabelString -- import address of a C label
-- specification of an externally exported entity in dependence on the calling
-- convention
--
-data ForeignExport = CExport (Located CExportSpec) -- contains the calling
- -- convention
- (Located SourceText) -- original source text for
- -- the C entity
- deriving Data
-
--- pretty printing of foreign declarations
---
+data ForeignExport pass = CExport (XCExport pass) (Located CExportSpec) -- contains the calling convention
+ | XForeignExport !(XXForeignExport pass)
-instance Outputable ForeignImport where
- 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) _ =
- 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)) _) =
- ppr cconv <+> char '"' <> ppr lbl <> char '"'
{-
************************************************************************
@@ -1650,10 +1580,8 @@ instance Outputable ForeignExport where
-- | Located Rule Declarations
type LRuleDecls pass = XRec pass (RuleDecls pass)
- -- Note [Pragma source text] in GHC.Types.SourceText
-- | Rule Declarations
data RuleDecls pass = HsRules { rds_ext :: XCRuleDecls pass
- , rds_src :: SourceText
, rds_rules :: [LRuleDecl pass] }
| XRuleDecls !(XXRuleDecls pass)
@@ -1665,7 +1593,7 @@ data RuleDecl pass
= HsRule -- Source rule
{ rd_ext :: XHsRule pass
-- ^ After renamer, free-vars from the LHS and RHS
- , rd_name :: XRec pass (SourceText,RuleName)
+ , rd_name :: XRec pass RuleName
-- ^ Note [Pragma source text] in "GHC.Types.Basic"
, rd_act :: Activation
, rd_tyvs :: Maybe [LHsTyVarBndr () (NoGhcTc pass)]
@@ -1705,9 +1633,6 @@ data RuleBndr pass
collectRuleBndrSigTys :: [RuleBndr pass] -> [HsPatSigType pass]
collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ _ ty <- bndrs]
-pprFullRuleName :: GenLocated a (SourceText, RuleName) -> SDoc
-pprFullRuleName (L _ (st, n)) = pprWithSourceText st (doubleQuotes $ ftext n)
-
{-
************************************************************************
* *
@@ -1728,10 +1653,6 @@ data DocDecl pass
deriving instance (Data pass, Data (IdP pass)) => Data (DocDecl pass)
--- Okay, I need to reconstruct the document comments, but for now:
-instance Outputable (DocDecl name) where
- ppr _ = text "<document comment>"
-
docDeclDoc :: DocDecl pass -> LHsDoc pass
docDeclDoc (DocCommentNext d) = d
docDeclDoc (DocCommentPrev d) = d
@@ -1751,10 +1672,8 @@ We use exported entities for things to deprecate.
-- | Located Warning Declarations
type LWarnDecls pass = XRec pass (WarnDecls pass)
- -- Note [Pragma source text] in GHC.Types.SourceText
-- | Warning pragma Declarations
data WarnDecls pass = Warnings { wd_ext :: XWarnings pass
- , wd_src :: SourceText
, wd_warnings :: [LWarnDecl pass]
}
| XWarnDecls !(XXWarnDecls pass)
@@ -1781,7 +1700,6 @@ type LAnnDecl pass = XRec pass (AnnDecl pass)
-- | Annotation Declaration
data AnnDecl pass = HsAnnotation
(XHsAnnotation pass)
- SourceText -- Note [Pragma source text] in GHC.Types.SourceText
(AnnProvenance pass) (XRec pass (HsExpr pass))
-- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen',
-- 'GHC.Parser.Annotation.AnnType'
diff --git a/compiler/Language/Haskell/Syntax/Extension.hs b/compiler/Language/Haskell/Syntax/Extension.hs
index 6312681f52..74cdbb07e0 100644
--- a/compiler/Language/Haskell/Syntax/Extension.hs
+++ b/compiler/Language/Haskell/Syntax/Extension.hs
@@ -354,6 +354,10 @@ type family XXDefaultDecl x
type family XForeignImport x
type family XForeignExport x
type family XXForeignDecl x
+type family XCImport x
+type family XXForeignImport x
+type family XCExport x
+type family XXForeignExport x
-- -------------------------------------
-- RuleDecls type families
View Lorry Controller Status