[Git][ghc/ghc][wip/az/exactprint] WIP on in-tree annotations
Alan Zimmerman
gitlab at gitlab.haskell.org
Wed Apr 1 23:04:08 UTC 2020
Alan Zimmerman pushed to branch wip/az/exactprint at Glasgow Haskell Compiler / GHC
Commits:
069d05b4 by Alan Zimmerman at 2020-04-02T00:03:28+01:00
WIP on in-tree annotations
Includes updating HsModule
Imports
LocateA ImportDecl so we can hang AnnSemi off it
A whole bunch of stuff more
InjectivityAnn and FamEqn now have annotations in them
- - - - -
28 changed files:
- compiler/GHC/Driver/Backpack.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Hs.hs
- compiler/GHC/Hs/Decls.hs
- compiler/GHC/Hs/Extension.hs
- compiler/GHC/Hs/ImpExp.hs
- compiler/GHC/HsToCore.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Rename/Names.hs
- compiler/GHC/Rename/Source.hs
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/ThToHs.hs
- compiler/main/HeaderInfo.hs
- compiler/main/HscStats.hs
- compiler/parser/Lexer.x
- compiler/parser/Parser.y
- compiler/parser/RdrHsSyn.hs
- compiler/typecheck/TcBackpack.hs
- compiler/typecheck/TcHsSyn.hs
- compiler/typecheck/TcInstDcls.hs
- compiler/typecheck/TcRnDriver.hs
- compiler/typecheck/TcRnExports.hs
- compiler/typecheck/TcRnMonad.hs
- compiler/typecheck/TcRnTypes.hs
- compiler/typecheck/TcRules.hs
- compiler/typecheck/TcTyClsDecls.hs
- compiler/utils/OrdList.hs
Changes:
=====================================
compiler/GHC/Driver/Backpack.hs
=====================================
@@ -695,6 +695,7 @@ summariseRequirement pn mod_name = do
ms_textual_imps = extra_sig_imports,
ms_parsed_mod = Just (HsParsedModule {
hpm_module = L loc (HsModule {
+ hsmodAnn = noAnn,
hsmodName = Just (L loc mod_name),
hsmodExports = Nothing,
hsmodImports = [],
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -394,7 +394,8 @@ hscParse' mod_summary
srcs2 <- liftIO $ filterM doesFileExist srcs1
let api_anns = ApiAnns {
- apiAnnItems = M.fromListWith (++) $ annotations pst,
+ -- AZ apiAnnItems = M.fromListWith (++) $ annotations pst,
+ apiAnnItems = M.empty,
apiAnnEofPos = eof_pos pst,
apiAnnComments = M.fromList (annotations_comments pst),
apiAnnRogueComments = comment_q pst
@@ -991,9 +992,9 @@ hscCheckSafeImports tcg_env = do
warns dflags rules = listToBag $ map (warnRules dflags) rules
- warnRules :: DynFlags -> GenLocated SrcSpan (RuleDecl GhcTc) -> ErrMsg
+ warnRules :: DynFlags -> LRuleDecl GhcTc -> ErrMsg
warnRules dflags (L loc (HsRule { rd_name = n })) =
- mkPlainWarnMsg dflags loc $
+ mkPlainWarnMsg dflags (locA loc) $
text "Rule \"" <> ftext (snd $ unLoc n) <> text "\" ignored" $+$
text "User defined rules are disabled under Safe Haskell"
warnRules _ (L _ (XRuleDecl nec)) = noExtCon nec
=====================================
compiler/GHC/Hs.hs
=====================================
@@ -63,10 +63,11 @@ import Data.Data hiding ( Fixity )
-- All we actually declare here is the top-level structure for a module.
data HsModule
= HsModule {
+ hsmodAnn :: ApiAnn,
hsmodName :: Maybe (Located ModuleName),
-- ^ @Nothing@: \"module X where\" is omitted (in which case the next
-- field is Nothing too)
- hsmodExports :: Maybe (Located [LIE GhcPs]),
+ hsmodExports :: Maybe (LocatedA [LIE GhcPs]),
-- ^ Export list
--
-- - @Nothing@: export list omitted, so export everything
@@ -86,7 +87,7 @@ data HsModule
-- downstream.
hsmodDecls :: [LHsDecl GhcPs],
-- ^ Type, class, value, and interface signature decls
- hsmodDeprecMessage :: Maybe (Located WarningTxt),
+ hsmodDeprecMessage :: Maybe (LocatedA WarningTxt),
-- ^ reason\/explanation for warning/deprecation of this module
--
-- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen'
@@ -116,11 +117,11 @@ deriving instance Data HsModule
instance Outputable HsModule where
- ppr (HsModule Nothing _ imports decls _ mbDoc)
+ ppr (HsModule _ Nothing _ imports decls _ mbDoc)
= pp_mb mbDoc $$ pp_nonnull imports
$$ pp_nonnull decls
- ppr (HsModule (Just name) exports imports decls deprec mbDoc)
+ ppr (HsModule _ (Just name) exports imports decls deprec mbDoc)
= vcat [
pp_mb mbDoc,
case exports of
=====================================
compiler/GHC/Hs/Decls.hs
=====================================
@@ -1135,11 +1135,17 @@ type LInjectivityAnn pass = Located (InjectivityAnn pass)
--
-- This will be represented as "InjectivityAnn `r` [`a`, `c`]"
data InjectivityAnn pass
- = InjectivityAnn (LocatedA (IdP pass)) [LocatedA (IdP pass)]
+ = InjectivityAnn (XCInjectivityAnn pass)
+ (LocatedA (IdP pass)) [LocatedA (IdP pass)]
-- ^ - 'ApiAnnotation.AnnKeywordId' :
-- 'ApiAnnotation.AnnRarrow', 'ApiAnnotation.AnnVbar'
-- For details on above see note [Api annotations] in ApiAnnotation
+ | XInjectivityAnn !(XXInjectivityAnn pass)
+
+type instance XCInjectivityAnn (GhcPass _) = ApiAnn
+type instance XXInjectivityAnn (GhcPass _) = NoExtCon
+
data FamilyInfo pass
= DataFamily
@@ -1201,8 +1207,9 @@ pprFamilyDecl top_level (FamilyDecl { fdInfo = info, fdLName = ltycon
TyVarSig _ tv_bndr -> text "=" <+> ppr tv_bndr
XFamilyResultSig nec -> noExtCon nec
pp_inj = case mb_inj of
- Just (L _ (InjectivityAnn lhs rhs)) ->
+ Just (L _ (InjectivityAnn _ lhs rhs)) ->
hsep [ vbar, ppr lhs, text "->", hsep (map ppr rhs) ]
+ Just (L _ (XInjectivityAnn nec)) -> noExtCon nec
Nothing -> empty
(pp_where, pp_eqns) = case info of
ClosedTypeFamily mb_eqns ->
@@ -1628,7 +1635,7 @@ free-standing `type instance` declaration.
----------------- Type synonym family instances -------------
-- | Located Type Family Instance Equation
-type LTyFamInstEqn pass = Located (TyFamInstEqn pass)
+type LTyFamInstEqn pass = LocatedA (TyFamInstEqn pass)
-- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi'
-- when in a list
@@ -1741,7 +1748,7 @@ data FamEqn pass rhs
-- For details on above see note [Api annotations] in ApiAnnotation
-type instance XCFamEqn (GhcPass _) r = NoExtField
+type instance XCFamEqn (GhcPass _) r = ApiAnn
type instance XXFamEqn (GhcPass _) r = NoExtCon
----------------- Class instances -------------
@@ -1760,7 +1767,7 @@ data ClsInstDecl pass
, cid_sigs :: [LSig pass] -- User-supplied pragmatic info
, cid_tyfam_insts :: [LTyFamInstDecl pass] -- Type family instances
, cid_datafam_insts :: [LDataFamInstDecl pass] -- Data family instances
- , cid_overlap_mode :: Maybe (Located OverlapMode)
+ , cid_overlap_mode :: Maybe (LocatedA OverlapMode)
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
-- 'ApiAnnotation.AnnClose',
@@ -1922,7 +1929,7 @@ ppDerivStrategy mb =
Nothing -> empty
Just (L _ ds) -> ppr ds
-ppOverlapPragma :: Maybe (Located OverlapMode) -> SDoc
+ppOverlapPragma :: Maybe (LocatedA OverlapMode) -> SDoc
ppOverlapPragma mb =
case mb of
Nothing -> empty
@@ -1982,7 +1989,7 @@ data DerivDecl pass = DerivDecl
-- See Note [Inferring the instance context] in TcDerivInfer.
, deriv_strategy :: Maybe (LDerivStrategy pass)
- , deriv_overlap_mode :: Maybe (Located OverlapMode)
+ , deriv_overlap_mode :: Maybe (LocatedA OverlapMode)
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDeriving',
-- 'ApiAnnotation.AnnInstance', 'ApiAnnotation.AnnStock',
-- 'ApiAnnotation.AnnAnyClass', 'Api.AnnNewtype',
@@ -2170,11 +2177,11 @@ data ForeignDecl pass
such as Int and IO that we know how to make foreign calls with.
-}
-type instance XForeignImport GhcPs = NoExtField
+type instance XForeignImport GhcPs = ApiAnn
type instance XForeignImport GhcRn = NoExtField
type instance XForeignImport GhcTc = Coercion
-type instance XForeignExport GhcPs = NoExtField
+type instance XForeignExport GhcPs = ApiAnn
type instance XForeignExport GhcRn = NoExtField
type instance XForeignExport GhcTc = Coercion
@@ -2292,7 +2299,7 @@ type instance XCRuleDecls GhcTc = NoExtField
type instance XXRuleDecls (GhcPass _) = NoExtCon
-- | Located Rule Declaration
-type LRuleDecl pass = Located (RuleDecl pass)
+type LRuleDecl pass = LocatedA (RuleDecl pass)
-- | Rule Declaration
data RuleDecl pass
@@ -2322,7 +2329,7 @@ data RuleDecl pass
data HsRuleRn = HsRuleRn NameSet NameSet -- Free-vars from the LHS and RHS
deriving Data
-type instance XHsRule GhcPs = NoExtField
+type instance XHsRule GhcPs = ApiAnn
type instance XHsRule GhcRn = HsRuleRn
type instance XHsRule GhcTc = HsRuleRn
=====================================
compiler/GHC/Hs/Extension.hs
=====================================
@@ -261,6 +261,20 @@ data SrcSpanAnn = SrcSpanAnn { ann :: ApiAnn, locA :: SrcSpan }
instance Outputable SrcSpanAnn where
ppr (SrcSpanAnn a l) = text "SrcSpanAnn" <+> ppr a <+> ppr l
+-- ---------------------------------------------------------------------
+-- Managing annotations for lists
+-- ---------------------------------------------------------------------
+
+data AnnList
+ = AnnList {
+ alOpenLoc :: SrcSpan,
+ alOpenKeyword :: AnnKeywordId,
+ alCloseLoc :: SrcSpan,
+ alCloseKeyword :: AnnKeywordId
+ } deriving (Data)
+
+-- ---------------------------------------------------------------------
+
reAnn :: [AddApiAnn] -> ApiAnnComments -> Located a -> LocatedA a
reAnn anns cs (L l a) = L (SrcSpanAnn (ApiAnn anns cs) l) a
@@ -559,6 +573,11 @@ type family XXAnnDecl x
type family XCRoleAnnotDecl x
type family XXRoleAnnotDecl x
+-- -------------------------------------
+-- InjectivityAnn type families
+type family XCInjectivityAnn x
+type family XXInjectivityAnn x
+
-- =====================================================================
-- Type families for the HsExpr extension points
@@ -826,9 +845,6 @@ type family XIEDoc x
type family XIEDocNamed x
type family XXIE x
--- -------------------------------------
-
-
-- =====================================================================
-- End of Type family definitions
-- =====================================================================
=====================================
compiler/GHC/Hs/ImpExp.hs
=====================================
@@ -43,7 +43,7 @@ One per \tr{import} declaration in a module.
-}
-- | Located Import Declaration
-type LImportDecl pass = Located (ImportDecl pass)
+type LImportDecl pass = LocatedA (ImportDecl pass)
-- ^ When in a list this may have
--
-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi'
@@ -88,7 +88,7 @@ data ImportDecl pass
ideclQualified :: ImportDeclQualifiedStyle, -- ^ If/how the import is qualified.
ideclImplicit :: Bool, -- ^ True => implicit import (of Prelude)
ideclAs :: Maybe (Located ModuleName), -- ^ as Module
- ideclHiding :: Maybe (Bool, Located [LIE pass])
+ ideclHiding :: Maybe (Bool, LocatedA [LIE pass])
-- ^ (True => hiding, names)
}
| XImportDecl (XXImportDecl pass)
@@ -197,7 +197,7 @@ type LIEWrappedName name = Located (IEWrappedName name)
-- | Located Import or Export
-type LIE pass = Located (IE pass)
+type LIE pass = LocatedA (IE pass)
-- ^ When in a list this may have
--
-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnComma'
=====================================
compiler/GHC/HsToCore.hs
=====================================
@@ -379,7 +379,7 @@ dsRule (L loc (HsRule { rd_name = name
, rd_tmvs = vars
, rd_lhs = lhs
, rd_rhs = rhs }))
- = putSrcSpanDs loc $
+ = putSrcSpanDs (locA loc) $
do { let bndrs' = [var | L _ (RuleBndr _ (L _ var)) <- vars]
; lhs' <- unsetGOptM Opt_EnableRewriteRules $
=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -598,7 +598,7 @@ repInjectivityAnn :: Maybe (LInjectivityAnn GhcRn)
-> MetaM (Core (Maybe TH.InjectivityAnn))
repInjectivityAnn Nothing =
do { coreNothing injAnnTyConName }
-repInjectivityAnn (Just (L _ (InjectivityAnn lhs rhs))) =
+repInjectivityAnn (Just (L _ (InjectivityAnn _ lhs rhs))) =
do { lhs' <- lookupBinder (unLoc lhs)
; rhs1 <- mapM (lookupBinder . unLoc) rhs
; rhs2 <- coreList nameTyConName rhs1
@@ -840,7 +840,7 @@ repRuleD (L loc (HsRule { rd_name = n
; rhs' <- repLE rhs
; repPragRule n' ty_bndrs' tm_bndrs' lhs' rhs' act' }
; wrapGenSyms ss rule }
- ; return (loc, rule) }
+ ; return (locA loc, rule) }
repRuleD (L _ (XRuleDecl nec)) = noExtCon nec
ruleBndrNames :: LRuleBndr GhcRn -> [Name]
=====================================
compiler/GHC/Iface/Ext/Ast.hs
=====================================
@@ -1344,11 +1344,11 @@ instance ToHie (LFamilyDecl GhcRn) where
instance ToHie (FamilyInfo GhcRn) where
toHie (ClosedTypeFamily (Just eqns)) = concatM $
- [ concatMapM (pure . locOnly . getLoc) eqns
+ [ concatMapM (pure . locOnly . getLocA) eqns
, toHie $ map go eqns
]
where
- go (L l ib) = TS (ResolvedScopes [mkScope l]) ib
+ go (L l ib) = TS (ResolvedScopes [mkScope (locA l)]) ib
toHie _ = pure []
instance ToHie (RScoped (LFamilyResultSig GhcRn)) where
@@ -1389,7 +1389,7 @@ instance (ToHie rhs, HasLoc rhs)
instance ToHie (LInjectivityAnn GhcRn) where
toHie (L span ann) = concatM $ makeNode ann span : case ann of
- InjectivityAnn lhs rhs ->
+ InjectivityAnn _ lhs rhs ->
[ toHie $ C Use lhs
, toHie $ map (C Use) rhs
]
@@ -1425,8 +1425,8 @@ instance ToHie (Located (DerivStrategy GhcRn)) where
NewtypeStrategy _ -> []
ViaStrategy s -> [ toHie $ TS (ResolvedScopes []) s ]
-instance ToHie (Located OverlapMode) where
- toHie (L span _) = pure $ locOnly span
+instance ToHie (LocatedA OverlapMode) where
+ toHie (L span _) = pure $ locOnly (locA span)
instance ToHie (LConDecl GhcRn) where
toHie (L span decl) = concatM $ makeNode decl span : case decl of
@@ -1863,10 +1863,10 @@ instance ToHie (LRuleDecls GhcRn) where
instance ToHie (LRuleDecl GhcRn) where
toHie (L _ (XRuleDecl _)) = pure []
toHie (L span r@(HsRule _ rname _ tybndrs bndrs exprA exprB)) = concatM
- [ makeNode r span
+ [ makeNode r (locA span)
, pure $ locOnly $ getLoc rname
, toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs
- , toHie $ map (RS $ mkScope span) bndrs
+ , toHie $ map (RS $ mkScope (locA span)) bndrs
, toHie exprA
, toHie exprB
]
@@ -1887,7 +1887,7 @@ instance ToHie (RScoped (LRuleBndr GhcRn)) where
XRuleBndr _ -> []
instance ToHie (LImportDecl GhcRn) where
- toHie (L span decl) = concatM $ makeNode decl span : case decl of
+ toHie (L span decl) = concatM $ makeNode decl (locA span) : case decl of
ImportDecl { ideclName = name, ideclAs = as, ideclHiding = hidden } ->
[ toHie $ IEC Import name
, toHie $ fmap (IEC ImportAs) as
@@ -1896,14 +1896,14 @@ instance ToHie (LImportDecl GhcRn) where
XImportDecl _ -> []
where
goIE (hiding, (L sp liens)) = concatM $
- [ pure $ locOnly sp
+ [ pure $ locOnly (locA sp)
, toHie $ map (IEC c) liens
]
where
c = if hiding then ImportHiding else Import
instance ToHie (IEContext (LIE GhcRn)) where
- toHie (IEC c (L span ie)) = concatM $ makeNode ie span : case ie of
+ toHie (IEC c (L span ie)) = concatM $ makeNode ie (locA span) : case ie of
IEVar _ n ->
[ toHie $ IEC c n
]
=====================================
compiler/GHC/Rename/Names.hs
=====================================
@@ -273,7 +273,7 @@ rnImportDecl this_mod
, ideclSource = want_boot, ideclSafe = mod_safe
, ideclQualified = qual_style, ideclImplicit = implicit
, ideclAs = as_mod, ideclHiding = imp_details }))
- = setSrcSpan loc $ do
+ = setSrcSpan (locA loc) $ do
when (isJust mb_pkg) $ do
pkg_imports <- xoptM LangExt.PackageImports
@@ -343,7 +343,7 @@ rnImportDecl this_mod
let
qual_mod_name = fmap unLoc as_mod `orElse` imp_mod_name
imp_spec = ImpDeclSpec { is_mod = imp_mod_name, is_qual = qual_only,
- is_dloc = loc, is_as = qual_mod_name }
+ is_dloc = locA loc, is_as = qual_mod_name }
-- filter the imports according to the import declaration
(new_imp_details, gres) <- filterImports iface imp_spec imp_details
@@ -364,7 +364,7 @@ rnImportDecl this_mod
let imv = ImportedModsVal
{ imv_name = qual_mod_name
- , imv_span = loc
+ , imv_span = locA loc
, imv_is_safe = mod_safe'
, imv_is_hiding = is_hiding
, imv_all_exports = potential_gres
@@ -906,8 +906,8 @@ although we never look up data constructors.
filterImports
:: ModIface
-> ImpDeclSpec -- The span for the entire import decl
- -> Maybe (Bool, Located [LIE GhcPs]) -- Import spec; True => hiding
- -> RnM (Maybe (Bool, Located [LIE GhcRn]), -- Import spec w/ Names
+ -> Maybe (Bool, LocatedA [LIE GhcPs]) -- Import spec; True => hiding
+ -> RnM (Maybe (Bool, LocatedA [LIE GhcRn]), -- Import spec w/ Names
[GlobalRdrElt]) -- Same again, but in GRE form
filterImports iface decl_spec Nothing
= return (Nothing, gresFromAvails (Just imp_spec) (mi_exports iface))
@@ -967,7 +967,7 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items))
lookup_lie :: LIE GhcPs -> TcRn [(LIE GhcRn, AvailInfo)]
lookup_lie (L loc ieRdr)
- = do (stuff, warns) <- setSrcSpan loc $
+ = do (stuff, warns) <- setSrcSpan (locA loc) $
liftM (fromMaybe ([],[])) $
run_lookup (lookup_ie ieRdr)
mapM_ emit_warning warns
@@ -1156,7 +1156,8 @@ gresFromIE decl_spec (L loc ie, avail)
prov_fn name
= Just (ImpSpec { is_decl = decl_spec, is_item = item_spec })
where
- item_spec = ImpSome { is_explicit = is_explicit name, is_iloc = loc }
+ item_spec = ImpSome { is_explicit = is_explicit name
+ , is_iloc = locA loc }
{-
@@ -1399,7 +1400,7 @@ findImportUsage imports used_gres
unused_decl decl@(L loc (ImportDecl { ideclHiding = imps }))
= (decl, used_gres, nameSetElemsStable unused_imps)
where
- used_gres = lookupSrcLoc (srcSpanEnd loc) import_usage
+ used_gres = lookupSrcLoc (srcSpanEnd $ locA loc) import_usage
-- srcSpanEnd: see Note [The ImportMap]
`orElse` []
@@ -1499,7 +1500,7 @@ warnUnusedImport flag fld_env (L loc decl, used, unused)
-- Nothing used; drop entire declaration
| null used
- = addWarnAt (Reason flag) loc msg1
+ = addWarnAt (Reason flag) (locA loc) msg1
-- Everything imported is used; nop
| null unused
@@ -1507,7 +1508,7 @@ warnUnusedImport flag fld_env (L loc decl, used, unused)
-- Some imports are unused
| otherwise
- = addWarnAt (Reason flag) loc msg2
+ = addWarnAt (Reason flag) (locA loc) msg2
where
msg1 = vcat [ pp_herald <+> quotes pp_mod <+> is_redundant
=====================================
compiler/GHC/Rename/Source.hs
=====================================
@@ -244,6 +244,9 @@ addTcgDUs tcg_env dus = tcg_env { tcg_dus = tcg_dus tcg_env `plusDU` dus }
rnList :: (a -> RnM (b, FreeVars)) -> [Located a] -> RnM ([Located b], FreeVars)
rnList f xs = mapFvRn (wrapLocFstM f) xs
+rnListA :: (a -> RnM (b, FreeVars)) -> [LocatedA a] -> RnM ([LocatedA b], FreeVars)
+rnListA f xs = mapFvRn (wrapLocFstMA f) xs
+
{-
*********************************************************
* *
@@ -750,7 +753,7 @@ rnFamInstEqn doc atfi rhs_kvars
; return (HsIB { hsib_ext = all_imp_var_names -- Note [Wildcards in family instances]
, hsib_body
- = FamEqn { feqn_ext = noExtField
+ = FamEqn { feqn_ext = noAnn
, feqn_tycon = tycon'
, feqn_bndrs = bndrs' <$ mb_bndrs
, feqn_pats = pats'
@@ -999,7 +1002,7 @@ standaloneDerivErr
rnHsRuleDecls :: RuleDecls GhcPs -> RnM (RuleDecls GhcRn, FreeVars)
rnHsRuleDecls (HsRules { rds_src = src
, rds_rules = rules })
- = do { (rn_rules,fvs) <- rnList rnHsRuleDecl rules
+ = do { (rn_rules,fvs) <- rnListA rnHsRuleDecl rules
; return (HsRules { rds_ext = noExtField
, rds_src = src
, rds_rules = rn_rules }, fvs) }
@@ -1905,7 +1908,7 @@ rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars
-> FamilyInfo GhcPs -> RnM (FamilyInfo GhcRn, FreeVars)
rn_info (L _ fam_name) (ClosedTypeFamily (Just eqns))
= do { (eqns', fvs)
- <- rnList (rnTyFamInstEqn NonAssocTyFamEqn (ClosedTyFam tycon fam_name))
+ <- rnListA (rnTyFamInstEqn NonAssocTyFamEqn (ClosedTyFam tycon fam_name))
-- no class context
eqns
; return (ClosedTypeFamily (Just eqns'), fvs) }
@@ -1987,16 +1990,16 @@ rnInjectivityAnn :: LHsQTyVars GhcRn -- ^ Type variables declared in
-> LInjectivityAnn GhcPs -- ^ Injectivity annotation
-> RnM (LInjectivityAnn GhcRn)
rnInjectivityAnn tvBndrs (L _ (TyVarSig _ resTv))
- (L srcSpan (InjectivityAnn injFrom injTo))
+ (L srcSpan (InjectivityAnn x injFrom injTo))
= do
- { (injDecl'@(L _ (InjectivityAnn injFrom' injTo')), noRnErrors)
+ { (injDecl'@(L _ (InjectivityAnn _ injFrom' injTo')), noRnErrors)
<- askNoErrs $
bindLocalNames [hsLTyVarName resTv] $
-- The return type variable scopes over the injectivity annotation
-- e.g. type family F a = (r::*) | r -> a
do { injFrom' <- rnLTyVar injFrom
; injTo' <- mapM rnLTyVar injTo
- ; return $ L srcSpan (InjectivityAnn injFrom' injTo') }
+ ; return $ L srcSpan (InjectivityAnn x injFrom' injTo') }
; let tvNames = Set.fromList $ hsAllLTyVarNames tvBndrs
resName = hsLTyVarName resTv
@@ -2032,12 +2035,12 @@ rnInjectivityAnn tvBndrs (L _ (TyVarSig _ resTv))
--
-- So we rename injectivity annotation like we normally would except that
-- this time we expect "result" to be reported not in scope by rnLTyVar.
-rnInjectivityAnn _ _ (L srcSpan (InjectivityAnn injFrom injTo)) =
+rnInjectivityAnn _ _ (L srcSpan (InjectivityAnn x injFrom injTo)) =
setSrcSpan srcSpan $ do
(injDecl', _) <- askNoErrs $ do
injFrom' <- rnLTyVar injFrom
injTo' <- mapM rnLTyVar injTo
- return $ L srcSpan (InjectivityAnn injFrom' injTo')
+ return $ L srcSpan (InjectivityAnn x injFrom' injTo')
return $ injDecl'
{-
=====================================
compiler/GHC/Runtime/Eval.hs
=====================================
@@ -773,7 +773,7 @@ findGlobalRdrEnv hsc_env imports
(err : _, _) -> Left err }
where
idecls :: [LImportDecl GhcPs]
- idecls = [noLoc d | IIDecl d <- imports]
+ idecls = [noLocA d | IIDecl d <- imports]
imods :: [ModuleName]
imods = [m | IIModule m <- imports]
=====================================
compiler/GHC/ThToHs.hs
=====================================
@@ -124,6 +124,9 @@ setL loc = CvtM (\_ _ -> Right (loc, ()))
returnL :: a -> CvtM (Located a)
returnL x = CvtM (\_ loc -> Right (loc, L loc x))
+returnLA :: a -> CvtM (LocatedA a)
+returnLA x = CvtM (\_ loc -> Right (loc, L (noAnnSrcSpan loc) x))
+
returnJustL :: a -> CvtM (Maybe (Located a))
returnJustL = fmap Just . returnL
@@ -293,7 +296,8 @@ cvtDec (InstanceD o ctxt ty decs)
, cid_binds = binds'
, cid_sigs = Hs.mkClassOpSigs sigs'
, cid_tyfam_insts = ats', cid_datafam_insts = adts'
- , cid_overlap_mode = fmap (L loc . overlap) o } }
+ , cid_overlap_mode
+ = fmap (L (noAnnSrcSpan loc) . overlap) o } }
where
overlap pragma =
case pragma of
@@ -329,7 +333,7 @@ cvtDec (DataInstD ctxt bndrs tys ksig constrs derivs)
; returnJustL $ InstD noExtField $ DataFamInstD
{ dfid_ext = noAnn
, dfid_inst = DataFamInstDecl { dfid_eqn = mkHsImplicitBndrs $
- FamEqn { feqn_ext = noExtField
+ FamEqn { feqn_ext = noAnn
, feqn_tycon = tc'
, feqn_bndrs = bndrs'
, feqn_pats = typats'
@@ -349,7 +353,7 @@ cvtDec (NewtypeInstD ctxt bndrs tys ksig constr derivs)
; returnJustL $ InstD noExtField $ DataFamInstD
{ dfid_ext = noAnn
, dfid_inst = DataFamInstDecl { dfid_eqn = mkHsImplicitBndrs $
- FamEqn { feqn_ext = noExtField
+ FamEqn { feqn_ext = noAnn
, feqn_tycon = tc'
, feqn_bndrs = bndrs'
, feqn_pats = typats'
@@ -440,8 +444,8 @@ cvtTySynEqn (TySynEqn mb_bndrs lhs rhs)
ConT nm -> do { nm' <- tconNameL nm
; rhs' <- cvtType rhs
; let args' = map wrap_tyarg args
- ; returnL $ mkHsImplicitBndrs
- $ FamEqn { feqn_ext = noExtField
+ ; returnLA $ mkHsImplicitBndrs
+ $ FamEqn { feqn_ext = noAnn
, feqn_tycon = nm'
, feqn_bndrs = mb_bndrs'
, feqn_pats = args'
@@ -450,8 +454,8 @@ cvtTySynEqn (TySynEqn mb_bndrs lhs rhs)
InfixT t1 nm t2 -> do { nm' <- tconNameL nm
; args' <- mapM cvtType [t1,t2]
; rhs' <- cvtType rhs
- ; returnL $ mkHsImplicitBndrs
- $ FamEqn { feqn_ext = noExtField
+ ; returnLA $ mkHsImplicitBndrs
+ $ FamEqn { feqn_ext = noAnn
, feqn_tycon = nm'
, feqn_bndrs = mb_bndrs'
, feqn_pats =
@@ -697,7 +701,7 @@ cvtForD (ImportF callconv safety from nm ty)
mk_imp impspec
= do { nm' <- vNameL nm
; ty' <- cvtType ty
- ; return (ForeignImport { fd_i_ext = noExtField
+ ; return (ForeignImport { fd_i_ext = noAnn
, fd_name = nm'
, fd_sig_ty = mkLHsSigType ty'
, fd_fi = impspec })
@@ -714,7 +718,7 @@ cvtForD (ExportF callconv as nm ty)
(mkFastString as)
(cvt_conv callconv)))
(noLoc (SourceText as))
- ; return $ ForeignExport { fd_e_ext = noExtField
+ ; return $ ForeignExport { fd_e_ext = noAnn
, fd_name = nm'
, fd_sig_ty = mkLHsSigType ty'
, fd_fe = e } }
@@ -777,8 +781,8 @@ cvtPragmaD (RuleP nm ty_bndrs tm_bndrs lhs rhs phases)
; returnJustL $ Hs.RuleD noExtField
$ HsRules { rds_ext = noAnn
, rds_src = SourceText "{-# RULES"
- , rds_rules = [noLoc $
- HsRule { rd_ext = noExtField
+ , rds_rules = [noLocA $
+ HsRule { rd_ext = noAnn
, rd_name = (noLoc (quotedSourceText nm,nm'))
, rd_act = act
, rd_tyvs = ty_bndrs'
@@ -1688,7 +1692,7 @@ cvtInjectivityAnnotation :: TH.InjectivityAnn
cvtInjectivityAnnotation (TH.InjectivityAnn annLHS annRHS)
= do { annLHS' <- tNameL annLHS
; annRHS' <- mapM tNameL annRHS
- ; returnL (Hs.InjectivityAnn annLHS' annRHS') }
+ ; returnL (Hs.InjectivityAnn noAnn annLHS' annRHS') }
cvtPatSynSigTy :: TH.Type -> CvtM (LHsType GhcPs)
-- pattern synonym types are of peculiar shapes, which is why we treat
=====================================
compiler/main/HeaderInfo.hs
=====================================
@@ -125,18 +125,19 @@ mkPrelImports this_mod loc implicit_prelude import_decls
<- import_decls
, unLoc mod == pRELUDE_NAME ]
+ loc' = noAnnSrcSpan loc
preludeImportDecl :: LImportDecl GhcPs
preludeImportDecl
- = L loc $ ImportDecl { ideclExt = noAnn,
- ideclSourceSrc = NoSourceText,
- ideclName = L loc pRELUDE_NAME,
- ideclPkgQual = Nothing,
- ideclSource = False,
- ideclSafe = False, -- Not a safe import
- ideclQualified = NotQualified,
- ideclImplicit = True, -- Implicit!
- ideclAs = Nothing,
- ideclHiding = Nothing }
+ = L loc' $ ImportDecl { ideclExt = noAnn,
+ ideclSourceSrc = NoSourceText,
+ ideclName = L loc pRELUDE_NAME,
+ ideclPkgQual = Nothing,
+ ideclSource = False,
+ ideclSafe = False, -- Not a safe import
+ ideclQualified = NotQualified,
+ ideclImplicit = True, -- Implicit!
+ ideclAs = Nothing,
+ ideclHiding = Nothing }
--------------------------------------------------------------
-- Get options
=====================================
compiler/main/HscStats.hs
=====================================
@@ -22,7 +22,7 @@ import Data.Char
-- | Source Statistics
ppSourceStats :: Bool -> Located HsModule -> SDoc
-ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
+ppSourceStats short (L _ (HsModule _ _ exports imports ldecls _ _))
= (if short then hcat else vcat)
(map pp_val
[("ExportAll ", export_all), -- 1 if no export list
=====================================
compiler/parser/Lexer.x
=====================================
@@ -2124,7 +2124,7 @@ data PState = PState {
-- locations of 'noise' tokens in the source, so that users of
-- the GHC API can do source to source conversions.
-- See note [Api annotations] in ApiAnnotation.hs
- annotations :: [(ApiAnnKey,[RealSrcSpan])],
+ -- AZ annotations :: [(ApiAnnKey,[RealSrcSpan])],
eof_pos :: Maybe RealSrcSpan,
comment_q :: [RealLocated AnnotationComment],
annotations_comments :: [(RealSrcSpan,[RealLocated AnnotationComment])]
@@ -2606,7 +2606,7 @@ mkPStatePure options buf loc =
alr_context = [],
alr_expecting_ocurly = Nothing,
alr_justClosedExplicitLetBlock = False,
- annotations = [],
+ -- AZ annotations = [],
eof_pos = Nothing,
comment_q = [],
annotations_comments = []
@@ -2692,7 +2692,7 @@ instance MonadP P where
getBit ext = P $ \s -> let b = ext `xtest` pExtsBitmap (options s)
in b `seq` POk s b
addAnnotation (RealSrcSpan l _) a (RealSrcSpan v _) = do
- addAnnotationOnly l a v
+ -- AZ addAnnotationOnly l a v
_ <- allocateCommentsP l
return ()
addAnnotation _ _ _ = return ()
@@ -3236,10 +3236,12 @@ data AddApiAnn = AddApiAnn AnnKeywordId SrcSpan deriving (Data,Show,Eq)
instance Outputable AddApiAnn where
ppr (AddApiAnn kw ss) = text "AddApiAnn" <+> ppr kw <+> ppr ss
+{- AZ
addAnnotationOnly :: RealSrcSpan -> AnnKeywordId -> RealSrcSpan -> P ()
addAnnotationOnly l a v = P $ \s -> POk s {
annotations = ((l,a), [v]) : annotations s
} ()
+-}
-- |Given a 'SrcSpan' that surrounds a 'HsPar' or 'HsParTy', generate
-- 'AddApiAnn' values for the opening and closing bordering on the start
=====================================
compiler/parser/Parser.y
=====================================
@@ -725,12 +725,12 @@ unitdecl :: { LHsUnitDecl PackageName }
False -> HsSrcFile
True -> HsBootFile)
$4
- (Just $ sL1 $2 (HsModule (Just $4) $6 (fst $ snd $8) (snd $ snd $8) $5 $1)) }
+ (Just $ sL1 $2 (HsModule noAnn (Just $4) $6 (fst $ snd $8) (snd $ snd $8) $5 $1)) }
| maybedocheader 'signature' modid maybemodwarning maybeexports 'where' body
{ sL1 $2 $ DeclD
HsigFile
$3
- (Just $ sL1 $2 (HsModule (Just $3) $5 (fst $ snd $7) (snd $ snd $7) $4 $1)) }
+ (Just $ sL1 $2 (HsModule noAnn (Just $3) $5 (fst $ snd $7) (snd $ snd $7) $4 $1)) }
-- NB: MUST have maybedocheader here, otherwise shift-reduce conflict
-- will prevent us from parsing both forms.
| maybedocheader 'module' maybe_src modid
@@ -761,23 +761,20 @@ unitdecl :: { LHsUnitDecl PackageName }
signature :: { Located HsModule }
: maybedocheader 'signature' modid maybemodwarning maybeexports 'where' body
{% fileSrcSpan >>= \ loc ->
- ams (\_ -> L loc (HsModule (Just $3) $5 (fst $ snd $7)
- (snd $ snd $7) $4 $1)
- )
- ([mj AnnSignature $2, mj AnnWhere $6] ++ fst $7) }
+ acs (\cs -> L loc (HsModule (ApiAnn ([mj AnnSignature $2, mj AnnWhere $6] ++ fst $7) cs)
+ (Just $3) $5 (fst $ snd $7)
+ (snd $ snd $7) $4 $1) )}
module :: { Located HsModule }
: maybedocheader 'module' modid maybemodwarning maybeexports 'where' body
{% fileSrcSpan >>= \ loc ->
- ams (\_ -> L loc (HsModule (Just $3) $5 (fst $ snd $7)
- (snd $ snd $7) $4 $1)
- )
- ([mj AnnModule $2, mj AnnWhere $6] ++ fst $7) }
+ acs (\cs -> L loc (HsModule (ApiAnn ([mj AnnModule $2, mj AnnWhere $6] ++ fst $7) cs)
+ (Just $3) $5 (fst $ snd $7)
+ (snd $ snd $7) $4 $1) ) }
| body2
{% fileSrcSpan >>= \ loc ->
- ams (\_ -> L loc (HsModule Nothing Nothing
- (fst $ snd $1) (snd $ snd $1) Nothing Nothing))
- (fst $1) }
+ acs (\cs -> L loc (HsModule (ApiAnn (fst $1) cs) Nothing Nothing
+ (fst $ snd $1) (snd $ snd $1) Nothing Nothing)) }
maybedocheader :: { Maybe LHsDocString }
: moduleheader { $1 }
@@ -789,13 +786,13 @@ missing_module_keyword :: { () }
implicit_top :: { () }
: {- empty -} {% pushModuleContext }
-maybemodwarning :: { Maybe (Located WarningTxt) }
+maybemodwarning :: { Maybe (LocatedA WarningTxt) }
: '{-# DEPRECATED' strings '#-}'
- {% ajs (\_ -> sLL $1 $> $ DeprecatedTxt (sL1 $1 (getDEPRECATED_PRAGs $1)) (snd $ unLoc $2))
- (mo $1:mc $3: (fst $ unLoc $2)) }
+ {% fmap Just $ amsr (sLL $1 $> $ DeprecatedTxt (sL1 $1 (getDEPRECATED_PRAGs $1)) (snd $ unLoc $2))
+ (mo $1:mc $3: (fst $ unLoc $2))}
| '{-# WARNING' strings '#-}'
- {% ajs (\_ -> sLL $1 $> $ WarningTxt (sL1 $1 (getWARNING_PRAGs $1)) (snd $ unLoc $2))
- (mo $1:mc $3 : (fst $ unLoc $2)) }
+ {% fmap Just $ amsr (sLL $1 $> $ WarningTxt (sL1 $1 (getWARNING_PRAGs $1)) (snd $ unLoc $2))
+ (mo $1:mc $3 : (fst $ unLoc $2))}
| {- empty -} { Nothing }
body :: { ([AddApiAnn]
@@ -826,15 +823,17 @@ top1 :: { ([LImportDecl GhcPs], [LHsDecl GhcPs]) }
header :: { Located HsModule }
: maybedocheader 'module' modid maybemodwarning maybeexports 'where' header_body
{% fileSrcSpan >>= \ loc ->
- ams (\_ -> L loc (HsModule (Just $3) $5 $7 [] $4 $1
- )) [mj AnnModule $2,mj AnnWhere $6] }
+ acs (\cs -> L loc (HsModule (ApiAnn [mj AnnModule $2,mj AnnWhere $6] cs)
+ (Just $3) $5 $7 [] $4 $1
+ )) }
| maybedocheader 'signature' modid maybemodwarning maybeexports 'where' header_body
{% fileSrcSpan >>= \ loc ->
- ams (\_ -> L loc (HsModule (Just $3) $5 $7 [] $4 $1
- )) [mj AnnModule $2,mj AnnWhere $6] }
+ acs (\cs -> L loc (HsModule (ApiAnn [mj AnnModule $2,mj AnnWhere $6] cs)
+ (Just $3) $5 $7 [] $4 $1
+ )) }
| header_body2
{% fileSrcSpan >>= \ loc ->
- return (L loc (HsModule Nothing Nothing $1 [] Nothing
+ return (L loc (HsModule noAnn Nothing Nothing $1 [] Nothing
Nothing)) }
header_body :: { [LImportDecl GhcPs] }
@@ -855,21 +854,28 @@ header_top_importdecls :: { [LImportDecl GhcPs] }
-----------------------------------------------------------------------------
-- The Export List
-maybeexports :: { (Maybe (Located [LIE GhcPs])) }
- : '(' exportlist ')' {% amsL (comb2 $1 $>) [mop $1,mcp $3] >>
- return (Just (sLL $1 $> (fromOL $2))) }
+maybeexports :: { (Maybe (LocatedA [LIE GhcPs])) }
+ : '(' exportlist ')' {% fmap Just $ amsr (sLL $1 $> (fromOL $2)) [mop $1,mcp $3] }
| {- empty -} { Nothing }
exportlist :: { OrdList (LIE GhcPs) }
- : expdoclist ',' expdoclist {% addAnnotation (oll $1) AnnComma (gl $2)
- >> return ($1 `appOL` $3) }
+ : expdoclist ',' expdoclist {% if isNilOL $1
+ then return ($1 `appOL` $3)
+ else case unsnocOL $1 of
+ (hs,t) -> do
+ t' <- addAnnotationA t AnnComma (gl $2)
+ return (snocOL hs t' `appOL` $3) }
| exportlist1 { $1 }
exportlist1 :: { OrdList (LIE GhcPs) }
: expdoclist export expdoclist ',' exportlist1
- {% (addAnnotation (oll ($1 `appOL` $2 `appOL` $3))
- AnnComma (gl $4) ) >>
- return ($1 `appOL` $2 `appOL` $3 `appOL` $5) }
+ {% let ls = $1 `appOL` $2 `appOL` $3
+ in if isNilOL ls
+ then return (ls `appOL` $5)
+ else case unsnocOL ls of
+ (hs, t) -> do
+ t' <- addAnnotationA t AnnComma (gl $4)
+ return (snocOL hs t' `appOL` $5)}
| expdoclist export expdoclist { $1 `appOL` $2 `appOL` $3 }
| expdoclist { $1 }
@@ -878,20 +884,19 @@ expdoclist :: { OrdList (LIE GhcPs) }
| {- empty -} { nilOL }
exp_doc :: { OrdList (LIE GhcPs) }
- : docsection { unitOL (sL1 $1 (case (unLoc $1) of (n, doc) -> IEGroup noExtField n doc)) }
- | docnamed { unitOL (sL1 $1 (IEDocNamed noExtField ((fst . unLoc) $1))) }
- | docnext { unitOL (sL1 $1 (IEDoc noExtField (unLoc $1))) }
-
+ : docsection { unitOL (sL1a $1 (case (unLoc $1) of (n, doc) -> IEGroup noExtField n doc)) }
+ | docnamed { unitOL (sL1a $1 (IEDocNamed noExtField ((fst . unLoc) $1))) }
+ | docnext { unitOL (sL1a $1 (IEDoc noExtField (unLoc $1))) }
-- No longer allow things like [] and (,,,) to be exported
-- They are built in syntax, always available
export :: { OrdList (LIE GhcPs) }
: qcname_ext export_subspec {% mkModuleImpExp $1 (snd $ unLoc $2)
- >>= \ie -> amsu (\_ -> sLL $1 $> ie) (fst $ unLoc $2) }
- | 'module' modid {% amsu (\cs -> sLL $1 $> (IEModuleContents (ApiAnn [mj AnnModule $1] cs) $2))
- [mj AnnModule $1] }
- | 'pattern' qcon {% amsu (\cs -> sLLlA $1 $> (IEVar (ApiAnn [mj AnnPattern $1] cs) (sLLlA $1 $> (IEPattern $2))))
- [mj AnnPattern $1] }
+ >>= \ie -> fmap unitOL (amsr (sLL $1 $> ie) (fst $ unLoc $2)) }
+ | 'module' modid {% fmap (unitOL . reLocA) (ams (\cs -> sLL $1 $> (IEModuleContents (ApiAnn [mj AnnModule $1] cs) $2))
+ [mj AnnModule $1]) }
+ | 'pattern' qcon {% fmap (unitOL . reLocA) (ams (\cs -> sLLlA $1 $> (IEVar (ApiAnn [mj AnnPattern $1] cs) (sLLlA $1 $> (IEPattern $2))))
+ [mj AnnPattern $1]) }
export_subspec :: { Located ([AddApiAnn],ImpExpSubSpec) }
: {- empty -} { sL0 ([],ImpExpAbs) }
@@ -925,9 +930,9 @@ qcname_ext_w_wildcard :: { Located ([AddApiAnn], Located ImpExpQcSpec) }
qcname_ext :: { Located ImpExpQcSpec }
: qcname { sL1A $1 (ImpExpQcName $1) }
- | 'type' oqtycon {% do { n <- mkTypeImpExp $2
- ; ams (\_ -> sLLlA $1 $> (ImpExpQcType n))
- [mj AnnType $1] } }
+ | 'type' oqtycon {% do { n' <- reA $1 $2 [mj AnnType $1]
+ ; n <- mkTypeImpExp n'
+ ; return $ sLLlA $1 $> (ImpExpQcType n) }}
qcname :: { LocatedA RdrName } -- Variable or type constructor
: qvar { $1 } -- Things which look like functions
@@ -961,7 +966,7 @@ importdecls
importdecls_semi :: { [LImportDecl GhcPs] }
importdecls_semi
: importdecls_semi importdecl semis1
- {% ams (\_ -> $2) $3 >> return ($2 : $1) }
+ {% amsA $2 $3 >> return ($2 : $1) }
| {- empty -} { [] }
importdecl :: { LImportDecl GhcPs }
@@ -971,8 +976,7 @@ importdecl :: { LImportDecl GhcPs }
; let anns
= (mj AnnImport $1 : fst (fst $2) ++ fst $3 ++ fmap (mj AnnQualified) (maybeToList $4)
++ fst $5 ++ fmap (mj AnnQualified) (maybeToList $7) ++ fst $8)
- ; cs <- allocateCommentsS (comb4 $1 $6 (snd $8) $9)
- ; ams (\_ -> L (comb4 $1 $6 (snd $8) $9) $
+ ; fmap reLocA $ ams (\cs -> L (comb4 $1 $6 (snd $8) $9) $
ImportDecl { ideclExt = ApiAnn anns cs
, ideclSourceSrc = snd $ fst $2
, ideclName = $6, ideclPkgQual = snd $5
@@ -1014,20 +1018,20 @@ maybeas :: { ([AddApiAnn],Located (Maybe (Located ModuleName))) }
,sLL $1 $> (Just $2)) }
| {- empty -} { ([],noLoc Nothing) }
-maybeimpspec :: { Located (Maybe (Bool, Located [LIE GhcPs])) }
+maybeimpspec :: { Located (Maybe (Bool, LocatedA [LIE GhcPs])) }
: impspec {% let (b, ie) = unLoc $1 in
checkImportSpec ie
>>= \checkedIe ->
return (L (gl $1) (Just (b, checkedIe))) }
| {- empty -} { noLoc Nothing }
-impspec :: { Located (Bool, Located [LIE GhcPs]) }
- : '(' exportlist ')' {% ams (\_ -> sLL $1 $> (False,
- sLL $1 $> $ fromOL $2))
- [mop $1,mcp $3] }
- | 'hiding' '(' exportlist ')' {% ams (\_ -> sLL $1 $> (True,
- sLL $1 $> $ fromOL $3))
- [mj AnnHiding $1,mop $2,mcp $4] }
+impspec :: { Located (Bool, LocatedA [LIE GhcPs]) }
+ : '(' exportlist ')' {% do { es <- amsr (sLL $1 $> $ fromOL $2)
+ [mop $1,mcp $3]
+ ; return $ sLL $1 $> (False, es)} }
+ | 'hiding' '(' exportlist ')' {% do { es <- amsr (sLL $1 $> $ fromOL $3)
+ [mj AnnHiding $1,mop $2,mcp $4]
+ ; return $ sLL $1 $> (True, es)} }
-----------------------------------------------------------------------------
-- Fixity Declarations
@@ -1043,8 +1047,10 @@ infix :: { Located FixityDirection }
| 'infixr' { sL1 $1 InfixR }
ops :: { Located (OrdList (LocatedA RdrName)) }
- : ops ',' op {% addAnnotation (ollA $ unLoc $1) AnnComma (gl $2) >>
- return (sLLlA $1 $> ((unLoc $1) `appOL` unitOL $3))}
+ : ops ',' op {% case unsnocOL (unLoc $1) of
+ (hs,t) -> do
+ t' <- addAnnotationA t AnnComma (gl $2)
+ return (sLLlA $1 $> (snocOL hs t' `appOL` unitOL $3)) }
| op { sL1A $1 (unitOL $1) }
-----------------------------------------------------------------------------
@@ -1056,7 +1062,7 @@ topdecls :: { OrdList (LHsDecl GhcPs) }
-- May have trailing semicolons, can be empty
topdecls_semi :: { OrdList (LHsDecl GhcPs) }
- : topdecls_semi topdecl semis1 {% ams (\_ -> $2) $3 >> return ($1 `snocOL` $2) }
+ : topdecls_semi topdecl semis1 {% amsr $2 $3 >> return ($1 `snocOL` $2) }
| {- empty -} { nilOL }
topdecl :: { LHsDecl GhcPs }
@@ -1066,17 +1072,12 @@ topdecl :: { LHsDecl GhcPs }
| inst_decl { sL1 $1 (InstD noExtField (unLoc $1)) }
| stand_alone_deriving { sLL $1 $> (DerivD noExtField (unLoc $1)) }
| role_annot { sL1 $1 (RoleAnnotD noExtField (unLoc $1)) }
- | 'default' '(' comma_types0 ')' {% ams (\cs -> sLL $1 $> (DefD noExtField (DefaultDecl (ApiAnn [mj AnnDefault $1,mop $2,mcp $4] cs) $3)))
- [mj AnnDefault $1
- ,mop $2,mcp $4] }
- | 'foreign' fdecl {% ams (\_ -> sLL $1 $> (snd $ unLoc $2))
- (mj AnnForeign $1:(fst $ unLoc $2)) }
- | '{-# DEPRECATED' deprecations '#-}' {% ams (\cs -> sLL $1 $> $ WarningD noExtField (Warnings (ApiAnn [mo $1,mc $3] cs) (getDEPRECATED_PRAGs $1) (fromOL $2)))
- [mo $1,mc $3] }
- | '{-# WARNING' warnings '#-}' {% ams (\cs -> sLL $1 $> $ WarningD noExtField (Warnings (ApiAnn [mo $1,mc $3] cs) (getWARNING_PRAGs $1) (fromOL $2)))
- [mo $1,mc $3] }
- | '{-# RULES' rules '#-}' {% ams (\cs -> sLL $1 $> $ RuleD noExtField (HsRules (ApiAnn [mo $1,mc $3] cs) (getRULES_PRAGs $1) (fromOL $2)))
- [mo $1,mc $3] }
+ | 'default' '(' comma_types0 ')' {% acs (\cs -> sLL $1 $>
+ (DefD noExtField (DefaultDecl (ApiAnn [mj AnnDefault $1,mop $2,mcp $4] cs) $3))) }
+ | 'foreign' fdecl {% acs (\cs -> sLL $1 $> ((snd $ unLoc $2) (ApiAnn (mj AnnForeign $1:(fst $ unLoc $2)) cs))) }
+ | '{-# DEPRECATED' deprecations '#-}' {% acs (\cs -> sLL $1 $> $ WarningD noExtField (Warnings (ApiAnn [mo $1,mc $3] cs) (getDEPRECATED_PRAGs $1) (fromOL $2))) }
+ | '{-# WARNING' warnings '#-}' {% acs (\cs -> sLL $1 $> $ WarningD noExtField (Warnings (ApiAnn [mo $1,mc $3] cs) (getWARNING_PRAGs $1) (fromOL $2))) }
+ | '{-# RULES' rules '#-}' {% acs (\cs -> sLL $1 $> $ RuleD noExtField (HsRules (ApiAnn [mo $1,mc $3] cs) (getRULES_PRAGs $1) (reverse $2))) }
| annotation { $1 }
| decl_no_th { $1 }
@@ -1091,8 +1092,7 @@ topdecl :: { LHsDecl GhcPs }
--
cl_decl :: { LTyClDecl GhcPs }
: 'class' tycl_hdr fds where_cls
- {% amms (mkClassDecl (comb4 $1 $2 $3 $4) $2 $3 (snd $ unLoc $4)
- (ApiAnn (mj AnnClass $1:(fst $ unLoc $3)++(fst $ unLoc $4)) noCom))
+ {% mkClassDecl (comb4 $1 $2 $3 $4) $2 $3 (snd $ unLoc $4)
(mj AnnClass $1:(fst $ unLoc $3)++(fst $ unLoc $4)) }
-- Type declarations (toplevel)
@@ -1107,63 +1107,59 @@ ty_decl :: { LTyClDecl GhcPs }
--
-- Note the use of type for the head; this allows
-- infix type constructors to be declared
- {% amms (mkTySynonym (comb2 $1 $4) $2 $4
- (ApiAnn [mj AnnType $1,mj AnnEqual $3] noCom))
- [mj AnnType $1,mj AnnEqual $3] }
+ {% mkTySynonym (comb2 $1 $4) $2 $4 [mj AnnType $1,mj AnnEqual $3] }
-- type family declarations
| 'type' 'family' type opt_tyfam_kind_sig opt_injective_info
where_type_family
-- Note the use of type for the head; this allows
-- infix type constructors to be declared
- {% amms (mkFamDecl (comb4 $1 $3 $4 $5) (snd $ unLoc $6) $3
+ {% mkFamDecl (comb4 $1 $3 $4 $5) (snd $ unLoc $6) $3
(snd $ unLoc $4) (snd $ unLoc $5)
- (ApiAnn (mj AnnType $1:mj AnnFamily $2:(fst $ unLoc $4)
- ++ (fst $ unLoc $5) ++ (fst $ unLoc $6)) noCom))
- (mj AnnType $1:mj AnnFamily $2:(fst $ unLoc $4)
- ++ (fst $ unLoc $5) ++ (fst $ unLoc $6)) }
+ (mj AnnType $1:mj AnnFamily $2:(fst $ unLoc $4)
+ ++ (fst $ unLoc $5) ++ (fst $ unLoc $6)) }
-- ordinary data type or newtype declaration
| data_or_newtype capi_ctype tycl_hdr constrs maybe_derivings
- {% amms (mkTyData (comb4 $1 $3 $4 $5) (snd $ unLoc $1) $2 $3
+ {% mkTyData (comb4 $1 $3 $4 $5) (snd $ unLoc $1) $2 $3
Nothing (reverse (snd $ unLoc $4))
(fmap reverse $5)
- (ApiAnn ((fst $ unLoc $1):(fst $ unLoc $4)) noCom))
+ ((fst $ unLoc $1):(fst $ unLoc $4)) }
-- We need the location on tycl_hdr in case
-- constrs and deriving are both empty
- ((fst $ unLoc $1):(fst $ unLoc $4)) }
-- ordinary GADT declaration
| data_or_newtype capi_ctype tycl_hdr opt_kind_sig
gadt_constrlist
maybe_derivings
- {% amms (mkTyData (comb4 $1 $3 $5 $6) (snd $ unLoc $1) $2 $3
+ {% mkTyData (comb4 $1 $3 $5 $6) (snd $ unLoc $1) $2 $3
(snd $ unLoc $4) (snd $ unLoc $5)
(fmap reverse $6)
- (ApiAnn ((fst $ unLoc $1):(fst $ unLoc $4)++(fst $ unLoc $5)) noCom))
+ ((fst $ unLoc $1):(fst $ unLoc $4)++(fst $ unLoc $5)) }
-- We need the location on tycl_hdr in case
-- constrs and deriving are both empty
- ((fst $ unLoc $1):(fst $ unLoc $4)++(fst $ unLoc $5)) }
-- data/newtype family
| 'data' 'family' type opt_datafam_kind_sig
- {% amms (mkFamDecl (comb3 $1 $2 $4) DataFamily $3
+ {% mkFamDecl (comb3 $1 $2 $4) DataFamily $3
(snd $ unLoc $4) Nothing
- (ApiAnn (mj AnnData $1:mj AnnFamily $2:(fst $ unLoc $4)) noCom))
- (mj AnnData $1:mj AnnFamily $2:(fst $ unLoc $4)) }
+ (mj AnnData $1:mj AnnFamily $2:(fst $ unLoc $4)) }
-- standalone kind signature
standalone_kind_sig :: { LStandaloneKindSig GhcPs }
: 'type' sks_vars '::' ktypedoc
- {% amms (mkStandaloneKindSig (comb2 $1 $4) $2 $4
- (ApiAnn [mj AnnType $1,mu AnnDcolon $3] noCom))
- [mj AnnType $1,mu AnnDcolon $3] }
+ {% mkStandaloneKindSig (comb2 $1 $4) $2 $4
+ [mj AnnType $1,mu AnnDcolon $3]}
-- See also: sig_vars
sks_vars :: { Located [LocatedA RdrName] } -- Returned in reverse order
: sks_vars ',' oqtycon
- {% addAnnotation (glA $ head $ unLoc $1) AnnComma (gl $2) >>
- return (sLLlA $1 $> ($3 : unLoc $1)) }
+ -- {% addAnnotation (glA $ head $ unLoc $1) AnnComma (gl $2) >>
+ -- return (sLLlA $1 $> ($3 : unLoc $1)) }
+ {% case unLoc $1 of
+ (h:t) -> do
+ h' <- addAnnotationA h AnnComma (gl $2)
+ return (sLLlA $1 $> ($3 : h' : t)) }
| oqtycon { sL1A $1 [$1] }
inst_decl :: { LInstDecl GhcPs }
@@ -1177,68 +1173,57 @@ inst_decl :: { LInstDecl GhcPs }
, cid_tyfam_insts = ats
, cid_overlap_mode = $2
, cid_datafam_insts = adts }
- ; ams (\cs -> L (comb3 $1 (hsSigType $3) $4) (ClsInstD { cid_d_ext = noExtField, cid_inst = cid cs }))
- anns } }
+ ; acs (\cs -> L (comb3 $1 (hsSigType $3) $4)
+ (ClsInstD { cid_d_ext = noExtField, cid_inst = cid cs }))
+ } }
-- type instance declarations
| 'type' 'instance' ty_fam_inst_eqn
- {% ams (\_ -> $3) (fst $ unLoc $3)
- >> amms (mkTyFamInst (comb2 $1 $3) (snd $ unLoc $3)
- (ApiAnn (mj AnnType $1:mj AnnInstance $2:(fst $ unLoc $3)) noCom))
- (mj AnnType $1:mj AnnInstance $2:(fst $ unLoc $3)) }
+ {% mkTyFamInst (comb2A $1 $3) (unLoc $3)
+ (mj AnnType $1:mj AnnInstance $2:[]) }
-- data/newtype instance declaration
| data_or_newtype 'instance' capi_ctype tycl_hdr_inst constrs
maybe_derivings
- {% amms (mkDataFamInst (comb4 $1 $4 $5 $6) (snd $ unLoc $1) $3 (snd $ unLoc $4)
+ {% mkDataFamInst (comb4 $1 $4 $5 $6) (snd $ unLoc $1) $3 (snd $ unLoc $4)
Nothing (reverse (snd $ unLoc $5))
(fmap reverse $6)
- (ApiAnn ((fst $ unLoc $1):mj AnnInstance $2:(fst $ unLoc $4)++(fst $ unLoc $5)) noCom))
- ((fst $ unLoc $1):mj AnnInstance $2:(fst $ unLoc $4)++(fst $ unLoc $5)) }
+ ((fst $ unLoc $1):mj AnnInstance $2:(fst $ unLoc $4)++(fst $ unLoc $5)) }
-- GADT instance declaration
| data_or_newtype 'instance' capi_ctype tycl_hdr_inst opt_kind_sig
gadt_constrlist
maybe_derivings
- {% amms (mkDataFamInst (comb4 $1 $4 $6 $7) (snd $ unLoc $1) $3 (snd $ unLoc $4)
+ {% mkDataFamInst (comb4 $1 $4 $6 $7) (snd $ unLoc $1) $3 (snd $ unLoc $4)
(snd $ unLoc $5) (snd $ unLoc $6)
(fmap reverse $7)
- (ApiAnn ((fst $ unLoc $1):mj AnnInstance $2
- :(fst $ unLoc $4)++(fst $ unLoc $5)++(fst $ unLoc $6)) noCom))
- ((fst $ unLoc $1):mj AnnInstance $2
+ ((fst $ unLoc $1):mj AnnInstance $2
:(fst $ unLoc $4)++(fst $ unLoc $5)++(fst $ unLoc $6)) }
-overlap_pragma :: { Maybe (Located OverlapMode) }
- : '{-# OVERLAPPABLE' '#-}' {% ajs (\_ -> sLL $1 $> (Overlappable (getOVERLAPPABLE_PRAGs $1)))
+overlap_pragma :: { Maybe (LocatedA OverlapMode) }
+ : '{-# OVERLAPPABLE' '#-}' {% fmap Just $ amsr (sLL $1 $> (Overlappable (getOVERLAPPABLE_PRAGs $1)))
[mo $1,mc $2] }
- | '{-# OVERLAPPING' '#-}' {% ajs (\_ -> sLL $1 $> (Overlapping (getOVERLAPPING_PRAGs $1)))
+ | '{-# OVERLAPPING' '#-}' {% fmap Just $ amsr (sLL $1 $> (Overlapping (getOVERLAPPING_PRAGs $1)))
[mo $1,mc $2] }
- | '{-# OVERLAPS' '#-}' {% ajs (\_ -> sLL $1 $> (Overlaps (getOVERLAPS_PRAGs $1)))
+ | '{-# OVERLAPS' '#-}' {% fmap Just $ amsr (sLL $1 $> (Overlaps (getOVERLAPS_PRAGs $1)))
[mo $1,mc $2] }
- | '{-# INCOHERENT' '#-}' {% ajs (\_ -> sLL $1 $> (Incoherent (getINCOHERENT_PRAGs $1)))
+ | '{-# INCOHERENT' '#-}' {% fmap Just $ amsr (sLL $1 $> (Incoherent (getINCOHERENT_PRAGs $1)))
[mo $1,mc $2] }
| {- empty -} { Nothing }
deriv_strategy_no_via :: { LDerivStrategy GhcPs }
- : 'stock' {% ams (\cs -> sL1 $1 (StockStrategy (ApiAnn [mj AnnStock $1] cs)))
- [mj AnnStock $1] }
- | 'anyclass' {% ams (\cs -> sL1 $1 (AnyclassStrategy (ApiAnn [mj AnnAnyclass $1] cs)))
- [mj AnnAnyclass $1] }
- | 'newtype' {% ams (\cs -> sL1 $1 (NewtypeStrategy (ApiAnn [mj AnnNewtype $1] cs)))
- [mj AnnNewtype $1] }
+ : 'stock' {% acs (\cs -> sL1 $1 (StockStrategy (ApiAnn [mj AnnStock $1] cs))) }
+ | 'anyclass' {% acs (\cs -> sL1 $1 (AnyclassStrategy (ApiAnn [mj AnnAnyclass $1] cs))) }
+ | 'newtype' {% acs (\cs -> sL1 $1 (NewtypeStrategy (ApiAnn [mj AnnNewtype $1] cs))) }
deriv_strategy_via :: { LDerivStrategy GhcPs }
- : 'via' type {% ams (\cs -> sLL $1 $> (ViaStrategy (XViaStrategyPs (ApiAnn [mj AnnVia $1] cs)
- (mkLHsSigType $2))))
- [mj AnnVia $1] }
+ : 'via' type {% acs (\cs -> sLL $1 $> (ViaStrategy (XViaStrategyPs (ApiAnn [mj AnnVia $1] cs)
+ (mkLHsSigType $2)))) }
deriv_standalone_strategy :: { Maybe (LDerivStrategy GhcPs) }
- : 'stock' {% ajs (\cs -> sL1 $1 (StockStrategy (ApiAnn [mj AnnStock $1] cs)))
- [mj AnnStock $1] }
- | 'anyclass' {% ajs (\cs -> sL1 $1 (AnyclassStrategy (ApiAnn [mj AnnAnyclass $1] cs)))
- [mj AnnAnyclass $1] }
- | 'newtype' {% ajs (\cs -> sL1 $1 (NewtypeStrategy (ApiAnn [mj AnnNewtype $1] cs)))
- [mj AnnNewtype $1] }
+ : 'stock' {% fmap Just $ acs (\cs -> sL1 $1 (StockStrategy (ApiAnn [mj AnnStock $1] cs))) }
+ | 'anyclass' {% fmap Just $ acs (\cs -> sL1 $1 (AnyclassStrategy (ApiAnn [mj AnnAnyclass $1] cs))) }
+ | 'newtype' {% fmap Just $ acs (\cs -> sL1 $1 (NewtypeStrategy (ApiAnn [mj AnnNewtype $1] cs))) }
| deriv_strategy_via { Just $1 }
| {- empty -} { Nothing }
@@ -1251,8 +1236,7 @@ opt_injective_info :: { Located ([AddApiAnn], Maybe (LInjectivityAnn GhcPs)) }
injectivity_cond :: { LInjectivityAnn GhcPs }
: tyvarid '->' inj_varids
- {% ams (\_ -> sLLAl $1 $> (InjectivityAnn $1 (reverse (unLoc $3))))
- [mu AnnRarrow $2] }
+ {% acs (\cs -> sLLAl $1 $> (InjectivityAnn (ApiAnn [mu AnnRarrow $2] cs) $1 (reverse (unLoc $3)))) }
inj_varids :: { Located [LocatedA RdrName] }
: inj_varids tyvarid { sLLlA $1 $> ($2 : unLoc $1) }
@@ -1278,28 +1262,32 @@ ty_fam_inst_eqn_list :: { Located ([AddApiAnn],Maybe [LTyFamInstEqn GhcPs]) }
ty_fam_inst_eqns :: { Located [LTyFamInstEqn GhcPs] }
: ty_fam_inst_eqns ';' ty_fam_inst_eqn
- {% let (L loc (anns, eqn)) = $3 in
- asl (unLoc $1) $2 (L loc eqn)
- >> ams (\_ -> $3) anns
- >> return (sLL $1 $> (L loc eqn : unLoc $1)) }
- | ty_fam_inst_eqns ';' {% addAnnotation (gl $1) AnnSemi (gl $2)
- >> return (sLL $1 $> (unLoc $1)) }
- | ty_fam_inst_eqn {% let (L loc (anns, eqn)) = $1 in
- ams (\_ -> $1) anns
- >> return (sLL $1 $> [L loc eqn]) }
+ {% let (L loc eqn) = $3 in
+ case unLoc $1 of
+ [] -> return (sLLlA $1 $> (L loc eqn : unLoc $1))
+ (h:t) -> do
+ h' <- addAnnotationA h AnnSemi (gl $2)
+ return (sLLlA $1 $> ($3 : h' : t)) }
+ | ty_fam_inst_eqns ';' {% case unLoc $1 of
+ [] -> return (sLL $1 $> (unLoc $1))
+ (h:t) -> do
+ h' <- addAnnotationA h AnnSemi (gl $2)
+ return (sLL $1 $> (h':t)) }
+ | ty_fam_inst_eqn { sLLAA $1 $> [$1] }
| {- empty -} { noLoc [] }
-ty_fam_inst_eqn :: { Located ([AddApiAnn],TyFamInstEqn GhcPs) }
+ty_fam_inst_eqn :: { LTyFamInstEqn GhcPs }
: 'forall' tv_bndrs '.' type '=' ktype
{% do { hintExplicitForall $1
- ; (eqn,ann) <- mkTyFamInstEqn (Just $2) $4 $6
- ; return (sLL $1 $>
- (mu AnnForall $1:mj AnnDot $3:mj AnnEqual $5:ann,eqn)) } }
+ ; mkTyFamInstEqn (comb2 $1 $>) (Just $2) $4 $6 (mu AnnForall $1:mj AnnDot $3:mj AnnEqual $5:[]) }}
| type '=' ktype
- {% do { (eqn,ann) <- mkTyFamInstEqn Nothing $1 $3
- ; return (sLL $1 $> (mj AnnEqual $2:ann, eqn)) } }
+ -- {% do { (eqn,ann) <- mkTyFamInstEqn Nothing $1 $3
+ -- ; return (sLL $1 $> (mj AnnEqual $2:ann, eqn)) } }
+ {% mkTyFamInstEqn (comb2 $1 $>) Nothing $1 $3 (mj AnnEqual $2:[]) }
-- Note the use of type for the head; this allows
-- infix type constructors and type patterns
+-- AZ working above
+
-- Associated type family declarations
--
@@ -1313,39 +1301,32 @@ ty_fam_inst_eqn :: { Located ([AddApiAnn],TyFamInstEqn GhcPs) }
at_decl_cls :: { LHsDecl GhcPs }
: -- data family declarations, with optional 'family' keyword
'data' opt_family type opt_datafam_kind_sig
- {% amms (liftM mkTyClD (mkFamDecl (comb3 $1 $3 $4) DataFamily $3
+ {% liftM mkTyClD (mkFamDecl (comb3 $1 $3 $4) DataFamily $3
(snd $ unLoc $4) Nothing
- (ApiAnn (mj AnnData $1:$2++(fst $ unLoc $4)) noCom)))
- (mj AnnData $1:$2++(fst $ unLoc $4)) }
+ (mj AnnData $1:$2++(fst $ unLoc $4))) }
-- type family declarations, with optional 'family' keyword
-- (can't use opt_instance because you get shift/reduce errors
| 'type' type opt_at_kind_inj_sig
- {% amms (liftM mkTyClD
+ {% liftM mkTyClD
(mkFamDecl (comb3 $1 $2 $3) OpenTypeFamily $2
(fst . snd $ unLoc $3)
(snd . snd $ unLoc $3)
- (ApiAnn (mj AnnType $1:(fst $ unLoc $3)) noCom)))
- (mj AnnType $1:(fst $ unLoc $3)) }
+ (mj AnnType $1:(fst $ unLoc $3)) )}
| 'type' 'family' type opt_at_kind_inj_sig
- {% amms (liftM mkTyClD
+ {% liftM mkTyClD
(mkFamDecl (comb3 $1 $3 $4) OpenTypeFamily $3
(fst . snd $ unLoc $4)
(snd . snd $ unLoc $4)
- (ApiAnn (mj AnnType $1:mj AnnFamily $2:(fst $ unLoc $4)) noCom)))
- (mj AnnType $1:mj AnnFamily $2:(fst $ unLoc $4)) }
+ (mj AnnType $1:mj AnnFamily $2:(fst $ unLoc $4)))}
-- default type instances, with optional 'instance' keyword
| 'type' ty_fam_inst_eqn
- {% ams (\_ -> $2) (fst $ unLoc $2) >>
- amms (liftM mkInstD (mkTyFamInst (comb2 $1 $2) (snd $ unLoc $2)
- (ApiAnn (mj AnnType $1:(fst $ unLoc $2)) noCom)))
- (mj AnnType $1:(fst $ unLoc $2)) }
+ {% liftM mkInstD (mkTyFamInst (comb2A $1 $2) (unLoc $2)
+ [mj AnnType $1]) }
| 'type' 'instance' ty_fam_inst_eqn
- {% ams (\_ -> $3) (fst $ unLoc $3) >>
- amms (liftM mkInstD (mkTyFamInst (comb2 $1 $3) (snd $ unLoc $3)
- (ApiAnn (mj AnnType $1:mj AnnInstance $2:(fst $ unLoc $3)) noCom)))
- (mj AnnType $1:mj AnnInstance $2:(fst $ unLoc $3)) }
+ {% liftM mkInstD (mkTyFamInst (comb2A $1 $3) (unLoc $3)
+ (mj AnnType $1:mj AnnInstance $2:[]) )}
opt_family :: { [AddApiAnn] }
: {- empty -} { [] }
@@ -1362,27 +1343,23 @@ at_decl_inst :: { LInstDecl GhcPs }
: 'type' opt_instance ty_fam_inst_eqn
-- Note the use of type for the head; this allows
-- infix type constructors and type patterns
- {% ams (\_ -> $3) (fst $ unLoc $3) >>
- amms (mkTyFamInst (comb2 $1 $3) (snd $ unLoc $3)
- (ApiAnn (mj AnnType $1:$2++(fst $ unLoc $3)) noCom))
- (mj AnnType $1:$2++(fst $ unLoc $3)) }
+ {% mkTyFamInst (comb2A $1 $3) (unLoc $3)
+ (mj AnnType $1:$2) }
-- data/newtype instance declaration, with optional 'instance' keyword
| data_or_newtype opt_instance capi_ctype tycl_hdr_inst constrs maybe_derivings
- {% amms (mkDataFamInst (comb4 $1 $4 $5 $6) (snd $ unLoc $1) $3 (snd $ unLoc $4)
+ {% mkDataFamInst (comb4 $1 $4 $5 $6) (snd $ unLoc $1) $3 (snd $ unLoc $4)
Nothing (reverse (snd $ unLoc $5))
(fmap reverse $6)
- (ApiAnn ((fst $ unLoc $1):$2++(fst $ unLoc $4)++(fst $ unLoc $5)) noCom))
- ((fst $ unLoc $1):$2++(fst $ unLoc $4)++(fst $ unLoc $5)) }
+ ((fst $ unLoc $1):$2++(fst $ unLoc $4)++(fst $ unLoc $5)) }
-- GADT instance declaration, with optional 'instance' keyword
| data_or_newtype opt_instance capi_ctype tycl_hdr_inst opt_kind_sig
gadt_constrlist
maybe_derivings
- {% amms (mkDataFamInst (comb4 $1 $4 $6 $7) (snd $ unLoc $1) $3
+ {% mkDataFamInst (comb4 $1 $4 $6 $7) (snd $ unLoc $1) $3
(snd $ unLoc $4) (snd $ unLoc $5) (snd $ unLoc $6)
(fmap reverse $7)
- (ApiAnn ((fst $ unLoc $1):$2++(fst $ unLoc $4)++(fst $ unLoc $5)++(fst $ unLoc $6)) noCom))
((fst $ unLoc $1):$2++(fst $ unLoc $4)++(fst $ unLoc $5)++(fst $ unLoc $6)) }
data_or_newtype :: { Located (AddApiAnn, NewOrData) }
@@ -1684,24 +1661,30 @@ wherebinds :: { Located ([AddApiAnn],Located (HsLocalBinds GhcPs)) }
-----------------------------------------------------------------------------
-- Transformation Rules
-rules :: { OrdList (LRuleDecl GhcPs) }
- : rules ';' rule {% addAnnotation (oll $1) AnnSemi (gl $2)
- >> return ($1 `snocOL` $3) }
- | rules ';' {% addAnnotation (oll $1) AnnSemi (gl $2)
- >> return $1 }
- | rule { unitOL $1 }
- | {- empty -} { nilOL }
+rules :: { [LRuleDecl GhcPs] } -- Reversed
+ : rules ';' rule {% case $1 of
+ [] -> return ($3:$1)
+ (h:t) -> do
+ h' <- addAnnotationA h AnnSemi (gl $2)
+ return ($3:h':t) }
+ | rules ';' {% case $1 of
+ [] -> return $1
+ (h:t) -> do
+ h' <- addAnnotationA h AnnSemi (gl $2)
+ return (h':t) }
+ | rule { [$1] }
+ | {- empty -} { [] }
rule :: { LRuleDecl GhcPs }
: STRING rule_activation rule_foralls infixexp '=' exp
{%runECP_P $4 >>= \ $4 ->
runECP_P $6 >>= \ $6 ->
- ams (\_ -> sLLlA $1 $> $ HsRule { rd_ext = noExtField
+ acsA (\cs -> sLLlA $1 $> $ HsRule
+ { rd_ext = ApiAnn (mj AnnEqual $5 : (fst $2) ++ (fstOf3 $3)) cs
, rd_name = L (gl $1) (getSTRINGs $1, getSTRING $1)
, rd_act = (snd $2) `orElse` AlwaysActive
, rd_tyvs = sndOf3 $3, rd_tmvs = thdOf3 $3
- , rd_lhs = reLoc $4, rd_rhs = reLoc $6 })
- (mj AnnEqual $5 : (fst $2) ++ (fstOf3 $3)) }
+ , rd_lhs = reLoc $4, rd_rhs = reLoc $6 }) }
-- Rules can be specified to be NeverActive, unlike inline/specialize pragmas
rule_activation :: { ([AddApiAnn],Maybe Activation) }
@@ -1844,7 +1827,7 @@ annotation :: { LHsDecl GhcPs }
-----------------------------------------------------------------------------
-- Foreign import and export declarations
-fdecl :: { Located ([AddApiAnn],HsDecl GhcPs) }
+fdecl :: { Located ([AddApiAnn],ApiAnn -> HsDecl GhcPs) }
fdecl : 'import' callconv safety fspec
{% mkImport $2 $3 (snd $ unLoc $4) >>= \i ->
return (sLL $1 $> (mj AnnImport $1 : (fst $ unLoc $4),i)) }
@@ -4166,6 +4149,9 @@ ams a bs = do
cs <- addAnnsAt l bs
return (a cs)
+acsA :: MonadP m => (ApiAnnComments -> Located a) -> m (LocatedA a)
+acsA a = reLocA <$> acs a
+
acs :: MonadP m => (ApiAnnComments -> Located a) -> m (Located a)
acs a = do
let (L l _) = a []
@@ -4178,9 +4164,15 @@ acsExpr a = do { expr :: (LHsExpr GhcPs) <- runPV $ acs a
amsA :: MonadP m => LocatedA a -> [AddApiAnn] -> m (LocatedA a)
-amsA a@(L l _) bs = do
+amsA (L l a) bs = do
cs <- addAnnsAt (locA l) bs
- return a
+ let aa = addAnns (ann l) bs cs
+ return (L (SrcSpanAnn aa (locA l)) a)
+
+reA :: MonadP m => Located a -> LocatedA b -> [AddApiAnn] -> m (LocatedA b)
+reA x y@(L la b) bs = do
+ let l = comb2A x y
+ amsA (L (SrcSpanAnn (ann la) l) b) bs
amsr :: MonadP m => Located a -> [AddApiAnn] -> m (LocatedA a)
amsr a@(L l _) bs = do
@@ -4194,6 +4186,9 @@ amsL sp bs = addAnnsAt sp bs >> return ()
ajs :: MonadP m => (ApiAnnComments -> Located a) -> [AddApiAnn] -> m (Maybe (Located a))
ajs a bs = Just <$> ams a bs
+acsj :: MonadP m => (ApiAnnComments -> Located a) -> m (Maybe (Located a))
+acsj a = Just <$> acs a
+
-- |Add a list of AddApiAnns to the given AST element, where the AST element is the
-- result of a monadic action
amms :: MonadP m => m (Located a) -> [AddApiAnn] -> m (Located a)
@@ -4224,6 +4219,12 @@ amsu a bs = do
cs <- addAnnsAt l bs
return (unitOL (a cs))
+amcsu :: (ApiAnnComments -> Located a) -> P (OrdList (Located a))
+amcsu a = do
+ let (L l _) = a []
+ cs <- addAnnsAt l []
+ return (unitOL (a cs))
+
-- |Synonyms for AddApiAnn versions of AnnOpen and AnnClose
mo,mc :: Located Token -> AddApiAnn
mo ll = mj AnnOpen ll
@@ -4294,4 +4295,9 @@ allocateCommentsS :: SrcSpan -> P [RealLocated AnnotationComment]
allocateCommentsS (RealSrcSpan l _) = allocateCommentsP l
allocateCommentsS _ = return []
+addAnnotationA :: MonadP m => LocatedA a -> AnnKeywordId -> SrcSpan -> m (LocatedA a)
+addAnnotationA (L la a) kw span = do
+ cs <- addAnnsAt (locA la) []
+ let anns' = addAnns (ann la) [AddApiAnn kw span] cs
+ return (L (SrcSpanAnn anns' (locA la)) a)
}
=====================================
compiler/parser/RdrHsSyn.hs
=====================================
@@ -169,7 +169,7 @@ mkClassDecl :: SrcSpan
-> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
-> Located (a,[LHsFunDep GhcPs])
-> OrdList (LHsDecl GhcPs)
- -> ApiAnn
+ -> [AddApiAnn]
-> P (LTyClDecl GhcPs)
mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls annsIn
@@ -179,7 +179,7 @@ mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls annsIn
; cs1 <- addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan
; (tyvars,annst) <- checkTyVars (text "class") whereDots cls tparams
; cs2 <- addAnnsAt loc annst -- Add any API Annotations to the top SrcSpan
- ; let anns' = addAnns annsIn (ann++annst) (cs1 ++ cs2)
+ ; let anns' = addAnns (ApiAnn annsIn []) (ann++annst) (cs1 ++ cs2)
; return (L loc (ClassDecl { tcdCExt = anns', tcdCtxt = cxt
, tcdLName = cls, tcdTyVars = tyvars
, tcdFixity = fixity
@@ -196,7 +196,7 @@ mkTyData :: SrcSpan
-> Maybe (LHsKind GhcPs)
-> [LConDecl GhcPs]
-> HsDeriving GhcPs
- -> ApiAnn
+ -> [AddApiAnn]
-> P (LTyClDecl GhcPs)
mkTyData loc new_or_data cType (L _ (mcxt, tycl_hdr))
ksig data_cons maybe_deriv annsIn
@@ -204,7 +204,7 @@ mkTyData loc new_or_data cType (L _ (mcxt, tycl_hdr))
; cs1 <- addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan [temp]
; (tyvars, anns) <- checkTyVars (ppr new_or_data) equalsDots tc tparams
; cs2 <- addAnnsAt loc anns -- Add any API Annotations to the top SrcSpan [temp]
- ; let anns' = addAnns annsIn (ann ++ anns) (cs1 ++ cs2)
+ ; let anns' = addAnns (ApiAnn annsIn []) (ann ++ anns) (cs1 ++ cs2)
; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
; return (L loc (DataDecl { tcdDExt = anns',
tcdLName = tc, tcdTyVars = tyvars,
@@ -232,14 +232,14 @@ mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
mkTySynonym :: SrcSpan
-> LHsType GhcPs -- LHS
-> LHsType GhcPs -- RHS
- -> ApiAnn
+ -> [AddApiAnn]
-> P (LTyClDecl GhcPs)
mkTySynonym loc lhs rhs annsIn
= do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
; cs1 <- addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan [temp]
; (tyvars, anns) <- checkTyVars (text "type") equalsDots tc tparams
; cs2 <- addAnnsAt loc anns -- Add any API Annotations to the top SrcSpan [temp]
- ; let anns' = addAnns annsIn (ann ++ anns) (cs1 ++ cs2)
+ ; let anns' = addAnns (ApiAnn annsIn []) (ann ++ anns) (cs1 ++ cs2)
; return (L loc (SynDecl { tcdSExt = anns'
, tcdLName = tc, tcdTyVars = tyvars
, tcdFixity = fixity
@@ -249,12 +249,13 @@ mkStandaloneKindSig
:: SrcSpan
-> Located [LocatedA RdrName] -- LHS
-> LHsKind GhcPs -- RHS
- -> ApiAnn
+ -> [AddApiAnn]
-> P (LStandaloneKindSig GhcPs)
mkStandaloneKindSig loc lhs rhs anns =
do { vs <- mapM check_lhs_name (unLoc lhs)
; v <- check_singular_lhs (reverse vs)
- ; return $ L loc $ StandaloneKindSig anns v (mkLHsSigType rhs) }
+ ; cs <- addAnnsAt loc []
+ ; return $ L loc $ StandaloneKindSig (ApiAnn anns cs) v (mkLHsSigType rhs) }
where
check_lhs_name :: LocatedA RdrName -> P (LocatedA RdrName) -- AZ temp
check_lhs_name v@(unLoc->name) =
@@ -272,20 +273,22 @@ mkStandaloneKindSig loc lhs rhs anns =
2 (pprWithCommas ppr vs)
, text "See https://gitlab.haskell.org/ghc/ghc/issues/16754 for details." ]
-mkTyFamInstEqn :: Maybe [LHsTyVarBndr GhcPs]
+mkTyFamInstEqn :: SrcSpan
+ -> Maybe [LHsTyVarBndr GhcPs]
-> LHsType GhcPs
-> LHsType GhcPs
- -> P (TyFamInstEqn GhcPs,[AddApiAnn])
-mkTyFamInstEqn bndrs lhs rhs
+ -> [AddApiAnn]
+ -> P (LTyFamInstEqn GhcPs)
+mkTyFamInstEqn loc bndrs lhs rhs anns
= do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
- ; return (mkHsImplicitBndrs
- (FamEqn { feqn_ext = noExtField
+ ; cs <- addAnnsAt loc []
+ ; return (L (noAnnSrcSpan loc) $ mkHsImplicitBndrs
+ (FamEqn { feqn_ext = ApiAnn anns cs
, feqn_tycon = tc
, feqn_bndrs = bndrs
, feqn_pats = tparams
, feqn_fixity = fixity
- , feqn_rhs = rhs }),
- ann) }
+ , feqn_rhs = rhs })) }
mkDataFamInst :: SrcSpan
-> NewOrData
@@ -295,16 +298,17 @@ mkDataFamInst :: SrcSpan
-> Maybe (LHsKind GhcPs)
-> [LConDecl GhcPs]
-> HsDeriving GhcPs
- -> ApiAnn
+ -> [AddApiAnn]
-> P (LInstDecl GhcPs)
mkDataFamInst loc new_or_data cType (mcxt, bndrs, tycl_hdr)
ksig data_cons maybe_deriv anns
= do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr
; -- AZ:TODO: deal with these comments
- ; _cs <- addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan [temp]
+ ; cs <- addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan [temp]
+ ; let anns' = addAnns (ApiAnn ann cs) anns []
; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
- ; return (L loc (DataFamInstD anns (DataFamInstDecl (mkHsImplicitBndrs
- (FamEqn { feqn_ext = noExtField
+ ; return (L loc (DataFamInstD anns' (DataFamInstDecl (mkHsImplicitBndrs
+ (FamEqn { feqn_ext = noAnn -- AZ: get anns
, feqn_tycon = tc
, feqn_bndrs = bndrs
, feqn_pats = tparams
@@ -313,24 +317,25 @@ mkDataFamInst loc new_or_data cType (mcxt, bndrs, tycl_hdr)
mkTyFamInst :: SrcSpan
-> TyFamInstEqn GhcPs
- -> ApiAnn
+ -> [AddApiAnn]
-> P (LInstDecl GhcPs)
-mkTyFamInst loc eqn anns
- = return (L loc (TyFamInstD anns (TyFamInstDecl eqn)))
+mkTyFamInst loc eqn anns = do
+ cs <- addAnnsAt loc []
+ return (L loc (TyFamInstD (ApiAnn anns cs) (TyFamInstDecl eqn)))
mkFamDecl :: SrcSpan
-> FamilyInfo GhcPs
-> LHsType GhcPs -- LHS
-> Located (FamilyResultSig GhcPs) -- Optional result signature
-> Maybe (LInjectivityAnn GhcPs) -- Injectivity annotation
- -> ApiAnn
+ -> [AddApiAnn]
-> P (LTyClDecl GhcPs)
mkFamDecl loc info lhs ksig injAnn annsIn
= do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
; cs1 <- addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan [temp]
; (tyvars, anns) <- checkTyVars (ppr info) equals_or_where tc tparams
; cs2 <- addAnnsAt loc anns -- Add any API Annotations to the top SrcSpan [temp]
- ; let anns' = addAnns annsIn (ann++anns) (cs1 ++ cs2)
+ ; let anns' = addAnns (ApiAnn annsIn []) (ann++anns) (cs1 ++ cs2)
; return (L loc (FamDecl anns' (FamilyDecl
{ fdExt = noExtField
, fdInfo = info, fdLName = tc
@@ -2699,7 +2704,7 @@ mkInlinePragma src (inl, match_info) mb_act
mkImport :: Located CCallConv
-> Located Safety
-> (Located StringLiteral, LocatedA RdrName, LHsSigType GhcPs)
- -> P (HsDecl GhcPs)
+ -> P (ApiAnn -> HsDecl GhcPs)
mkImport cconv safety (L loc (StringLiteral esrc entity), v, ty) =
case unLoc cconv of
CCallConv -> mkCImport
@@ -2728,8 +2733,8 @@ mkImport cconv safety (L loc (StringLiteral esrc entity), v, ty) =
funcTarget = CFunction (StaticTarget esrc entity' Nothing True)
importSpec = CImport cconv safety Nothing funcTarget (L loc esrc)
- returnSpec spec = return $ ForD noExtField $ ForeignImport
- { fd_i_ext = noExtField
+ returnSpec spec = return $ \ann -> ForD noExtField $ ForeignImport
+ { fd_i_ext = ann
, fd_name = v
, fd_sig_ty = ty
, fd_fi = spec
@@ -2800,10 +2805,10 @@ parseCImport cconv safety nm str sourceText =
--
mkExport :: Located CCallConv
-> (Located StringLiteral, LocatedA RdrName, LHsSigType GhcPs)
- -> P (HsDecl GhcPs)
+ -> P (ApiAnn -> HsDecl GhcPs)
mkExport (L lc cconv) (L le (StringLiteral esrc entity), v, ty)
- = return $ ForD noExtField $
- ForeignExport { fd_e_ext = noExtField, fd_name = v, fd_sig_ty = 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) }
where
@@ -2888,11 +2893,11 @@ mkTypeImpExp name =
text "Illegal keyword 'type' (use ExplicitNamespaces to enable)"
return (fmap (`setRdrNameSpace` tcClsName) name)
-checkImportSpec :: Located [LIE GhcPs] -> P (Located [LIE GhcPs])
+checkImportSpec :: LocatedA [LIE GhcPs] -> P (LocatedA [LIE GhcPs])
checkImportSpec ie@(L _ specs) =
case [l | (L l (IEThingWith _ _ (IEWildcard _) _ _)) <- specs] of
[] -> return ie
- (l:_) -> importSpecError l
+ (l:_) -> importSpecError (locA l)
where
importSpecError l =
addFatalError l
@@ -2982,7 +2987,7 @@ data PV_Context =
data PV_Accum =
PV_Accum
{ pv_messages :: DynFlags -> Messages
- , pv_annotations :: [(ApiAnnKey,[RealSrcSpan])]
+ -- AZ , pv_annotations :: [(ApiAnnKey,[RealSrcSpan])]
, pv_comment_q :: [RealLocated AnnotationComment]
, pv_annotations_comments :: [(RealSrcSpan,[RealLocated AnnotationComment])]
}
@@ -3017,12 +3022,12 @@ runPV_msg msg m =
, pv_hint = msg }
pv_acc = PV_Accum
{ pv_messages = messages s
- , pv_annotations = annotations s
+ -- , pv_annotations = annotations s
, pv_comment_q = comment_q s
, pv_annotations_comments = annotations_comments s }
mkPState acc' =
s { messages = pv_messages acc'
- , annotations = pv_annotations acc'
+ -- AZ , annotations = pv_annotations acc'
, comment_q = pv_comment_q acc'
, annotations_comments = pv_annotations_comments acc' }
in
@@ -3054,10 +3059,12 @@ instance MonadP PV where
let
(comment_q', new_ann_comments) = allocateComments l (pv_comment_q acc)
annotations_comments' = new_ann_comments ++ pv_annotations_comments acc
- annotations' = ((l,a), [v]) : pv_annotations acc
+ -- annotations' = ((l,a), [v]) : pv_annotations acc
acc' = acc
- { pv_annotations = annotations'
- , pv_comment_q = comment_q'
+ {
+ -- AZ pv_annotations = annotations'
+ -- ,
+ pv_comment_q = comment_q'
, pv_annotations_comments = annotations_comments' }
in
PV_Ok acc' ()
=====================================
compiler/typecheck/TcBackpack.hs
=====================================
@@ -166,7 +166,7 @@ checkHsigIface tcg_env gr sig_iface
-- TODO: maybe we can be a little more
-- precise here and use the Located
-- info for the *specific* name we matched.
- -> getLoc e
+ -> getLocA e
_ -> nameSrcSpan name
addErrAt loc
(badReexportedBootThing False name name')
@@ -575,7 +575,7 @@ mergeSignatures
-- a signature package (i.e., does not expose any
-- modules.) If so, we can thin it.
| isFromSignaturePackage
- -> setSrcSpan loc $ do
+ -> setSrcSpan (locA loc) $ do
-- Suppress missing errors; they might be used to refer
-- to entities from other signatures we are merging in.
-- If an identifier truly doesn't exist in any of the
@@ -629,7 +629,7 @@ mergeSignatures
is_mod = mod_name,
is_as = mod_name,
is_qual = False,
- is_dloc = loc
+ is_dloc = locA loc
} ImpAll
rdr_env = mkGlobalRdrEnv (gresFromAvails (Just ispec) as1)
setGblEnv tcg_env {
=====================================
compiler/typecheck/TcHsSyn.hs
=====================================
@@ -1493,7 +1493,7 @@ zonkForeignExport _ for_imp
= return for_imp -- Foreign imports don't need zonking
zonkRules :: ZonkEnv -> [LRuleDecl GhcTcId] -> TcM [LRuleDecl GhcTc]
-zonkRules env rs = mapM (wrapLocM (zonkRule env)) rs
+zonkRules env rs = mapM (wrapLocMA (zonkRule env)) rs
zonkRule :: ZonkEnv -> RuleDecl GhcTcId -> TcM (RuleDecl GhcTc)
zonkRule env rule@(HsRule { rd_tmvs = tm_bndrs{-::[RuleBndr TcId]-}
=====================================
compiler/typecheck/TcInstDcls.hs
=====================================
@@ -572,7 +572,7 @@ tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqn = eqn }))
-- (1) do the work of verifying the synonym group
; co_ax_branch <- tcTyFamInstEqn fam_tc mb_clsinfo
- (L (locA $ getLoc fam_lname) eqn)
+ (L (getLoc fam_lname) eqn)
-- (2) check for validity
=====================================
compiler/typecheck/TcRnDriver.hs
=====================================
@@ -207,7 +207,7 @@ tcRnModuleTcRnM :: HscEnv
tcRnModuleTcRnM hsc_env mod_sum
(HsParsedModule {
hpm_module =
- (L loc (HsModule maybe_mod export_ies
+ (L loc (HsModule _anns maybe_mod export_ies
import_decls local_decls mod_deprec
maybe_doc_hdr)),
hpm_src_files = src_files
@@ -244,9 +244,9 @@ tcRnModuleTcRnM hsc_env mod_sum
$ implicitRequirements hsc_env
(map simplifyImport (prel_imports
++ import_decls))
- ; let { mkImport (Nothing, L _ mod_name) = noLoc
+ ; let { mkImport (Nothing, L _ mod_name) = noLocA
$ (simpleImportDecl mod_name)
- { ideclHiding = Just (False, noLoc [])}
+ { ideclHiding = Just (False, noLocA [])}
; mkImport _ = panic "mkImport" }
; let { all_imports = prel_imports ++ import_decls
++ map mkImport (raw_sig_imports ++ raw_req_imports) }
@@ -396,7 +396,7 @@ tcRnImports hsc_env import_decls
tcRnSrcDecls :: Bool -- False => no 'module M(..) where' header at all
-> [LHsDecl GhcPs] -- Declarations
- -> Maybe (Located [LIE GhcPs])
+ -> Maybe (LocatedA [LIE GhcPs])
-> TcM TcGblEnv
tcRnSrcDecls explicit_mod_hdr decls export_ies
= do { -- Do all the declarations
@@ -1716,7 +1716,7 @@ tcTyClsInstDecls tycl_decls deriv_decls binds
-}
checkMain :: Bool -- False => no 'module M(..) where' header at all
- -> Maybe (Located [LIE GhcPs]) -- Export specs of Main module
+ -> Maybe (LocatedA [LIE GhcPs]) -- Export specs of Main module
-> TcM TcGblEnv
-- If we are in module Main, check that 'main' is defined and exported.
checkMain explicit_mod_hdr export_ies
@@ -1724,7 +1724,7 @@ checkMain explicit_mod_hdr export_ies
; tcg_env <- getGblEnv
; check_main dflags tcg_env explicit_mod_hdr export_ies }
-check_main :: DynFlags -> TcGblEnv -> Bool -> Maybe (Located [LIE GhcPs])
+check_main :: DynFlags -> TcGblEnv -> Bool -> Maybe (LocatedA [LIE GhcPs])
-> TcM TcGblEnv
check_main dflags tcg_env explicit_mod_hdr export_ies
| mod /= main_mod
@@ -1834,7 +1834,7 @@ check_main dflags tcg_env explicit_mod_hdr export_ies
-- Select the main functions from the export list.
-- Only the module name is needed, the function name is fixed.
- selExportMains :: Maybe (Located [LIE GhcPs]) -> [ModuleName] -- #16453
+ selExportMains :: Maybe (LocatedA [LIE GhcPs]) -> [ModuleName] -- #16453
selExportMains Nothing = [main_mod_nm]
-- no main specified, but there is a header.
selExportMains (Just exps) = fmap fst $
=====================================
compiler/typecheck/TcRnExports.hs
=====================================
@@ -152,7 +152,7 @@ type ExportOccMap = OccEnv (Name, IE GhcPs)
-- that have the same occurrence name
tcRnExports :: Bool -- False => no 'module M(..) where' header at all
- -> Maybe (Located [LIE GhcPs]) -- Nothing => no explicit export list
+ -> Maybe (LocatedA [LIE GhcPs]) -- Nothing => no explicit export list
-> TcGblEnv
-> RnM TcGblEnv
@@ -184,7 +184,7 @@ tcRnExports explicit_mod exports
; let real_exports
| explicit_mod = exports
| has_main
- = Just (noLoc [noLoc (IEVar noAnn
+ = Just (noLocA [noLocA (IEVar noAnn
(noLoc (IEName $ noLocA default_main)))])
-- ToDo: the 'noLoc' here is unhelpful if 'main'
-- turns out to be out of scope
@@ -212,7 +212,7 @@ tcRnExports explicit_mod exports
; failIfErrsM
; return new_tcg_env }
-exports_from_avail :: Maybe (Located [LIE GhcPs])
+exports_from_avail :: Maybe (LocatedA [LIE GhcPs])
-- ^ 'Nothing' means no explicit export list
-> GlobalRdrEnv
-> ImportAvails
@@ -262,7 +262,7 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
where
do_litem :: ExportAccum -> LIE GhcPs
-> RnM (Maybe (ExportAccum, (LIE GhcRn, Avails)))
- do_litem acc lie = setSrcSpan (getLoc lie) (exports_from_item acc lie)
+ do_litem acc lie = setSrcSpan (getLocA lie) (exports_from_item acc lie)
-- Maps a parent to its in-scope children
kids_env :: NameEnv [GlobalRdrElt]
=====================================
compiler/typecheck/TcRnMonad.hs
=====================================
@@ -60,7 +60,7 @@ module TcRnMonad(
-- * Error management
getSrcSpanM, setSrcSpan, addLocM, addLocMA,
- wrapLocM, wrapLocFstM, wrapLocSndM,wrapLocM_,wrapLocMA,
+ wrapLocM, wrapLocFstM, wrapLocFstMA, wrapLocSndM,wrapLocM_,wrapLocMA,
getErrsVar, setErrsVar,
addErr,
failWith, failAt,
@@ -851,6 +851,12 @@ wrapLocFstM fn (L loc a) =
(b,c) <- fn a
return (L loc b, c)
+wrapLocFstMA :: (a -> TcM (b,c)) -> LocatedA a -> TcM (LocatedA b, c)
+wrapLocFstMA fn (L loc a) =
+ setSrcSpan (locA loc) $ do
+ (b,c) <- fn a
+ return (L loc b, c)
+
wrapLocSndM :: (a -> TcM (b, c)) -> Located a -> TcM (b, Located c)
wrapLocSndM fn (L loc a) =
setSrcSpan loc $ do
=====================================
compiler/typecheck/TcRnTypes.hs
=====================================
@@ -509,7 +509,7 @@ data TcGblEnv
-- The binds, rules and foreign-decl fields are collected
-- initially in un-zonked form and are finally zonked in tcRnSrcDecls
- tcg_rn_exports :: Maybe [(Located (IE GhcRn), Avails)],
+ tcg_rn_exports :: Maybe [(LIE GhcRn, Avails)],
-- Nothing <=> no explicit export list
-- Is always Nothing if we don't want to retain renamed
-- exports.
=====================================
compiler/typecheck/TcRules.hs
=====================================
@@ -105,7 +105,7 @@ tcRules decls = mapM (wrapLocM tcRuleDecls) decls
tcRuleDecls :: RuleDecls GhcRn -> TcM (RuleDecls GhcTcId)
tcRuleDecls (HsRules { rds_src = src
, rds_rules = decls })
- = do { tc_decls <- mapM (wrapLocM tcRule) decls
+ = do { tc_decls <- mapM (wrapLocMA tcRule) decls
; return $ HsRules { rds_ext = noExtField
, rds_src = src
, rds_rules = tc_decls } }
=====================================
compiler/typecheck/TcTyClsDecls.hs
=====================================
@@ -2620,7 +2620,7 @@ tcInjectivity _ Nothing
-- therefore we can always infer the result kind if we know the result type.
-- But this does not seem to be useful in any way so we don't do it. (Another
-- reason is that the implementation would not be straightforward.)
-tcInjectivity tcbs (Just (L loc (InjectivityAnn _ lInjNames)))
+tcInjectivity tcbs (Just (L loc (InjectivityAnn _ _ lInjNames)))
= setSrcSpan loc $
do { let tvs = binderVars tcbs
; dflags <- getDynFlags
@@ -2751,7 +2751,7 @@ kcTyFamInstEqn tc_fam_tc
, feqn_bndrs = mb_expl_bndrs
, feqn_pats = hs_pats
, feqn_rhs = hs_rhs_ty }}))
- = setSrcSpan loc $
+ = setSrcSpan (locA loc) $
do { traceTc "kcTyFamInstEqn" (vcat
[ text "tc_name =" <+> ppr eqn_tc_name
, text "fam_tc =" <+> ppr tc_fam_tc <+> dcolon <+> ppr (tyConKind tc_fam_tc)
@@ -2793,7 +2793,7 @@ tcTyFamInstEqn fam_tc mb_clsinfo
, feqn_pats = hs_pats
, feqn_rhs = hs_rhs_ty }}))
= ASSERT( getName fam_tc == eqn_tc_name )
- setSrcSpan loc $
+ setSrcSpan (locA loc) $
do { traceTc "tcTyFamInstEqn" $
vcat [ ppr fam_tc <+> ppr hs_pats
, text "fam tc bndrs" <+> pprTyVars (tyConTyVars fam_tc)
@@ -2815,7 +2815,7 @@ tcTyFamInstEqn fam_tc mb_clsinfo
-- (tcFamInstEqnGuts zonks to Type)
; return (mkCoAxBranch qtvs [] [] fam_tc pats rhs_ty
(map (const Nominal) qtvs)
- loc) }
+ (locA loc)) }
tcTyFamInstEqn _ _ _ = panic "tcTyFamInstEqn"
=====================================
compiler/utils/OrdList.hs
=====================================
@@ -16,6 +16,7 @@ module OrdList (
OrdList,
nilOL, isNilOL, unitOL, appOL, consOL, snocOL, concatOL, lastOL,
headOL,
+ initOL, tailOL, unsnocOL, unconsOL,
mapOL, fromOL, toOL, foldrOL, foldlOL, reverseOL, fromOLReverse,
strictlyEqOL, strictlyOrdOL
) where
@@ -73,6 +74,10 @@ concatOL :: [OrdList a] -> OrdList a
headOL :: OrdList a -> a
lastOL :: OrdList a -> a
lengthOL :: OrdList a -> Int
+initOL :: OrdList a -> OrdList a
+tailOL :: OrdList a -> OrdList a
+unsnocOL :: OrdList a -> (OrdList a, a)
+unconsOL :: OrdList a -> (a, OrdList a)
nilOL = None
unitOL as = One as
@@ -94,6 +99,36 @@ lastOL (Cons _ as) = lastOL as
lastOL (Snoc _ a) = a
lastOL (Two _ as) = lastOL as
+initOL None = panic "initOL"
+initOL (One _) = None
+initOL (Many [_]) = None
+initOL (Many as) = Many (init as)
+initOL (Cons a (Many [_])) = One a
+initOL (Cons a (One _)) = One a
+initOL (Cons a as) = Cons a (initOL as)
+initOL (Snoc as _) = as
+initOL (Two as (Many [_])) = as
+initOL (Two as (One _)) = as
+initOL (Two as bs) = Two as (initOL bs)
+
+tailOL None = panic "initOL"
+tailOL (One _) = None
+tailOL (Many [_]) = None
+tailOL (Many as) = Many (tail as)
+tailOL (Cons _ as) = as
+tailOL (Snoc (Many [_]) b) = One b
+tailOL (Snoc (One _) b) = One b
+tailOL (Snoc as b) = Snoc (tailOL as) b
+tailOL (Two (Many [_]) bs) = bs
+tailOL (Two (One _) bs) = bs
+tailOL (Two as bs) = Two (tailOL as) bs
+
+unconsOL None = panic "unconsOL"
+unconsOL as = (headOL as, tailOL as)
+
+unsnocOL None = panic "unsnocOL"
+unsnocOL as = (initOL as, lastOL as)
+
lengthOL None = 0
lengthOL (One _) = 1
lengthOL (Many as) = length as
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/069d05b4de11e34da562fe63ac451f990743d504
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/069d05b4de11e34da562fe63ac451f990743d504
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200401/5f253dd3/attachment-0001.html>
More information about the ghc-commits
mailing list