From acc1816b9153f134a3308d13b90d67bfcb123d87 Mon Sep 17 00:00:00 2001 From: romes Date: Mon, 13 Jun 2022 23:22:06 +0200 Subject: TTG for ForeignImport/Export Add a TTG parameter to both `ForeignImport` and `ForeignExport` and, according to #21592, move the GHC-specific bits in them and in the other AST data types related to foreign imports and exports to the TTG extension point. --- compiler/GHC/Driver/Errors/Ppr.hs | 2 +- compiler/GHC/Hs/Decls.hs | 125 ++++++++++++++++++++--- compiler/GHC/Hs/Instances.hs | 10 ++ compiler/GHC/HsToCore.hs | 2 +- compiler/GHC/HsToCore/Foreign/Decl.hs | 8 +- compiler/GHC/HsToCore/Quote.hs | 8 +- compiler/GHC/Iface/Ext/Ast.hs | 14 +-- compiler/GHC/Parser.y | 22 ++--- compiler/GHC/Parser/PostProcess.hs | 11 +-- compiler/GHC/Rename/Module.hs | 26 ++--- compiler/GHC/Tc/Errors/Types.hs | 12 +-- compiler/GHC/Tc/Gen/Annotation.hs | 2 +- compiler/GHC/Tc/Gen/Foreign.hs | 34 +++---- compiler/GHC/Tc/Gen/Rule.hs | 13 ++- compiler/GHC/ThToHs.hs | 21 ++-- compiler/Language/Haskell/Syntax/Binds.hs | 2 +- compiler/Language/Haskell/Syntax/Decls.hs | 136 +++++--------------------- compiler/Language/Haskell/Syntax/Extension.hs | 4 + 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 "" + 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 "" - 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 -- cgit v1.2.1