diff options
Diffstat (limited to 'compiler/GHC/Parser/PostProcess.hs')
| -rw-r--r-- | compiler/GHC/Parser/PostProcess.hs | 1352 |
1 files changed, 801 insertions, 551 deletions
diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs index 6a0f86aefe..9bf87b2e8b 100644 --- a/compiler/GHC/Parser/PostProcess.hs +++ b/compiler/GHC/Parser/PostProcess.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} @@ -34,6 +35,7 @@ module GHC.Parser.PostProcess ( mkRdrRecordCon, mkRdrRecordUpd, setRdrNameSpace, fromSpecTyVarBndr, fromSpecTyVarBndrs, + annBinds, cvBindGroup, cvBindsAndSigs, @@ -45,7 +47,7 @@ module GHC.Parser.PostProcess ( parseCImport, mkExport, mkExtName, -- RdrName -> CLabelString - mkGadtDecl, -- [Located RdrName] -> LHsType RdrName -> ConDecl RdrName + mkGadtDecl, -- [LocatedA RdrName] -> LHsType RdrName -> ConDecl RdrName mkConDeclH98, -- Bunch of functions in the parser monad for @@ -109,7 +111,7 @@ module GHC.Parser.PostProcess ( import GHC.Prelude import GHC.Hs -- Lots of it import GHC.Core.TyCon ( TyCon, isTupleTyCon, tyConSingleDataCon_maybe ) -import GHC.Core.DataCon ( DataCon, dataConTyCon, FieldLabelString ) +import GHC.Core.DataCon ( DataCon, dataConTyCon ) import GHC.Core.ConLike ( ConLike(..) ) import GHC.Core.Coercion.Axiom ( Role, fsFromRole ) import GHC.Types.Name.Reader @@ -136,11 +138,11 @@ import GHC.Data.FastString import GHC.Data.Maybe import GHC.Data.Bag import GHC.Utils.Misc -import GHC.Parser.Annotation import Data.Either import Data.List import Data.Foldable import GHC.Driver.Flags ( WarningFlag(..) ) +import qualified Data.Semigroup as Semi import GHC.Utils.Panic import Control.Monad @@ -178,17 +180,18 @@ mkClassDecl :: SrcSpan -> Located (a,[LHsFunDep GhcPs]) -> OrdList (LHsDecl GhcPs) -> LayoutInfo + -> [AddApiAnn] -> P (LTyClDecl GhcPs) -mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls layoutInfo - = do { (binds, sigs, ats, at_defs, _, docs) <- cvBindsAndSigs where_cls - ; let cxt = mcxt +mkClassDecl loc' (L _ (mcxt, tycl_hdr)) fds where_cls layoutInfo annsIn + = do { let loc = noAnnSrcSpan loc' + ; (binds, sigs, ats, at_defs, _, docs) <- cvBindsAndSigs where_cls ; (cls, tparams, fixity, ann) <- checkTyClHdr True tycl_hdr - ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan ; (tyvars,annst) <- checkTyVars (text "class") whereDots cls tparams - ; addAnnsAt loc annst -- Add any API Annotations to the top SrcSpan - ; return (L loc (ClassDecl { tcdCExt = layoutInfo - , tcdCtxt = cxt + ; cs <- getCommentsFor (locA loc) -- Get any remaining comments + ; let anns' = addAnns (ApiAnn (spanAsAnchor $ locA loc) annsIn noCom) (ann++annst) cs + ; return (L loc (ClassDecl { tcdCExt = (anns', NoAnnSortKey, layoutInfo) + , tcdCtxt = mcxt , tcdLName = cls, tcdTyVars = tyvars , tcdFixity = fixity , tcdFDs = snd (unLoc fds) @@ -199,34 +202,37 @@ mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls layoutInfo mkTyData :: SrcSpan -> NewOrData - -> Maybe (Located CType) + -> Maybe (LocatedP CType) -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs) -> Maybe (LHsKind GhcPs) -> [LConDecl GhcPs] - -> HsDeriving GhcPs + -> Located (HsDeriving GhcPs) + -> [AddApiAnn] -> P (LTyClDecl GhcPs) -mkTyData loc new_or_data cType (L _ (mcxt, tycl_hdr)) - ksig data_cons maybe_deriv - = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr - ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan +mkTyData loc' new_or_data cType (L _ (mcxt, tycl_hdr)) + ksig data_cons (L _ maybe_deriv) annsIn + = do { let loc = noAnnSrcSpan loc' + ; (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr ; (tyvars, anns) <- checkTyVars (ppr new_or_data) equalsDots tc tparams - ; addAnnsAt loc anns -- Add any API Annotations to the top SrcSpan - ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv - ; return (L loc (DataDecl { tcdDExt = noExtField, + ; cs <- getCommentsFor (locA loc) -- Get any remaining comments + ; let anns' = addAnns (ApiAnn (spanAsAnchor $ locA loc) annsIn noCom) (ann ++ anns) cs + ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv anns' + ; return (L loc (DataDecl { tcdDExt = anns', -- AZ: do we need these? tcdLName = tc, tcdTyVars = tyvars, tcdFixity = fixity, tcdDataDefn = defn })) } mkDataDefn :: NewOrData - -> Maybe (Located CType) + -> Maybe (LocatedP CType) -> Maybe (LHsContext GhcPs) -> Maybe (LHsKind GhcPs) -> [LConDecl GhcPs] -> HsDeriving GhcPs + -> ApiAnn -> P (HsDataDefn GhcPs) -mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv +mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv ann = do { checkDatatypeContext mcxt - ; return (HsDataDefn { dd_ext = noExtField + ; return (HsDataDefn { dd_ext = ann , dd_ND = new_or_data, dd_cType = cType , dd_ctxt = mcxt , dd_cons = data_cons @@ -237,67 +243,79 @@ mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv mkTySynonym :: SrcSpan -> LHsType GhcPs -- LHS -> LHsType GhcPs -- RHS + -> [AddApiAnn] -> P (LTyClDecl GhcPs) -mkTySynonym loc lhs rhs +mkTySynonym loc lhs rhs annsIn = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs - ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan + ; cs1 <- getCommentsFor loc -- Add any API Annotations to the top SrcSpan [temp] ; (tyvars, anns) <- checkTyVars (text "type") equalsDots tc tparams - ; addAnnsAt loc anns -- Add any API Annotations to the top SrcSpan - ; return (L loc (SynDecl { tcdSExt = noExtField + ; cs2 <- getCommentsFor loc -- Add any API Annotations to the top SrcSpan [temp] + ; let anns' = addAnns (ApiAnn (spanAsAnchor loc) annsIn noCom) (ann ++ anns) (cs1 Semi.<> cs2) + ; return (L (noAnnSrcSpan loc) (SynDecl + { tcdSExt = anns' , tcdLName = tc, tcdTyVars = tyvars , tcdFixity = fixity , tcdRhs = rhs })) } mkStandaloneKindSig :: SrcSpan - -> Located [Located RdrName] -- LHS - -> LHsSigType GhcPs -- RHS + -> Located [LocatedN RdrName] -- LHS + -> LHsSigType GhcPs -- RHS + -> [AddApiAnn] -> P (LStandaloneKindSig GhcPs) -mkStandaloneKindSig loc lhs rhs = +mkStandaloneKindSig loc lhs rhs anns = do { vs <- mapM check_lhs_name (unLoc lhs) ; v <- check_singular_lhs (reverse vs) - ; return $ L loc $ StandaloneKindSig noExtField v rhs } + ; cs <- getCommentsFor loc + ; return $ L (noAnnSrcSpan loc) + $ StandaloneKindSig (ApiAnn (spanAsAnchor loc) anns cs) v rhs } where check_lhs_name v@(unLoc->name) = if isUnqual name && isTcOcc (rdrNameOcc name) then return v - else addFatalError $ PsError (PsErrUnexpectedQualifiedConstructor (unLoc v)) [] (getLoc v) + else addFatalError $ PsError (PsErrUnexpectedQualifiedConstructor (unLoc v)) [] (getLocA v) check_singular_lhs vs = case vs of [] -> panic "mkStandaloneKindSig: empty left-hand side" [v] -> return v _ -> addFatalError $ PsError (PsErrMultipleNamesInStandaloneKindSignature vs) [] (getLoc lhs) -mkTyFamInstEqn :: HsOuterFamEqnTyVarBndrs GhcPs +mkTyFamInstEqn :: SrcSpan + -> HsOuterFamEqnTyVarBndrs GhcPs -> LHsType GhcPs -> LHsType GhcPs - -> P (TyFamInstEqn GhcPs,[AddAnn]) -mkTyFamInstEqn bndrs lhs rhs + -> [AddApiAnn] + -> P (LTyFamInstEqn GhcPs) +mkTyFamInstEqn loc bndrs lhs rhs anns = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs - ; return (FamEqn { feqn_ext = noExtField + ; cs <- getCommentsFor loc + ; return (L (noAnnSrcSpan loc) $ FamEqn + { feqn_ext = ApiAnn (spanAsAnchor loc) (anns `mappend` ann) cs , feqn_tycon = tc , feqn_bndrs = bndrs , feqn_pats = tparams , feqn_fixity = fixity - , feqn_rhs = rhs }, - ann) } + , feqn_rhs = rhs })} mkDataFamInst :: SrcSpan -> NewOrData - -> Maybe (Located CType) + -> Maybe (LocatedP CType) -> (Maybe ( LHsContext GhcPs), HsOuterFamEqnTyVarBndrs GhcPs , LHsType GhcPs) -> Maybe (LHsKind GhcPs) -> [LConDecl GhcPs] - -> HsDeriving GhcPs + -> Located (HsDeriving GhcPs) + -> [AddApiAnn] -> P (LInstDecl GhcPs) mkDataFamInst loc new_or_data cType (mcxt, bndrs, tycl_hdr) - ksig data_cons maybe_deriv + ksig data_cons (L _ maybe_deriv) anns = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr - ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan - ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv - ; return (L loc (DataFamInstD noExtField (DataFamInstDecl - (FamEqn { feqn_ext = noExtField + ; -- AZ:TODO: deal with these comments + ; cs <- getCommentsFor loc -- Add any API Annotations to the top SrcSpan [temp] + ; let anns' = addAnns (ApiAnn (spanAsAnchor loc) ann cs) anns noCom + ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv anns' + ; return (L (noAnnSrcSpan loc) (DataFamInstD anns' (DataFamInstDecl + (FamEqn { feqn_ext = noAnn -- AZ: get anns , feqn_tycon = tc , feqn_bndrs = bndrs , feqn_pats = tparams @@ -306,23 +324,31 @@ mkDataFamInst loc new_or_data cType (mcxt, bndrs, tycl_hdr) mkTyFamInst :: SrcSpan -> TyFamInstEqn GhcPs + -> [AddApiAnn] -> P (LInstDecl GhcPs) -mkTyFamInst loc eqn - = return (L loc (TyFamInstD noExtField (TyFamInstDecl eqn))) +mkTyFamInst loc eqn anns = do + cs <- getCommentsFor loc + return (L (noAnnSrcSpan loc) (TyFamInstD noExtField + (TyFamInstDecl (ApiAnn (spanAsAnchor loc) anns cs) eqn))) mkFamDecl :: SrcSpan -> FamilyInfo GhcPs + -> TopLevelFlag -> LHsType GhcPs -- LHS -> Located (FamilyResultSig GhcPs) -- Optional result signature -> Maybe (LInjectivityAnn GhcPs) -- Injectivity annotation + -> [AddApiAnn] -> P (LTyClDecl GhcPs) -mkFamDecl loc info lhs ksig injAnn +mkFamDecl loc info topLevel lhs ksig injAnn annsIn = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs - ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan + ; cs1 <- getCommentsFor loc -- Add any API Annotations to the top SrcSpan [temp] ; (tyvars, anns) <- checkTyVars (ppr info) equals_or_where tc tparams - ; addAnnsAt loc anns -- Add any API Annotations to the top SrcSpan - ; return (L loc (FamDecl noExtField (FamilyDecl - { fdExt = noExtField + ; cs2 <- getCommentsFor loc -- Add any API Annotations to the top SrcSpan [temp] + ; let anns' = addAnns (ApiAnn (spanAsAnchor loc) annsIn noCom) (ann++anns) (cs1 Semi.<> cs2) + ; return (L (noAnnSrcSpan loc) (FamDecl noExtField + (FamilyDecl + { fdExt = anns' + , fdTopLevel = topLevel , fdInfo = info, fdLName = tc , fdTyVars = tyvars , fdFixity = fixity @@ -334,7 +360,7 @@ mkFamDecl loc info lhs ksig injAnn OpenTypeFamily -> empty ClosedTypeFamily {} -> whereDots -mkSpliceDecl :: LHsExpr GhcPs -> HsDecl GhcPs +mkSpliceDecl :: LHsExpr GhcPs -> P (LHsDecl GhcPs) -- If the user wrote -- [pads| ... ] then return a QuasiQuoteD -- $(e) then return a SpliceD @@ -345,23 +371,30 @@ mkSpliceDecl :: LHsExpr GhcPs -> HsDecl GhcPs -- Typed splices are not allowed at the top level, thus we do not represent them -- as spliced declaration. See #10945 mkSpliceDecl lexpr@(L loc expr) - | HsSpliceE _ splice@(HsUntypedSplice {}) <- expr - = SpliceD noExtField (SpliceDecl noExtField (L loc splice) ExplicitSplice) + | HsSpliceE _ splice@(HsUntypedSplice {}) <- expr = do + cs <- getCommentsFor (locA loc) + return $ L (addCommentsToSrcAnn loc cs) $ SpliceD noExtField (SpliceDecl noExtField (L loc splice) ExplicitSplice) - | HsSpliceE _ splice@(HsQuasiQuote {}) <- expr - = SpliceD noExtField (SpliceDecl noExtField (L loc splice) ExplicitSplice) + | HsSpliceE _ splice@(HsQuasiQuote {}) <- expr = do + cs <- getCommentsFor (locA loc) + return $ L (addCommentsToSrcAnn loc cs) $ SpliceD noExtField (SpliceDecl noExtField (L loc splice) ExplicitSplice) - | otherwise - = SpliceD noExtField (SpliceDecl noExtField (L loc (mkUntypedSplice BareSplice lexpr)) - ImplicitSplice) + | otherwise = do + cs <- getCommentsFor (locA loc) + return $ L (addCommentsToSrcAnn loc cs) $ SpliceD noExtField (SpliceDecl noExtField + (L loc (mkUntypedSplice noAnn BareSplice lexpr)) + ImplicitSplice) mkRoleAnnotDecl :: SrcSpan - -> Located RdrName -- type being annotated - -> [Located (Maybe FastString)] -- roles + -> LocatedN RdrName -- type being annotated + -> [Located (Maybe FastString)] -- roles + -> [AddApiAnn] -> P (LRoleAnnotDecl GhcPs) -mkRoleAnnotDecl loc tycon roles +mkRoleAnnotDecl loc tycon roles anns = do { roles' <- mapM parse_role roles - ; return $ L loc $ RoleAnnotDecl noExtField tycon roles' } + ; cs <- getCommentsFor loc + ; return $ L (noAnnSrcSpan loc) + $ RoleAnnotDecl (ApiAnn (spanAsAnchor loc) anns cs) tycon roles' } where role_data_type = dataTypeOf (undefined :: Role) all_roles = map fromConstr $ dataTypeConstrs role_data_type @@ -393,9 +426,37 @@ fromSpecTyVarBndr bndr = case bndr of (L loc (KindedTyVar xtv flag idp k)) -> (check_spec flag loc) >> return (L loc $ KindedTyVar xtv () idp k) where - check_spec :: Specificity -> SrcSpan -> P () + check_spec :: Specificity -> SrcSpanAnnA -> P () check_spec SpecifiedSpec _ = return () - check_spec InferredSpec loc = addFatalError $ PsError PsErrInferredTypeVarNotAllowed [] loc + check_spec InferredSpec loc = addFatalError $ PsError PsErrInferredTypeVarNotAllowed [] (locA loc) + +-- | Add the annotation for a 'where' keyword to existing @HsLocalBinds@ +annBinds :: AddApiAnn -> HsLocalBinds GhcPs -> HsLocalBinds GhcPs +annBinds a (HsValBinds an bs) = (HsValBinds (add_where a an) bs) +annBinds a (HsIPBinds an bs) = (HsIPBinds (add_where a an) bs) +annBinds _ (EmptyLocalBinds x) = (EmptyLocalBinds x) + +add_where :: AddApiAnn -> ApiAnn' AnnList -> ApiAnn' AnnList +add_where an@(AddApiAnn _ (AR rs)) (ApiAnn a (AnnList anc o c r t) cs) + | valid_anchor (anchor a) + = ApiAnn (widenAnchor a [an]) (AnnList anc o c (an:r) t) cs + | otherwise + = ApiAnn (patch_anchor rs a) (AnnList (fmap (patch_anchor rs) anc) o c (an:r) t) cs +add_where an@(AddApiAnn _ (AR rs)) ApiAnnNotUsed + = ApiAnn (Anchor rs UnchangedAnchor) + (AnnList (Just $ Anchor rs UnchangedAnchor) Nothing Nothing [an] []) noCom +add_where (AddApiAnn _ (AD _)) _ = panic "add_where" + -- AD should only be used for transformations + +valid_anchor :: RealSrcSpan -> Bool +valid_anchor r = srcSpanStartLine r >= 0 + +-- If the decl list for where binds is empty, the anchor ends up +-- invalid. In this case, use the parent one +patch_anchor :: RealSrcSpan -> Anchor -> Anchor +patch_anchor r1 (Anchor r0 op) = Anchor r op + where + r = if srcSpanStartLine r0 < 0 then r1 else r0 {- ********************************************************************** @@ -418,11 +479,11 @@ cvBindGroup binding = do { (mbs, sigs, fam_ds, tfam_insts , dfam_insts, _) <- cvBindsAndSigs binding ; ASSERT( null fam_ds && null tfam_insts && null dfam_insts) - return $ ValBinds noExtField mbs sigs } + return $ ValBinds NoAnnSortKey mbs sigs } cvBindsAndSigs :: OrdList (LHsDecl GhcPs) -> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs] - , [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl]) + , [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl GhcPs]) -- Input decls contain just value bindings and signatures -- and in case of class or instance declarations also -- associated type declarations. They might also contain Haddock comments. @@ -446,7 +507,7 @@ cvBindsAndSigs fb = do -- called on top-level declarations. drop_bad_decls [] = return [] drop_bad_decls (L l (SpliceD _ d) : ds) = do - addError $ PsError (PsErrDeclSpliceNotAtTopLevel d) [] l + addError $ PsError (PsErrDeclSpliceNotAtTopLevel d) [] (locA l) drop_bad_decls ds drop_bad_decls (d:ds) = (d:) <$> drop_bad_decls ds @@ -475,18 +536,25 @@ getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1) | has_args mtchs1 = go mtchs1 loc1 binds [] where + -- TODO:AZ may have to preserve annotations. Although they should + -- only be AnnSemi, and meaningless in this context? + go :: [LMatch GhcPs (LHsExpr GhcPs)] -> SrcSpanAnnA + -> [LHsDecl GhcPs] -> [LHsDecl GhcPs] + -> (LHsBind GhcPs,[LHsDecl GhcPs]) -- AZ go mtchs loc ((L loc2 (ValD _ (FunBind { fun_id = (L _ f2) , fun_matches = - MG { mg_alts = (L _ mtchs2) } }))) + MG { mg_alts = (L _ [L lm2 mtchs2]) } }))) : binds) _ - | f1 == f2 = go (mtchs2 ++ mtchs) - (combineSrcSpans loc loc2) binds [] + | f1 == f2 = + let (loc2', lm2') = transferComments loc2 lm2 + in go (L lm2' mtchs2 : mtchs) + (combineSrcSpansA loc loc2') binds [] go mtchs loc (doc_decl@(L loc2 (DocD {})) : binds) doc_decls = let doc_decls' = doc_decl : doc_decls - in go mtchs (combineSrcSpans loc loc2) binds doc_decls' + in go mtchs (combineSrcSpansA loc loc2) binds doc_decls' go mtchs loc binds doc_decls - = ( L loc (makeFunBind fun_id1 (reverse mtchs)) + = ( L loc (makeFunBind fun_id1 (mkLocatedList $ reverse mtchs)) , (reverse doc_decls) ++ binds) -- Reverse the final matches, to get it back in the right order -- Do the same thing with the trailing doc comments @@ -551,32 +619,33 @@ constructor, a type, or a context, we would need unlimited lookahead which -- | Reinterpret a type constructor, including type operators, as a data -- constructor. -- See Note [Parsing data constructors is hard] -tyConToDataCon :: SrcSpan -> RdrName -> Either PsError (Located RdrName) -tyConToDataCon loc tc +tyConToDataCon :: LocatedN RdrName -> Either PsError (LocatedN RdrName) +tyConToDataCon (L loc tc) | isTcOcc occ || isDataOcc occ , isLexCon (occNameFS occ) = return (L loc (setRdrNameSpace tc srcDataName)) | otherwise - = Left $ PsError (PsErrNotADataCon tc) [] loc + = Left $ PsError (PsErrNotADataCon tc) [] (locA loc) where occ = rdrNameOcc tc -mkPatSynMatchGroup :: Located RdrName - -> Located (OrdList (LHsDecl GhcPs)) +mkPatSynMatchGroup :: LocatedN RdrName + -> LocatedL (OrdList (LHsDecl GhcPs)) -> P (MatchGroup GhcPs (LHsExpr GhcPs)) -mkPatSynMatchGroup (L loc patsyn_name) (L _ decls) = +mkPatSynMatchGroup (L loc patsyn_name) (L ld decls) = do { matches <- mapM fromDecl (fromOL decls) - ; when (null matches) (wrongNumberErr loc) - ; return $ mkMatchGroup FromSource matches } + ; when (null matches) (wrongNumberErr (locA loc)) + ; return $ mkMatchGroup FromSource (L ld matches) } where fromDecl (L loc decl@(ValD _ (PatBind _ - pat@(L _ (ConPat NoExtField ln@(L _ name) details)) + -- AZ: where should these anns come from? + pat@(L _ (ConPat noAnn ln@(L _ name) details)) rhs _))) = do { unless (name == patsyn_name) $ - wrongNameBindingErr loc decl + wrongNameBindingErr (locA loc) decl ; match <- case details of - PrefixCon _ pats -> return $ Match { m_ext = noExtField + PrefixCon _ pats -> return $ Match { m_ext = noAnn , m_ctxt = ctxt, m_pats = pats , m_grhss = rhs } where @@ -584,7 +653,7 @@ mkPatSynMatchGroup (L loc patsyn_name) (L _ decls) = , mc_fixity = Prefix , mc_strictness = NoSrcStrict } - InfixCon p1 p2 -> return $ Match { m_ext = noExtField + InfixCon p1 p2 -> return $ Match { m_ext = noAnn , m_ctxt = ctxt , m_pats = [p1, p2] , m_grhss = rhs } @@ -593,9 +662,9 @@ mkPatSynMatchGroup (L loc patsyn_name) (L _ decls) = , mc_fixity = Infix , mc_strictness = NoSrcStrict } - RecCon{} -> recordPatSynErr loc pat + RecCon{} -> recordPatSynErr (locA loc) pat ; return $ L loc match } - fromDecl (L loc decl) = extraDeclErr loc decl + fromDecl (L loc decl) = extraDeclErr (locA loc) decl extraDeclErr loc decl = addFatalError $ PsError (PsErrNoSingleWhereBindInPatSynDecl patsyn_name decl) [] loc @@ -610,14 +679,14 @@ recordPatSynErr :: SrcSpan -> LPat GhcPs -> P a recordPatSynErr loc pat = addFatalError $ PsError (PsErrRecordSyntaxInPatSynDecl pat) [] loc -mkConDeclH98 :: Located RdrName -> Maybe [LHsTyVarBndr Specificity GhcPs] +mkConDeclH98 :: ApiAnn -> LocatedN RdrName -> Maybe [LHsTyVarBndr Specificity GhcPs] -> Maybe (LHsContext GhcPs) -> HsConDeclH98Details GhcPs -> ConDecl GhcPs -mkConDeclH98 name mb_forall mb_cxt args - = ConDeclH98 { con_ext = noExtField +mkConDeclH98 ann name mb_forall mb_cxt args + = ConDeclH98 { con_ext = ann , con_name = name - , con_forall = noLoc $ isJust mb_forall + , con_forall = isJust mb_forall , con_ex_tvs = mb_forall `orElse` [] , con_mb_cxt = mb_cxt , con_args = args @@ -630,25 +699,36 @@ mkConDeclH98 name mb_forall mb_cxt args -- provided), context (if provided), argument types, and result type, and -- records whether this is a prefix or record GADT constructor. See -- Note [GADT abstract syntax] in "GHC.Hs.Decls" for more details. -mkGadtDecl :: [Located RdrName] +mkGadtDecl :: SrcSpan + -> [LocatedN RdrName] -> LHsSigType GhcPs - -> P (ConDecl GhcPs, [AddAnn]) -mkGadtDecl names ty = do - let (args, res_ty, anns) - | L _ (HsFunTy _ _w (L loc (HsRecTy _ rf)) res_ty) <- body_ty - = (RecConGADT (L loc rf), res_ty, []) + -> [AddApiAnn] + -> P (LConDecl GhcPs) +mkGadtDecl loc names ty annsIn = do + cs <- getCommentsFor loc + let l = noAnnSrcSpan loc + + let (args, res_ty, annsa, csa) + | L ll (HsFunTy af _w (L loc' (HsRecTy an rf)) res_ty) <- body_ty + = let + an' = addTrailingAnnToL (locA loc') (anns af) (comments af) an + in ( RecConGADT (L (SrcSpanAnn an' (locA loc')) rf), res_ty + , [], apiAnnComments (ann ll)) | otherwise - = let (arg_types, res_type, anns) = splitHsFunType body_ty - in (PrefixConGADT arg_types, res_type, anns) + = let (anns, cs, arg_types, res_type) = splitHsFunType body_ty + in (PrefixConGADT arg_types, res_type, anns, cs) + + an = case outer_bndrs of + _ -> ApiAnn (spanAsAnchor loc) (annsIn ++ annsa) (cs Semi.<> csa) - pure ( ConDeclGADT { con_g_ext = noExtField + pure $ L l ConDeclGADT + { con_g_ext = an , con_names = names , con_bndrs = L (getLoc ty) outer_bndrs , con_mb_cxt = mcxt , con_g_args = args , con_res_ty = res_ty , con_doc = Nothing } - , anns ) where (outer_bndrs, mcxt, body_ty) = splitLHsGadtTy ty @@ -743,34 +823,39 @@ eitherToP :: MonadP m => Either PsError a -> m a eitherToP (Left err) = addFatalError err eitherToP (Right thing) = return thing -checkTyVars :: SDoc -> SDoc -> Located RdrName -> [LHsTypeArg GhcPs] +checkTyVars :: SDoc -> SDoc -> LocatedN RdrName -> [LHsTypeArg GhcPs] -> P ( LHsQTyVars GhcPs -- the synthesized type variables - , [AddAnn] ) -- action which adds annotations + , [AddApiAnn] ) -- action which adds annotations -- ^ Check whether the given list of type parameters are all type variables -- (possibly with a kind signature). checkTyVars pp_what equals_or_where tc tparms = do { (tvs, anns) <- fmap unzip $ mapM check tparms ; return (mkHsQTvs tvs, concat anns) } where - check (HsTypeArg _ ki@(L loc _)) = addFatalError $ PsError (PsErrUnexpectedTypeAppInDecl ki pp_what (unLoc tc)) [] loc - check (HsValArg ty) = chkParens [] ty + check :: HsArg (LHsType GhcPs) (LHsType GhcPs) -> P (LHsTyVarBndr () GhcPs, [AddApiAnn]) -- AZ + check (HsTypeArg _ ki@(L loc _)) = addFatalError $ PsError (PsErrUnexpectedTypeAppInDecl ki pp_what (unLoc tc)) [] (locA loc) + check (HsValArg ty) = chkParens [] noCom ty check (HsArgPar sp) = addFatalError $ PsError (PsErrMalformedDecl pp_what (unLoc tc)) [] sp -- Keep around an action for adjusting the annotations of extra parens - chkParens :: [AddAnn] -> LHsType GhcPs - -> P (LHsTyVarBndr () GhcPs, [AddAnn]) - chkParens acc (L l (HsParTy _ ty)) = chkParens (mkParensApiAnn l ++ acc) ty - chkParens acc ty = do - tv <- chk ty + chkParens :: [AddApiAnn] -> ApiAnnComments -> LHsType GhcPs + -> P (LHsTyVarBndr () GhcPs, [AddApiAnn]) + chkParens acc cs (L l (HsParTy an ty)) + = chkParens (mkParensApiAnn (locA l) ++ acc) (cs Semi.<> apiAnnComments an) ty + chkParens acc cs ty = do + tv <- chk acc cs ty return (tv, reverse acc) -- Check that the name space is correct! - chk :: LHsType GhcPs -> P (LHsTyVarBndr () GhcPs) - chk (L l (HsKindSig _ (L lv (HsTyVar _ _ (L _ tv))) k)) - | isRdrTyVar tv = return (L l (KindedTyVar noExtField () (L lv tv) k)) - chk (L l (HsTyVar _ _ (L ltv tv))) - | isRdrTyVar tv = return (L l (UserTyVar noExtField () (L ltv tv))) - chk t@(L loc _) - = addFatalError $ PsError (PsErrUnexpectedTypeInDecl t pp_what (unLoc tc) tparms equals_or_where) [] loc + chk :: [AddApiAnn] -> ApiAnnComments -> LHsType GhcPs -> P (LHsTyVarBndr () GhcPs) + chk an cs (L l (HsKindSig annk (L annt (HsTyVar ann _ (L lv tv))) k)) + | isRdrTyVar tv + = return (L (widenLocatedAn (l Semi.<> annt) an) + (KindedTyVar (addAnns (annk Semi.<> ann) an cs) () (L lv tv) k)) + chk an cs (L l (HsTyVar ann _ (L ltv tv))) + | isRdrTyVar tv = return (L (widenLocatedAn l an) + (UserTyVar (addAnns ann an cs) () (L ltv tv))) + chk _ _ t@(L loc _) + = addFatalError $ PsError (PsErrUnexpectedTypeInDecl t pp_what (unLoc tc) tparms equals_or_where) [] (locA loc) whereDots, equalsDots :: SDoc @@ -782,26 +867,26 @@ checkDatatypeContext :: Maybe (LHsContext GhcPs) -> P () checkDatatypeContext Nothing = return () checkDatatypeContext (Just c) = do allowed <- getBit DatatypeContextsBit - unless allowed $ addError $ PsError (PsErrIllegalDataTypeContext c) [] (getLoc c) + unless allowed $ addError $ PsError (PsErrIllegalDataTypeContext c) [] (getLocA c) type LRuleTyTmVar = Located RuleTyTmVar -data RuleTyTmVar = RuleTyTmVar (Located RdrName) (Maybe (LHsType GhcPs)) +data RuleTyTmVar = RuleTyTmVar ApiAnn (LocatedN RdrName) (Maybe (LHsType GhcPs)) -- ^ Essentially a wrapper for a @RuleBndr GhcPs@ -- turns RuleTyTmVars into RuleBnrs - this is straightforward mkRuleBndrs :: [LRuleTyTmVar] -> [LRuleBndr GhcPs] mkRuleBndrs = fmap (fmap cvt_one) - where cvt_one (RuleTyTmVar v Nothing) = RuleBndr noExtField v - cvt_one (RuleTyTmVar v (Just sig)) = - RuleBndrSig noExtField v (mkHsPatSigType sig) + where cvt_one (RuleTyTmVar ann v Nothing) = RuleBndr ann v + cvt_one (RuleTyTmVar ann v (Just sig)) = + RuleBndrSig ann v (mkHsPatSigType sig) -- turns RuleTyTmVars into HsTyVarBndrs - this is more interesting mkRuleTyVarBndrs :: [LRuleTyTmVar] -> [LHsTyVarBndr () GhcPs] -mkRuleTyVarBndrs = fmap (fmap cvt_one) - where cvt_one (RuleTyTmVar v Nothing) - = UserTyVar noExtField () (fmap tm_to_ty v) - cvt_one (RuleTyTmVar v (Just sig)) - = KindedTyVar noExtField () (fmap tm_to_ty v) sig +mkRuleTyVarBndrs = fmap cvt_one + where cvt_one (L l (RuleTyTmVar ann v Nothing)) + = L (noAnnSrcSpan l) (UserTyVar ann () (fmap tm_to_ty v)) + cvt_one (L l (RuleTyTmVar ann v (Just sig))) + = L (noAnnSrcSpan l) (KindedTyVar ann () (fmap tm_to_ty v) sig) -- takes something in namespace 'varName' to something in namespace 'tvName' tm_to_ty (Unqual occ) = Unqual (setOccNameSpace tvName occ) tm_to_ty _ = panic "mkRuleTyVarBndrs" @@ -812,19 +897,19 @@ checkRuleTyVarBndrNames = mapM_ (check . fmap hsTyVarName) where check (L loc (Unqual occ)) = -- TODO: don't use string here, OccName has a Unique/FastString when ((occNameString occ ==) `any` ["forall","family","role"]) - (addFatalError $ PsError (PsErrParseErrorOnInput occ) [] loc) + (addFatalError $ PsError (PsErrParseErrorOnInput occ) [] (locA loc)) check _ = panic "checkRuleTyVarBndrNames" -checkRecordSyntax :: (MonadP m, Outputable a) => Located a -> m (Located a) +checkRecordSyntax :: (MonadP m, Outputable a) => LocatedA a -> m (LocatedA a) checkRecordSyntax lr@(L loc r) = do allowed <- getBit TraditionalRecordSyntaxBit - unless allowed $ addError $ PsError (PsErrIllegalTraditionalRecordSyntax (ppr r)) [] loc + unless allowed $ addError $ PsError (PsErrIllegalTraditionalRecordSyntax (ppr r)) [] (locA loc) return lr -- | Check if the gadt_constrlist is empty. Only raise parse error for -- `data T where` to avoid affecting existing error message, see #8258. -checkEmptyGADTs :: Located ([AddAnn], [LConDecl GhcPs]) - -> P (Located ([AddAnn], [LConDecl GhcPs])) +checkEmptyGADTs :: Located ([AddApiAnn], [LConDecl GhcPs]) + -> P (Located ([AddApiAnn], [LConDecl GhcPs])) checkEmptyGADTs gadts@(L span (_, [])) -- Empty GADT declaration. = do gadtSyntax <- getBit GadtSyntaxBit -- GADTs implies GADTSyntax unless gadtSyntax $ addError $ PsError PsErrIllegalWhereInDataDecl [] span @@ -834,10 +919,11 @@ checkEmptyGADTs gadts = return gadts -- Ordinary GADT declaration. checkTyClHdr :: Bool -- True <=> class header -- False <=> type header -> LHsType GhcPs - -> P (Located RdrName, -- the head symbol (type or class name) - [LHsTypeArg GhcPs], -- parameters of head symbol + -> P (LocatedN RdrName, -- the head symbol (type or class name) + [LHsTypeArg GhcPs], -- parameters of head symbol LexicalFixity, -- the declaration is in infix format - [AddAnn]) -- API Annotation for HsParTy when stripping parens + [AddApiAnn]) -- API Annotation for HsParTy + -- when stripping parens -- Well-formedness check and decomposition of type and class heads. -- Decomposes T ty1 .. tyn into (T, [ty1, ..., tyn]) -- Int :*: Bool into (:*:, [Int, Bool]) @@ -845,13 +931,15 @@ checkTyClHdr :: Bool -- True <=> class header checkTyClHdr is_cls ty = goL ty [] [] Prefix where - goL (L l ty) acc ann fix = go l ty acc ann fix + goL (L l ty) acc ann fix = go (locA l) ty acc ann fix -- workaround to define '*' despite StarIsType - go lp (HsParTy _ (L l (HsStarTy _ isUni))) acc ann fix - = do { addWarning Opt_WarnStarBinder (PsWarnStarBinder l) + go _ (HsParTy an (L l (HsStarTy _ isUni))) acc ann' fix + = do { addWarning Opt_WarnStarBinder (PsWarnStarBinder (locA l)) ; let name = mkOccName tcClsName (starSym isUni) - ; return (L l (Unqual name), acc, fix, (ann ++ mkParensApiAnn lp)) } + ; let a' = newAnns l an + ; return (L a' (Unqual name), acc, fix + , ann') } go _ (HsTyVar _ _ ltc@(L _ tc)) acc ann fix | isRdrTc tc = return (ltc, acc, fix, ann) @@ -861,7 +949,8 @@ checkTyClHdr is_cls ty go _ (HsAppTy _ t1 t2) acc ann fix = goL t1 (HsValArg t2:acc) ann fix go _ (HsAppKindTy l ty ki) acc ann fix = goL ty (HsTypeArg l ki:acc) ann fix go l (HsTupleTy _ HsBoxedOrConstraintTuple ts) [] ann fix - = return (L l (nameRdrName tup_name), map HsValArg ts, fix, ann) + = return (L (noAnnSrcSpan l) (nameRdrName tup_name) + , map HsValArg ts, fix, ann) where arity = length ts tup_name | is_cls = cTupleTyConName arity @@ -870,6 +959,22 @@ checkTyClHdr is_cls ty go l _ _ _ _ = addFatalError $ PsError (PsErrMalformedTyOrClDecl ty) [] l + -- Combine the annotations from the HsParTy and HsStarTy into a + -- new one for the LocatedN RdrName + newAnns :: SrcSpanAnnA -> ApiAnn' AnnParen -> SrcSpanAnnN + newAnns (SrcSpanAnn ApiAnnNotUsed l) (ApiAnn as (AnnParen _ o c) cs) = + let + lr = combineRealSrcSpans (realSrcSpan l) (anchor as) + -- lr = widenAnchorR as (realSrcSpan l) + an = (ApiAnn (Anchor lr UnchangedAnchor) (NameAnn NameParens o (AR $ realSrcSpan l) c []) cs) + in SrcSpanAnn an (RealSrcSpan lr Nothing) + newAnns _ ApiAnnNotUsed = panic "missing AnnParen" + newAnns (SrcSpanAnn (ApiAnn ap (AnnListItem ta) csp) l) (ApiAnn as (AnnParen _ o c) cs) = + let + lr = combineRealSrcSpans (anchor ap) (anchor as) + an = (ApiAnn (Anchor lr UnchangedAnchor) (NameAnn NameParens o (AR $ realSrcSpan l) c ta) (csp Semi.<> cs)) + in SrcSpanAnn an (RealSrcSpan lr Nothing) + -- | Yield a parse error if we have a function applied directly to a do block -- etc. and BlockArguments is not enabled. checkExpBlockArguments :: LHsExpr GhcPs -> PV () @@ -900,7 +1005,7 @@ checkCmdBlockArguments :: LHsCmd GhcPs -> PV () check err a = do blockArguments <- getBit BlockArgumentsBit unless blockArguments $ - addError $ PsError (err a) [] (getLoc a) + addError $ PsError (err a) [] (getLocA a) -- | Validate the context constraints and break up a context into a list -- of predicates. @@ -911,26 +1016,37 @@ checkCmdBlockArguments :: LHsCmd GhcPs -> PV () -- (Eq a) --> [Eq a] -- (((Eq a))) --> [Eq a] -- @ -checkContext :: LHsType GhcPs -> P ([AddAnn],LHsContext GhcPs) -checkContext (L l orig_t) - = check [] (L l orig_t) +checkContext :: LHsType GhcPs -> P (LHsContext GhcPs) +checkContext orig_t@(L (SrcSpanAnn _ l) _orig_t) = + check ([],[],noCom) orig_t where - check anns (L lp (HsTupleTy _ HsBoxedOrConstraintTuple ts)) + check :: ([AnnAnchor],[AnnAnchor],ApiAnnComments) + -> LHsType GhcPs -> P (LHsContext GhcPs) + check (oparens,cparens,cs) (L _l (HsTupleTy ann' HsBoxedOrConstraintTuple ts)) -- (Eq a, Ord b) shows up as a tuple type. Only boxed tuples can -- be used as context constraints. - = return (anns ++ mkParensApiAnn lp,L l ts) -- Ditto () - - check anns (L lp1 (HsParTy _ ty)) + -- Ditto () + = do + let (op,cp,cs') = case ann' of + ApiAnnNotUsed -> ([],[],noCom) + ApiAnn _ (AnnParen _ o c) cs -> ([o],[c],cs) + return (L (SrcSpanAnn (ApiAnn (spanAsAnchor l) + (AnnContext Nothing (op Semi.<> oparens) (cp Semi.<> cparens)) (cs Semi.<> cs')) l) ts) + + check (opi,cpi,csi) (L _lp1 (HsParTy ann' ty)) -- to be sure HsParTy doesn't get into the way - = check anns' ty - where anns' = if l == lp1 then anns - else (anns ++ mkParensApiAnn lp1) - - -- no need for anns, returning original - check _anns _t = return ([],L l [L l orig_t]) - -checkImportDecl :: Maybe (Located Token) - -> Maybe (Located Token) + = do + let (op,cp,cs') = case ann' of + ApiAnnNotUsed -> ([],[],noCom) + ApiAnn _ (AnnParen _ open close ) cs -> ([open],[close],cs) + check (op++opi,cp++cpi,cs' Semi.<> csi) ty + + -- No need for anns, returning original + check (_opi,_cpi,_csi) _t = + return (L (SrcSpanAnn (ApiAnn (spanAsAnchor l) (AnnContext Nothing [] []) noCom) l) [orig_t]) + +checkImportDecl :: Maybe AnnAnchor + -> Maybe AnnAnchor -> P () checkImportDecl mPre mPost = do let whenJust mg f = maybe (pure ()) f mg @@ -941,18 +1057,18 @@ checkImportDecl mPre mPost = do -- 'ImportQualifiedPost' is not in effect. whenJust mPost $ \post -> when (not importQualifiedPostEnabled) $ - failOpNotEnabledImportQualifiedPost (getLoc post) + failOpNotEnabledImportQualifiedPost (RealSrcSpan (annAnchorRealSrcSpan post) Nothing) -- Error if 'qualified' occurs in both pre and postpositive -- positions. whenJust mPost $ \post -> when (isJust mPre) $ - failOpImportQualifiedTwice (getLoc post) + failOpImportQualifiedTwice (RealSrcSpan (annAnchorRealSrcSpan post) Nothing) -- Warn if 'qualified' found in prepositive position and -- 'Opt_WarnPrepositiveQualifiedModule' is enabled. whenJust mPre $ \pre -> - warnPrepositiveQualifiedModule (getLoc pre) + warnPrepositiveQualifiedModule (RealSrcSpan (annAnchorRealSrcSpan pre) Nothing) -- ------------------------------------------------------------------------- -- Checking Patterns. @@ -960,40 +1076,40 @@ checkImportDecl mPre mPost = do -- We parse patterns as expressions and check for valid patterns below, -- converting the expression into a pattern at the same time. -checkPattern :: Located (PatBuilder GhcPs) -> P (LPat GhcPs) +checkPattern :: LocatedA (PatBuilder GhcPs) -> P (LPat GhcPs) checkPattern = runPV . checkLPat -checkPattern_hints :: [Hint] -> PV (Located (PatBuilder GhcPs)) -> P (LPat GhcPs) +checkPattern_hints :: [Hint] -> PV (LocatedA (PatBuilder GhcPs)) -> P (LPat GhcPs) checkPattern_hints hints pp = runPV_hints hints (pp >>= checkLPat) -checkLPat :: Located (PatBuilder GhcPs) -> PV (LPat GhcPs) +checkLPat :: LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs) checkLPat e@(L l _) = checkPat l e [] [] -checkPat :: SrcSpan -> Located (PatBuilder GhcPs) -> [HsPatSigType GhcPs] -> [LPat GhcPs] +checkPat :: SrcSpanAnnA -> LocatedA (PatBuilder GhcPs) -> [HsPatSigType GhcPs] -> [LPat GhcPs] -> PV (LPat GhcPs) -checkPat loc (L l e@(PatBuilderVar (L _ c))) tyargs args +checkPat loc (L l e@(PatBuilderVar (L ln c))) tyargs args | isRdrDataCon c = return . L loc $ ConPat - { pat_con_ext = noExtField - , pat_con = L l c + { pat_con_ext = noAnn -- AZ: where should this come from? + , pat_con = L ln c , pat_args = PrefixCon tyargs args } | not (null tyargs) = add_hint TypeApplicationsInPatternsOnlyDataCons $ - patFail l (ppr e <+> hsep [text "@" <> ppr t | t <- tyargs]) + patFail (locA l) (ppr e <+> hsep [text "@" <> ppr t | t <- tyargs]) | not (null args) && patIsRec c = add_hint SuggestRecursiveDo $ - patFail l (ppr e) -checkPat loc (L _ (PatBuilderAppType f t)) tyargs args = + patFail (locA l) (ppr e) +checkPat loc (L _ (PatBuilderAppType f _ t)) tyargs args = checkPat loc f (t : tyargs) args checkPat loc (L _ (PatBuilderApp f e)) [] args = do p <- checkLPat e checkPat loc f [] (p : args) -checkPat loc (L _ e) [] [] = do +checkPat loc (L l e) [] [] = do p <- checkAPat loc e - return (L loc p) -checkPat loc e _ _ = patFail loc (ppr e) + return (L l p) +checkPat loc e _ _ = patFail (locA loc) (ppr e) -checkAPat :: SrcSpan -> PatBuilder GhcPs -> PV (Pat GhcPs) +checkAPat :: SrcSpanAnnA -> PatBuilder GhcPs -> PV (Pat GhcPs) checkAPat loc e0 = do nPlusKPatterns <- getBit NPlusKPatternsBit case e0 of @@ -1003,45 +1119,50 @@ checkAPat loc e0 = do -- Overloaded numeric patterns (e.g. f 0 x = x) -- Negation is recorded separately, so that the literal is zero or +ve -- NB. Negative *primitive* literals are already handled by the lexer - PatBuilderOverLit pos_lit -> return (mkNPat (L loc pos_lit) Nothing) + PatBuilderOverLit pos_lit -> return (mkNPat (L (locA loc) pos_lit) Nothing noAnn) -- n+k patterns PatBuilderOpApp - (L nloc (PatBuilderVar (L _ n))) + (L _ (PatBuilderVar (L nloc n))) (L _ plus) (L lloc (PatBuilderOverLit lit@(OverLit {ol_val = HsIntegral {}}))) - | nPlusKPatterns && (plus == plus_RDR) - -> return (mkNPlusKPat (L nloc n) (L lloc lit)) + anns + | nPlusKPatterns && (plus == plus_RDR) + -> return (mkNPlusKPat (L nloc n) (L (locA lloc) lit) anns) -- Improve error messages for the @-operator when the user meant an @-pattern - PatBuilderOpApp _ op _ | opIsAt (unLoc op) -> do - addError $ PsError PsErrAtInPatPos [] (getLoc op) + PatBuilderOpApp _ op _ _ | opIsAt (unLoc op) -> do + addError $ PsError PsErrAtInPatPos [] (getLocA op) return (WildPat noExtField) - PatBuilderOpApp l (L cl c) r + PatBuilderOpApp l (L cl c) r anns | isRdrDataCon c -> do l <- checkLPat l r <- checkLPat r return $ ConPat - { pat_con_ext = noExtField + { pat_con_ext = anns , pat_con = L cl c , pat_args = InfixCon l r } - PatBuilderPar e -> checkLPat e >>= (return . (ParPat noExtField)) - _ -> patFail loc (ppr e0) + PatBuilderPar e an@(AnnParen pt o c) -> do + (L l p) <- checkLPat e + let aa = [AddApiAnn ai o, AddApiAnn ac c] + (ai,ac) = parenTypeKws pt + return (ParPat (ApiAnn (spanAsAnchor $ (widenSpan (locA l) aa)) an noCom) (L l p)) + _ -> patFail (locA loc) (ppr e0) -placeHolderPunRhs :: DisambECP b => PV (Located b) +placeHolderPunRhs :: DisambECP b => PV (LocatedA b) -- The RHS of a punned record field will be filled in by the renamer -- It's better not to make it an error, in case we want to print it when -- debugging -placeHolderPunRhs = mkHsVarPV (noLoc pun_RDR) +placeHolderPunRhs = mkHsVarPV (noLocA pun_RDR) plus_RDR, pun_RDR :: RdrName plus_RDR = mkUnqual varName (fsLit "+") -- Hack pun_RDR = mkUnqual varName (fsLit "pun-right-hand-side") -checkPatField :: LHsRecField GhcPs (Located (PatBuilder GhcPs)) +checkPatField :: LHsRecField GhcPs (LocatedA (PatBuilder GhcPs)) -> PV (LHsRecField GhcPs (LPat GhcPs)) checkPatField (L l fld) = do p <- checkLPat (hsRecFieldArg fld) return (L l (fld { hsRecFieldArg = p })) @@ -1055,47 +1176,49 @@ patIsRec e = e == mkUnqual varName (fsLit "rec") --------------------------------------------------------------------------- -- Check Equation Syntax -checkValDef :: Located (PatBuilder GhcPs) - -> Maybe (LHsType GhcPs) - -> Located (a,GRHSs GhcPs (LHsExpr GhcPs)) - -> P ([AddAnn],HsBind GhcPs) +checkValDef :: SrcSpan + -> LocatedA (PatBuilder GhcPs) + -> Maybe (AddApiAnn, LHsType GhcPs) + -> Located (GRHSs GhcPs (LHsExpr GhcPs)) + -> P (HsBind GhcPs) -checkValDef lhs (Just sig) grhss +checkValDef loc lhs (Just (sigAnn, sig)) grhss -- x :: ty = rhs parses as a *pattern* binding - = do lhs' <- runPV $ mkHsTySigPV (combineLocs lhs sig) lhs sig >>= checkLPat - checkPatBind lhs' grhss + = do lhs' <- runPV $ mkHsTySigPV (combineLocsA lhs sig) lhs sig [sigAnn] + >>= checkLPat + checkPatBind loc [] lhs' grhss -checkValDef lhs Nothing g@(L l (_,grhss)) +checkValDef loc lhs Nothing g@(L l grhss) = do { mb_fun <- isFunLhs lhs ; case mb_fun of Just (fun, is_infix, pats, ann) -> - checkFunBind NoSrcStrict ann (getLoc lhs) + checkFunBind NoSrcStrict loc ann (getLocA lhs) fun is_infix pats (L l grhss) Nothing -> do lhs' <- checkPattern lhs - checkPatBind lhs' g } + checkPatBind loc [] lhs' g } checkFunBind :: SrcStrictness - -> [AddAnn] -> SrcSpan - -> Located RdrName + -> [AddApiAnn] + -> SrcSpan + -> LocatedN RdrName -> LexicalFixity - -> [Located (PatBuilder GhcPs)] + -> [LocatedA (PatBuilder GhcPs)] -> Located (GRHSs GhcPs (LHsExpr GhcPs)) - -> P ([AddAnn],HsBind GhcPs) -checkFunBind strictness ann lhs_loc fun is_infix pats (L rhs_span grhss) + -> P (HsBind GhcPs) +checkFunBind strictness locF ann lhs_loc fun is_infix pats (L rhs_span grhss) = do ps <- runPV_hints param_hints (mapM checkLPat pats) - let match_span = combineSrcSpans lhs_loc rhs_span - -- Add back the annotations stripped from any HsPar values in the lhs - -- mapM_ (\a -> a match_span) ann - return (ann, makeFunBind fun - [L match_span (Match { m_ext = noExtField - , m_ctxt = FunRhs - { mc_fun = fun - , mc_fixity = is_infix - , mc_strictness = strictness } - , m_pats = ps - , m_grhss = grhss })]) + let match_span = noAnnSrcSpan $ combineSrcSpans lhs_loc rhs_span + cs <- getCommentsFor locF + return (makeFunBind fun (L (noAnnSrcSpan $ locA match_span) + [L match_span (Match { m_ext = ApiAnn (spanAsAnchor locF) ann cs + , m_ctxt = FunRhs + { mc_fun = fun + , mc_fixity = is_infix + , mc_strictness = strictness } + , m_pats = ps + , m_grhss = grhss })])) -- The span of the match covers the entire equation. -- That isn't quite right, but it'll do for now. where @@ -1103,7 +1226,7 @@ checkFunBind strictness ann lhs_loc fun is_infix pats (L rhs_span grhss) | Infix <- is_infix = [SuggestInfixBindMaybeAtPat (unLoc fun)] | otherwise = [] -makeFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] +makeFunBind :: LocatedN RdrName -> LocatedL [LMatch GhcPs (LHsExpr GhcPs)] -> HsBind GhcPs -- Like GHC.Hs.Utils.mkFunBind, but we need to be able to set the fixity too makeFunBind fn ms @@ -1113,62 +1236,66 @@ makeFunBind fn ms fun_tick = [] } -- See Note [FunBind vs PatBind] -checkPatBind :: LPat GhcPs - -> Located (a,GRHSs GhcPs (LHsExpr GhcPs)) - -> P ([AddAnn],HsBind GhcPs) -checkPatBind lhs (L rhs_span (_,grhss)) - | BangPat _ p <- unLoc lhs - , VarPat _ v <- unLoc p - = return ([], makeFunBind v [L match_span (m v)]) +checkPatBind :: SrcSpan + -> [AddApiAnn] + -> LPat GhcPs + -> Located (GRHSs GhcPs (LHsExpr GhcPs)) + -> P (HsBind GhcPs) +checkPatBind loc annsIn (L _ (BangPat (ApiAnn _ ans cs) (L _ (VarPat _ v)))) + (L _match_span grhss) + = return (makeFunBind v (L (noAnnSrcSpan loc) + [L (noAnnSrcSpan loc) (m (ApiAnn (spanAsAnchor loc) (ans++annsIn) cs) v)])) where - match_span = combineSrcSpans (getLoc lhs) rhs_span - m v = Match { m_ext = noExtField - , m_ctxt = FunRhs { mc_fun = v - , mc_fixity = Prefix - , mc_strictness = SrcStrict } - , m_pats = [] - , m_grhss = grhss } - -checkPatBind lhs (L _ (_,grhss)) - = return ([],PatBind noExtField lhs grhss ([],[])) - -checkValSigLhs :: LHsExpr GhcPs -> P (Located RdrName) + m a v = Match { m_ext = a + , m_ctxt = FunRhs { mc_fun = v + , mc_fixity = Prefix + , mc_strictness = SrcStrict } + , m_pats = [] + , m_grhss = grhss } + +checkPatBind loc annsIn lhs (L _ grhss) = do + cs <- getCommentsFor loc + return (PatBind (ApiAnn (spanAsAnchor loc) annsIn cs) lhs grhss ([],[])) + +checkValSigLhs :: LHsExpr GhcPs -> P (LocatedN RdrName) checkValSigLhs (L _ (HsVar _ lrdr@(L _ v))) | isUnqual v , not (isDataOcc (rdrNameOcc v)) = return lrdr checkValSigLhs lhs@(L l _) - = addFatalError $ PsError (PsErrInvalidTypeSignature lhs) [] l + = addFatalError $ PsError (PsErrInvalidTypeSignature lhs) [] (locA l) checkDoAndIfThenElse :: (Outputable a, Outputable b, Outputable c) => (a -> Bool -> b -> Bool -> c -> PsErrorDesc) - -> Located a -> Bool -> Located b -> Bool -> Located c -> PV () + -> LocatedA a -> Bool -> LocatedA b -> Bool -> LocatedA c -> PV () checkDoAndIfThenElse err guardExpr semiThen thenExpr semiElse elseExpr | semiThen || semiElse = do doAndIfThenElse <- getBit DoAndIfThenElseBit let e = err (unLoc guardExpr) semiThen (unLoc thenExpr) semiElse (unLoc elseExpr) - loc = combineLocs guardExpr elseExpr + loc = combineLocs (reLoc guardExpr) (reLoc elseExpr) unless doAndIfThenElse $ addError (PsError e [] loc) | otherwise = return () -isFunLhs :: Located (PatBuilder GhcPs) - -> P (Maybe (Located RdrName, LexicalFixity, [Located (PatBuilder GhcPs)],[AddAnn])) +isFunLhs :: LocatedA (PatBuilder GhcPs) + -> P (Maybe (LocatedN RdrName, LexicalFixity, + [LocatedA (PatBuilder GhcPs)],[AddApiAnn])) -- A variable binding is parsed as a FunBind. -- Just (fun, is_infix, arg_pats) if e is a function LHS isFunLhs e = go e [] [] where - go (L loc (PatBuilderVar (L _ f))) es ann + go (L _ (PatBuilderVar (L loc f))) es ann | not (isRdrDataCon f) = return (Just (L loc f, Prefix, es, ann)) go (L _ (PatBuilderApp f e)) es ann = go f (e:es) ann - go (L l (PatBuilderPar e)) es@(_:_) ann = go e es (ann ++ mkParensApiAnn l) - go (L loc (PatBuilderOpApp l (L loc' op) r)) es ann + go (L l (PatBuilderPar e _an)) es@(_:_) ann + = go e es (ann ++ mkParensApiAnn (locA l)) + go (L loc (PatBuilderOpApp l (L loc' op) r (ApiAnn loca anns cs))) es ann | not (isRdrDataCon op) -- We have found the function! - = return (Just (L loc' op, Infix, (l:r:es), ann)) + = return (Just (L loc' op, Infix, (l:r:es), (anns ++ ann))) | otherwise -- Infix data con; keep going = do { mb_l <- go l es ann ; case mb_l of @@ -1176,35 +1303,36 @@ isFunLhs e = go e [] [] -> return (Just (op', Infix, j : op_app : es', ann')) where op_app = L loc (PatBuilderOpApp k - (L loc' op) r) + (L loc' op) r (ApiAnn loca anns cs)) _ -> return Nothing } go _ _ _ = return Nothing -mkBangTy :: SrcStrictness -> LHsType GhcPs -> HsType GhcPs -mkBangTy strictness = - HsBangTy noExtField (HsSrcBang NoSourceText NoSrcUnpack strictness) +mkBangTy :: ApiAnn -> SrcStrictness -> LHsType GhcPs -> HsType GhcPs +mkBangTy anns strictness = + HsBangTy anns (HsSrcBang NoSourceText NoSrcUnpack strictness) -- | Result of parsing @{-\# UNPACK \#-}@ or @{-\# NOUNPACK \#-}@. data UnpackednessPragma = - UnpackednessPragma [AddAnn] SourceText SrcUnpackedness + UnpackednessPragma [AddApiAnn] SourceText SrcUnpackedness -- | Annotate a type with either an @{-\# UNPACK \#-}@ or a @{-\# NOUNPACK \#-}@ pragma. addUnpackednessP :: MonadP m => Located UnpackednessPragma -> LHsType GhcPs -> m (LHsType GhcPs) addUnpackednessP (L lprag (UnpackednessPragma anns prag unpk)) ty = do - let l' = combineSrcSpans lprag (getLoc ty) - t' = addUnpackedness ty - addAnnsAt l' anns - return (L l' t') + let l' = combineSrcSpans lprag (getLocA ty) + cs <- getCommentsFor l' + let an = ApiAnn (spanAsAnchor l') anns cs + t' = addUnpackedness an ty + return (L (noAnnSrcSpan l') t') where -- If we have a HsBangTy that only has a strictness annotation, -- such as ~T or !T, then add the pragma to the existing HsBangTy. -- -- Otherwise, wrap the type in a new HsBangTy constructor. - addUnpackedness (L _ (HsBangTy x bang t)) + addUnpackedness an (L _ (HsBangTy x bang t)) | HsSrcBang NoSourceText NoSrcUnpack strictness <- bang - = HsBangTy x (HsSrcBang prag unpk strictness) t - addUnpackedness t - = HsBangTy noExtField (HsSrcBang prag unpk NoSrcStrict) t + = HsBangTy (addAnns an (apiAnnAnns x) (apiAnnComments x)) (HsSrcBang prag unpk strictness) t + addUnpackedness an t + = HsBangTy an (HsSrcBang prag unpk NoSrcStrict) t --------------------------------------------------------------------------- -- | Check for monad comprehensions @@ -1237,7 +1365,7 @@ checkMonadComp = do -- P (forall b. DisambECP b => PV (Located b)) -- newtype ECP = - ECP { unECP :: forall b. DisambECP b => PV (Located b) } + ECP { unECP :: forall b. DisambECP b => PV (LocatedA b) } ecpFromExp :: LHsExpr GhcPs -> ECP ecpFromExp a = ECP (ecpFromExp' a) @@ -1247,79 +1375,98 @@ ecpFromCmd a = ECP (ecpFromCmd' a) -- The 'fbinds' parser rule produces values of this type. See Note -- [RecordDotSyntax field updates]. -type Fbind b = Either (LHsRecField GhcPs (Located b)) (LHsRecProj GhcPs (Located b)) +type Fbind b = Either (LHsRecField GhcPs (LocatedA b)) (LHsRecProj GhcPs (LocatedA b)) -- | Disambiguate infix operators. -- See Note [Ambiguous syntactic categories] class DisambInfixOp b where - mkHsVarOpPV :: Located RdrName -> PV (Located b) - mkHsConOpPV :: Located RdrName -> PV (Located b) - mkHsInfixHolePV :: SrcSpan -> PV (Located b) + mkHsVarOpPV :: LocatedN RdrName -> PV (LocatedN b) + mkHsConOpPV :: LocatedN RdrName -> PV (LocatedN b) + mkHsInfixHolePV :: SrcSpan -> (ApiAnnComments -> ApiAnn' ApiAnnUnboundVar) -> PV (Located b) instance DisambInfixOp (HsExpr GhcPs) where mkHsVarOpPV v = return $ L (getLoc v) (HsVar noExtField v) mkHsConOpPV v = return $ L (getLoc v) (HsVar noExtField v) - mkHsInfixHolePV l = return $ L l hsHoleExpr + mkHsInfixHolePV l ann = do + cs <- getCommentsFor l + return $ L l (hsHoleExpr (ann cs)) instance DisambInfixOp RdrName where mkHsConOpPV (L l v) = return $ L l v mkHsVarOpPV (L l v) = return $ L l v - mkHsInfixHolePV l = addFatalError $ PsError PsErrInvalidInfixHole [] l + mkHsInfixHolePV l _ = addFatalError $ PsError PsErrInvalidInfixHole [] l + +type AnnoBody b + = ( Anno (GRHS GhcPs (LocatedA (Body b GhcPs))) ~ SrcSpan + , Anno [LocatedA (Match GhcPs (LocatedA (Body b GhcPs)))] ~ SrcSpanAnnL + , Anno (Match GhcPs (LocatedA (Body b GhcPs))) ~ SrcSpanAnnA + , Anno (StmtLR GhcPs GhcPs (LocatedA (Body (Body b GhcPs) GhcPs))) ~ SrcSpanAnnA + , Anno [LocatedA (StmtLR GhcPs GhcPs + (LocatedA (Body (Body (Body b GhcPs) GhcPs) GhcPs)))] ~ SrcSpanAnnL + ) -- | Disambiguate constructs that may appear when we do not know ahead of time whether we are -- parsing an expression, a command, or a pattern. -- See Note [Ambiguous syntactic categories] -class b ~ (Body b) GhcPs => DisambECP b where +class (b ~ (Body b) GhcPs, AnnoBody b) => DisambECP b where -- | See Note [Body in DisambECP] type Body b :: Type -> Type -- | Return a command without ambiguity, or fail in a non-command context. - ecpFromCmd' :: LHsCmd GhcPs -> PV (Located b) + ecpFromCmd' :: LHsCmd GhcPs -> PV (LocatedA b) -- | Return an expression without ambiguity, or fail in a non-expression context. - ecpFromExp' :: LHsExpr GhcPs -> PV (Located b) - -- | This can only be satified by expressions. - mkHsProjUpdatePV :: SrcSpan -> Located [Located FieldLabelString] -> Located b -> Bool -> PV (LHsRecProj GhcPs (Located b)) + ecpFromExp' :: LHsExpr GhcPs -> PV (LocatedA b) + mkHsProjUpdatePV :: SrcSpan -> Located [Located (HsFieldLabel GhcPs)] + -> LocatedA b -> Bool -> [AddApiAnn] -> PV (LHsRecProj GhcPs (LocatedA b)) -- | Disambiguate "\... -> ..." (lambda) - mkHsLamPV :: SrcSpan -> MatchGroup GhcPs (Located b) -> PV (Located b) + mkHsLamPV + :: SrcSpan -> (ApiAnnComments -> MatchGroup GhcPs (LocatedA b)) -> PV (LocatedA b) -- | Disambiguate "let ... in ..." - mkHsLetPV :: SrcSpan -> LHsLocalBinds GhcPs -> Located b -> PV (Located b) + mkHsLetPV + :: SrcSpan -> HsLocalBinds GhcPs -> LocatedA b -> AnnsLet -> PV (LocatedA b) -- | Infix operator representation type InfixOp b -- | Bring superclass constraints on InfixOp into scope. -- See Note [UndecidableSuperClasses for associated types] - superInfixOp :: (DisambInfixOp (InfixOp b) => PV (Located b )) -> PV (Located b) + superInfixOp + :: (DisambInfixOp (InfixOp b) => PV (LocatedA b )) -> PV (LocatedA b) -- | Disambiguate "f # x" (infix operator) - mkHsOpAppPV :: SrcSpan -> Located b -> Located (InfixOp b) -> Located b -> PV (Located b) + mkHsOpAppPV :: SrcSpan -> LocatedA b -> LocatedN (InfixOp b) -> LocatedA b + -> PV (LocatedA b) -- | Disambiguate "case ... of ..." - mkHsCasePV :: SrcSpan -> LHsExpr GhcPs -> MatchGroup GhcPs (Located b) -> PV (Located b) - -- | Disambiguate @\\case ...@ (lambda case) - mkHsLamCasePV :: SrcSpan -> MatchGroup GhcPs (Located b) -> PV (Located b) + mkHsCasePV :: SrcSpan -> LHsExpr GhcPs -> (LocatedL [LMatch GhcPs (LocatedA b)]) + -> ApiAnnHsCase -> PV (LocatedA b) + mkHsLamCasePV :: SrcSpan -> (LocatedL [LMatch GhcPs (LocatedA b)]) + -> [AddApiAnn] + -> PV (LocatedA b) -- | Function argument representation type FunArg b -- | Bring superclass constraints on FunArg into scope. -- See Note [UndecidableSuperClasses for associated types] - superFunArg :: (DisambECP (FunArg b) => PV (Located b)) -> PV (Located b) + superFunArg :: (DisambECP (FunArg b) => PV (LocatedA b)) -> PV (LocatedA b) -- | Disambiguate "f x" (function application) - mkHsAppPV :: SrcSpan -> Located b -> Located (FunArg b) -> PV (Located b) + mkHsAppPV :: SrcSpanAnnA -> LocatedA b -> LocatedA (FunArg b) -> PV (LocatedA b) -- | Disambiguate "f @t" (visible type application) - mkHsAppTypePV :: SrcSpan -> Located b -> LHsType GhcPs -> PV (Located b) + mkHsAppTypePV :: SrcSpanAnnA -> LocatedA b -> SrcSpan -> LHsType GhcPs -> PV (LocatedA b) -- | Disambiguate "if ... then ... else ..." mkHsIfPV :: SrcSpan -> LHsExpr GhcPs -> Bool -- semicolon? - -> Located b + -> LocatedA b -> Bool -- semicolon? - -> Located b - -> PV (Located b) + -> LocatedA b + -> [AddApiAnn] + -> PV (LocatedA b) -- | Disambiguate "do { ... }" (do notation) mkHsDoPV :: SrcSpan -> Maybe ModuleName -> - Located [LStmt GhcPs (Located b)] -> - PV (Located b) + LocatedL [LStmt GhcPs (LocatedA b)] -> + AnnList -> + PV (LocatedA b) -- | Disambiguate "( ... )" (parentheses) - mkHsParPV :: SrcSpan -> Located b -> PV (Located b) + mkHsParPV :: SrcSpan -> LocatedA b -> AnnParen -> PV (LocatedA b) -- | Disambiguate a variable "f" or a data constructor "MkF". - mkHsVarPV :: Located RdrName -> PV (Located b) + mkHsVarPV :: LocatedN RdrName -> PV (LocatedA b) -- | Disambiguate a monomorphic literal mkHsLitPV :: Located (HsLit GhcPs) -> PV (Located b) -- | Disambiguate an overloaded literal @@ -1327,9 +1474,10 @@ class b ~ (Body b) GhcPs => DisambECP b where -- | Disambiguate a wildcard mkHsWildCardPV :: SrcSpan -> PV (Located b) -- | Disambiguate "a :: t" (type annotation) - mkHsTySigPV :: SrcSpan -> Located b -> LHsType GhcPs -> PV (Located b) + mkHsTySigPV + :: SrcSpanAnnA -> LocatedA b -> LHsType GhcPs -> [AddApiAnn] -> PV (LocatedA b) -- | Disambiguate "[a,b,c]" (list syntax) - mkHsExplicitListPV :: SrcSpan -> [Located b] -> PV (Located b) + mkHsExplicitListPV :: SrcSpan -> [LocatedA b] -> AnnList -> PV (LocatedA b) -- | Disambiguate "$(...)" and "[quasi|...|]" (TH splices) mkHsSplicePV :: Located (HsSplice GhcPs) -> PV (Located b) -- | Disambiguate "f { a = b, ... }" syntax (record construction and record updates) @@ -1337,25 +1485,30 @@ class b ~ (Body b) GhcPs => DisambECP b where Bool -> -- Is OverloadedRecordUpdate in effect? SrcSpan -> SrcSpan -> - Located b -> + LocatedA b -> ([Fbind b], Maybe SrcSpan) -> - PV (Located b) + [AddApiAnn] -> + PV (LocatedA b) -- | Disambiguate "-a" (negation) - mkHsNegAppPV :: SrcSpan -> Located b -> PV (Located b) + mkHsNegAppPV :: SrcSpan -> LocatedA b -> [AddApiAnn] -> PV (LocatedA b) -- | Disambiguate "(# a)" (right operator section) - mkHsSectionR_PV :: SrcSpan -> Located (InfixOp b) -> Located b -> PV (Located b) + mkHsSectionR_PV + :: SrcSpan -> LocatedA (InfixOp b) -> LocatedA b -> PV (Located b) -- | Disambiguate "(a -> b)" (view pattern) - mkHsViewPatPV :: SrcSpan -> LHsExpr GhcPs -> Located b -> PV (Located b) + mkHsViewPatPV + :: SrcSpan -> LHsExpr GhcPs -> LocatedA b -> [AddApiAnn] -> PV (LocatedA b) -- | Disambiguate "a@b" (as-pattern) - mkHsAsPatPV :: SrcSpan -> Located RdrName -> Located b -> PV (Located b) + mkHsAsPatPV + :: SrcSpan -> LocatedN RdrName -> LocatedA b -> [AddApiAnn] -> PV (LocatedA b) -- | Disambiguate "~a" (lazy pattern) - mkHsLazyPatPV :: SrcSpan -> Located b -> PV (Located b) + mkHsLazyPatPV :: SrcSpan -> LocatedA b -> [AddApiAnn] -> PV (LocatedA b) -- | Disambiguate "!a" (bang pattern) - mkHsBangPatPV :: SrcSpan -> Located b -> PV (Located b) + mkHsBangPatPV :: SrcSpan -> LocatedA b -> [AddApiAnn] -> PV (LocatedA b) -- | Disambiguate tuple sections and unboxed sums - mkSumOrTuplePV :: SrcSpan -> Boxity -> SumOrTuple b -> PV (Located b) + mkSumOrTuplePV + :: SrcSpanAnnA -> Boxity -> SumOrTuple b -> [AddApiAnn] -> PV (LocatedA b) -- | Validate infixexp LHS to reject unwanted {-# SCC ... #-} pragmas - rejectPragmaPV :: Located b -> PV () + rejectPragmaPV :: LocatedA b -> PV () {- Note [UndecidableSuperClasses for associated types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1404,57 +1557,74 @@ typechecker. instance DisambECP (HsCmd GhcPs) where type Body (HsCmd GhcPs) = HsCmd ecpFromCmd' = return - ecpFromExp' (L l e) = cmdFail l (ppr e) - mkHsProjUpdatePV l _ _ _ = addFatalError $ PsError PsErrOverloadedRecordDotInvalid [] l - mkHsLamPV l mg = return $ L l (HsCmdLam noExtField mg) - mkHsLetPV l bs e = return $ L l (HsCmdLet noExtField bs e) + ecpFromExp' (L l e) = cmdFail (locA l) (ppr e) + mkHsProjUpdatePV l _ _ _ _ = addFatalError $ PsError PsErrOverloadedRecordDotInvalid [] l + mkHsLamPV l mg = do + cs <- getCommentsFor l + return $ L (noAnnSrcSpan l) (HsCmdLam NoExtField (mg cs)) + mkHsLetPV l bs e anns = do + cs <- getCommentsFor l + return $ L (noAnnSrcSpan l) (HsCmdLet (ApiAnn (spanAsAnchor l) anns cs) bs e) type InfixOp (HsCmd GhcPs) = HsExpr GhcPs superInfixOp m = m mkHsOpAppPV l c1 op c2 = do - let cmdArg c = L (getLoc c) $ HsCmdTop noExtField c - return $ L l $ HsCmdArrForm noExtField op Infix Nothing [cmdArg c1, cmdArg c2] - mkHsCasePV l c mg = return $ L l (HsCmdCase noExtField c mg) - mkHsLamCasePV l mg = return $ L l (HsCmdLamCase noExtField mg) + let cmdArg c = L (getLocA c) $ HsCmdTop noExtField c + cs <- getCommentsFor l + return $ L (noAnnSrcSpan l) $ HsCmdArrForm (ApiAnn (spanAsAnchor l) (AnnList Nothing Nothing Nothing [] []) cs) (reLocL op) Infix Nothing [cmdArg c1, cmdArg c2] + mkHsCasePV l c (L lm m) anns = do + cs <- getCommentsFor l + let mg = mkMatchGroup FromSource (L lm m) + return $ L (noAnnSrcSpan l) (HsCmdCase (ApiAnn (spanAsAnchor l) anns cs) c mg) + mkHsLamCasePV l (L lm m) anns = do + cs <- getCommentsFor l + let mg = mkMatchGroup FromSource (L lm m) + return $ L (noAnnSrcSpan l) (HsCmdLamCase (ApiAnn (spanAsAnchor l) anns cs) mg) type FunArg (HsCmd GhcPs) = HsExpr GhcPs superFunArg m = m mkHsAppPV l c e = do + cs <- getCommentsFor (locA l) checkCmdBlockArguments c checkExpBlockArguments e - return $ L l (HsCmdApp noExtField c e) - mkHsAppTypePV l c t = cmdFail l (ppr c <+> text "@" <> ppr t) - mkHsIfPV l c semi1 a semi2 b = do + return $ L l (HsCmdApp (comment (realSrcSpan $ locA l) cs) c e) + mkHsAppTypePV l c _ t = cmdFail (locA l) (ppr c <+> text "@" <> ppr t) + mkHsIfPV l c semi1 a semi2 b anns = do checkDoAndIfThenElse PsErrSemiColonsInCondCmd c semi1 a semi2 b - return $ L l (mkHsCmdIf c a b) - mkHsDoPV l Nothing stmts = return $ L l (HsCmdDo noExtField stmts) - mkHsDoPV l (Just m) _ = addFatalError $ PsError (PsErrQualifiedDoInCmd m) [] l - mkHsParPV l c = return $ L l (HsCmdPar noExtField c) - mkHsVarPV (L l v) = cmdFail l (ppr v) + cs <- getCommentsFor l + return $ L (noAnnSrcSpan l) (mkHsCmdIf c a b (ApiAnn (spanAsAnchor l) anns cs)) + mkHsDoPV l Nothing stmts anns = do + cs <- getCommentsFor l + return $ L (noAnnSrcSpan l) (HsCmdDo (ApiAnn (spanAsAnchor l) anns cs) stmts) + mkHsDoPV l (Just m) _ _ = addFatalError $ PsError (PsErrQualifiedDoInCmd m) [] l + mkHsParPV l c ann = do + cs <- getCommentsFor l + return $ L (noAnnSrcSpan l) (HsCmdPar (ApiAnn (spanAsAnchor l) ann cs) c) + mkHsVarPV (L l v) = cmdFail (locA l) (ppr v) mkHsLitPV (L l a) = cmdFail l (ppr a) mkHsOverLitPV (L l a) = cmdFail l (ppr a) mkHsWildCardPV l = cmdFail l (text "_") - mkHsTySigPV l a sig = cmdFail l (ppr a <+> text "::" <+> ppr sig) - mkHsExplicitListPV l xs = cmdFail l $ + mkHsTySigPV l a sig _ = cmdFail (locA l) (ppr a <+> text "::" <+> ppr sig) + mkHsExplicitListPV l xs _ = cmdFail l $ brackets (fsep (punctuate comma (map ppr xs))) mkHsSplicePV (L l sp) = cmdFail l (ppr sp) - mkHsRecordPV _ l _ a (fbinds, ddLoc) = do + mkHsRecordPV _ l _ a (fbinds, ddLoc) _ = do let (fs, ps) = partitionEithers fbinds if not (null ps) then addFatalError $ PsError PsErrOverloadedRecordDotInvalid [] l else cmdFail l $ ppr a <+> ppr (mk_rec_fields fs ddLoc) - mkHsNegAppPV l a = cmdFail l (text "-" <> ppr a) + mkHsNegAppPV l a _ = cmdFail l (text "-" <> ppr a) mkHsSectionR_PV l op c = cmdFail l $ let pp_op = fromMaybe (panic "cannot print infix operator") (ppr_infix_expr (unLoc op)) in pp_op <> ppr c - mkHsViewPatPV l a b = cmdFail l $ + mkHsViewPatPV l a b _ = cmdFail l $ ppr a <+> text "->" <+> ppr b - mkHsAsPatPV l v c = cmdFail l $ + mkHsAsPatPV l v c _ = cmdFail l $ pprPrefixOcc (unLoc v) <> text "@" <> ppr c - mkHsLazyPatPV l c = cmdFail l $ + mkHsLazyPatPV l c _ = cmdFail l $ text "~" <> ppr c - mkHsBangPatPV l c = cmdFail l $ + mkHsBangPatPV l c _ = cmdFail l $ text "!" <> ppr c - mkSumOrTuplePV l boxity a = cmdFail l (pprSumOrTuple boxity a) + mkSumOrTuplePV l boxity a _ = cmdFail (locA l) (pprSumOrTuple boxity a) rejectPragmaPV _ = return () cmdFail :: SrcSpan -> SDoc -> PV a @@ -1463,121 +1633,172 @@ cmdFail loc e = addFatalError $ PsError (PsErrParseErrorInCmd e) [] loc instance DisambECP (HsExpr GhcPs) where type Body (HsExpr GhcPs) = HsExpr ecpFromCmd' (L l c) = do - addError $ PsError (PsErrArrowCmdInExpr c) [] l - return (L l hsHoleExpr) + addError $ PsError (PsErrArrowCmdInExpr c) [] (locA l) + return (L l (hsHoleExpr noAnn)) ecpFromExp' = return - mkHsProjUpdatePV l fields arg isPun = return $ mkRdrProjUpdate l fields arg isPun - mkHsLamPV l mg = return $ L l (HsLam noExtField mg) - mkHsLetPV l bs c = return $ L l (HsLet noExtField bs c) + mkHsProjUpdatePV l fields arg isPun anns = do + cs <- getCommentsFor l + return $ mkRdrProjUpdate (noAnnSrcSpan l) fields arg isPun (ApiAnn (spanAsAnchor l) anns cs) + mkHsLamPV l mg = do + cs <- getCommentsFor l + return $ L (noAnnSrcSpan l) (HsLam NoExtField (mg cs)) + mkHsLetPV l bs c anns = do + cs <- getCommentsFor l + return $ L (noAnnSrcSpan l) (HsLet (ApiAnn (spanAsAnchor l) anns cs) bs c) type InfixOp (HsExpr GhcPs) = HsExpr GhcPs superInfixOp m = m - mkHsOpAppPV l e1 op e2 = - return $ L l $ OpApp noExtField e1 op e2 - mkHsCasePV l e mg = return $ L l (HsCase noExtField e mg) - mkHsLamCasePV l mg = return $ L l (HsLamCase noExtField mg) + mkHsOpAppPV l e1 op e2 = do + cs <- getCommentsFor l + return $ L (noAnnSrcSpan l) $ OpApp (ApiAnn (spanAsAnchor l) [] cs) e1 (reLocL op) e2 + mkHsCasePV l e (L lm m) anns = do + cs <- getCommentsFor l + let mg = mkMatchGroup FromSource (L lm m) + return $ L (noAnnSrcSpan l) (HsCase (ApiAnn (spanAsAnchor l) anns cs) e mg) + mkHsLamCasePV l (L lm m) anns = do + cs <- getCommentsFor l + let mg = mkMatchGroup FromSource (L lm m) + return $ L (noAnnSrcSpan l) (HsLamCase (ApiAnn (spanAsAnchor l) anns cs) mg) type FunArg (HsExpr GhcPs) = HsExpr GhcPs superFunArg m = m mkHsAppPV l e1 e2 = do + cs <- getCommentsFor (locA l) checkExpBlockArguments e1 checkExpBlockArguments e2 - return $ L l (HsApp noExtField e1 e2) - mkHsAppTypePV l e t = do + return $ L l (HsApp (comment (realSrcSpan $ locA l) cs) e1 e2) + mkHsAppTypePV l e la t = do checkExpBlockArguments e - return $ L l (HsAppType noExtField e (mkHsWildCardBndrs t)) - mkHsIfPV l c semi1 a semi2 b = do + return $ L l (HsAppType la e (mkHsWildCardBndrs t)) + mkHsIfPV l c semi1 a semi2 b anns = do checkDoAndIfThenElse PsErrSemiColonsInCondExpr c semi1 a semi2 b - return $ L l (mkHsIf c a b) - mkHsDoPV l mod stmts = return $ L l (HsDo noExtField (DoExpr mod) stmts) - mkHsParPV l e = return $ L l (HsPar noExtField e) - mkHsVarPV v@(getLoc -> l) = return $ L l (HsVar noExtField v) - mkHsLitPV (L l a) = return $ L l (HsLit noExtField a) - mkHsOverLitPV (L l a) = return $ L l (HsOverLit noExtField a) - mkHsWildCardPV l = return $ L l hsHoleExpr - mkHsTySigPV l a sig = return $ L l (ExprWithTySig noExtField a (hsTypeToHsSigWcType sig)) - mkHsExplicitListPV l xs = return $ L l (ExplicitList noExtField xs) - mkHsSplicePV sp = return $ mapLoc (HsSpliceE noExtField) sp - mkHsRecordPV opts l lrec a (fbinds, ddLoc) = do - r <- mkRecConstrOrUpdate opts a lrec (fbinds, ddLoc) - checkRecordSyntax (L l r) - mkHsNegAppPV l a = return $ L l (NegApp noExtField a noSyntaxExpr) - mkHsSectionR_PV l op e = return $ L l (SectionR noExtField op e) - mkHsViewPatPV l a b = addError (PsError (PsErrViewPatInExpr a b) [] l) - >> return (L l hsHoleExpr) - mkHsAsPatPV l v e = addError (PsError (PsErrTypeAppWithoutSpace (unLoc v) e) [] l) - >> return (L l hsHoleExpr) - mkHsLazyPatPV l e = addError (PsError (PsErrLazyPatWithoutSpace e) [] l) - >> return (L l hsHoleExpr) - mkHsBangPatPV l e = addError (PsError (PsErrBangPatWithoutSpace e) [] l) - >> return (L l hsHoleExpr) + cs <- getCommentsFor l + return $ L (noAnnSrcSpan l) (mkHsIf c a b (ApiAnn (spanAsAnchor l) anns cs)) + mkHsDoPV l mod stmts anns = do + cs <- getCommentsFor l + return $ L (noAnnSrcSpan l) (HsDo (ApiAnn (spanAsAnchor l) anns cs) (DoExpr mod) stmts) + mkHsParPV l e ann = do + cs <- getCommentsFor l + return $ L (noAnnSrcSpan l) (HsPar (ApiAnn (spanAsAnchor l) ann cs) e) + mkHsVarPV v@(L l _) = return $ L (na2la l) (HsVar noExtField v) + mkHsLitPV (L l a) = do + cs <- getCommentsFor l + return $ L l (HsLit (comment (realSrcSpan l) cs) a) + mkHsOverLitPV (L l a) = do + cs <- getCommentsFor l + return $ L l (HsOverLit (comment (realSrcSpan l) cs) a) + mkHsWildCardPV l = return $ L l (hsHoleExpr noAnn) + mkHsTySigPV l a sig anns = do + cs <- getCommentsFor (locA l) + return $ L l (ExprWithTySig (ApiAnn (spanAsAnchor $ locA l) anns cs) a (hsTypeToHsSigWcType sig)) + mkHsExplicitListPV l xs anns = do + cs <- getCommentsFor l + return $ L (noAnnSrcSpan l) (ExplicitList (ApiAnn (spanAsAnchor l) anns cs) xs) + mkHsSplicePV sp@(L l _) = do + cs <- getCommentsFor l + return $ mapLoc (HsSpliceE (ApiAnn (spanAsAnchor l) NoApiAnns cs)) sp + mkHsRecordPV opts l lrec a (fbinds, ddLoc) anns = do + cs <- getCommentsFor l + r <- mkRecConstrOrUpdate opts a lrec (fbinds, ddLoc) (ApiAnn (spanAsAnchor l) anns cs) + checkRecordSyntax (L (noAnnSrcSpan l) r) + mkHsNegAppPV l a anns = do + cs <- getCommentsFor l + return $ L (noAnnSrcSpan l) (NegApp (ApiAnn (spanAsAnchor l) anns cs) a noSyntaxExpr) + mkHsSectionR_PV l op e = do + cs <- getCommentsFor l + return $ L l (SectionR (comment (realSrcSpan l) cs) op e) + mkHsViewPatPV l a b _ = addError (PsError (PsErrViewPatInExpr a b) [] l) + >> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn)) + mkHsAsPatPV l v e _ = addError (PsError (PsErrTypeAppWithoutSpace (unLoc v) e) [] l) + >> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn)) + mkHsLazyPatPV l e _ = addError (PsError (PsErrLazyPatWithoutSpace e) [] l) + >> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn)) + mkHsBangPatPV l e _ = addError (PsError (PsErrBangPatWithoutSpace e) [] l) + >> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn)) mkSumOrTuplePV = mkSumOrTupleExpr rejectPragmaPV (L _ (OpApp _ _ _ e)) = -- assuming left-associative parsing of operators rejectPragmaPV e - rejectPragmaPV (L l (HsPragE _ prag _)) = addError $ PsError (PsErrUnallowedPragma prag) [] l + rejectPragmaPV (L l (HsPragE _ prag _)) = addError $ PsError (PsErrUnallowedPragma prag) [] (locA l) rejectPragmaPV _ = return () -hsHoleExpr :: HsExpr GhcPs -hsHoleExpr = HsUnboundVar noExtField (mkVarOcc "_") +hsHoleExpr :: ApiAnn' ApiAnnUnboundVar -> HsExpr GhcPs +hsHoleExpr anns = HsUnboundVar anns (mkVarOcc "_") + +type instance Anno (GRHS GhcPs (LocatedA (PatBuilder GhcPs))) = SrcSpan +type instance Anno [LocatedA (Match GhcPs (LocatedA (PatBuilder GhcPs)))] = SrcSpanAnnL +type instance Anno (Match GhcPs (LocatedA (PatBuilder GhcPs))) = SrcSpanAnnA +type instance Anno (StmtLR GhcPs GhcPs (LocatedA (PatBuilder GhcPs))) = SrcSpanAnnA instance DisambECP (PatBuilder GhcPs) where type Body (PatBuilder GhcPs) = PatBuilder - ecpFromCmd' (L l c) = addFatalError $ PsError (PsErrArrowCmdInPat c) [] l - ecpFromExp' (L l e) = addFatalError $ PsError (PsErrArrowExprInPat e) [] l + ecpFromCmd' (L l c) = addFatalError $ PsError (PsErrArrowCmdInPat c) [] (locA l) + ecpFromExp' (L l e) = addFatalError $ PsError (PsErrArrowExprInPat e) [] (locA l) mkHsLamPV l _ = addFatalError $ PsError PsErrLambdaInPat [] l - mkHsLetPV l _ _ = addFatalError $ PsError PsErrLetInPat [] l - mkHsProjUpdatePV l _ _ _ = addFatalError $ PsError PsErrOverloadedRecordDotInvalid [] l + mkHsLetPV l _ _ _ = addFatalError $ PsError PsErrLetInPat [] l + mkHsProjUpdatePV l _ _ _ _ = addFatalError $ PsError PsErrOverloadedRecordDotInvalid [] l type InfixOp (PatBuilder GhcPs) = RdrName superInfixOp m = m - mkHsOpAppPV l p1 op p2 = return $ L l $ PatBuilderOpApp p1 op p2 - mkHsCasePV l _ _ = addFatalError $ PsError PsErrCaseInPat [] l - mkHsLamCasePV l _ = addFatalError $ PsError PsErrLambdaCaseInPat [] l + mkHsOpAppPV l p1 op p2 = do + cs <- getCommentsFor l + let anns = ApiAnn (spanAsAnchor l) [] cs + return $ L (noAnnSrcSpan l) $ PatBuilderOpApp p1 op p2 anns + mkHsCasePV l _ _ _ = addFatalError $ PsError PsErrCaseInPat [] l + mkHsLamCasePV l _ _ = addFatalError $ PsError PsErrLambdaCaseInPat [] l type FunArg (PatBuilder GhcPs) = PatBuilder GhcPs superFunArg m = m - mkHsAppPV l p1 p2 = return $ L l (PatBuilderApp p1 p2) - mkHsAppTypePV l p t = return $ L l (PatBuilderAppType p (mkHsPatSigType t)) - mkHsIfPV l _ _ _ _ _ = addFatalError $ PsError PsErrIfTheElseInPat [] l - mkHsDoPV l _ _ = addFatalError $ PsError PsErrDoNotationInPat [] l - mkHsParPV l p = return $ L l (PatBuilderPar p) - mkHsVarPV v@(getLoc -> l) = return $ L l (PatBuilderVar v) + mkHsAppPV l p1 p2 = return $ L l (PatBuilderApp p1 p2) + mkHsAppTypePV l p la t = return $ L l (PatBuilderAppType p la (mkHsPatSigType t)) + mkHsIfPV l _ _ _ _ _ _ = addFatalError $ PsError PsErrIfTheElseInPat [] l + mkHsDoPV l _ _ _ = addFatalError $ PsError PsErrDoNotationInPat [] l + mkHsParPV l p an = return $ L (noAnnSrcSpan l) (PatBuilderPar p an) + mkHsVarPV v@(getLoc -> l) = return $ L (na2la l) (PatBuilderVar v) mkHsLitPV lit@(L l a) = do checkUnboxedStringLitPat lit return $ L l (PatBuilderPat (LitPat noExtField a)) mkHsOverLitPV (L l a) = return $ L l (PatBuilderOverLit a) mkHsWildCardPV l = return $ L l (PatBuilderPat (WildPat noExtField)) - mkHsTySigPV l b sig = do + mkHsTySigPV l b sig anns = do p <- checkLPat b - return $ L l (PatBuilderPat (SigPat noExtField p (mkHsPatSigType sig))) - mkHsExplicitListPV l xs = do + cs <- getCommentsFor (locA l) + return $ L l (PatBuilderPat (SigPat (ApiAnn (spanAsAnchor $ locA l) anns cs) p (mkHsPatSigType sig))) + mkHsExplicitListPV l xs anns = do ps <- traverse checkLPat xs - return (L l (PatBuilderPat (ListPat noExtField ps))) + cs <- getCommentsFor l + return (L (noAnnSrcSpan l) (PatBuilderPat (ListPat (ApiAnn (spanAsAnchor l) anns cs) ps))) mkHsSplicePV (L l sp) = return $ L l (PatBuilderPat (SplicePat noExtField sp)) - mkHsRecordPV _ l _ a (fbinds, ddLoc) = do + mkHsRecordPV _ l _ a (fbinds, ddLoc) anns = do let (fs, ps) = partitionEithers fbinds if not (null ps) then addFatalError $ PsError PsErrOverloadedRecordDotInvalid [] l else do - r <- mkPatRec a (mk_rec_fields fs ddLoc) - checkRecordSyntax (L l r) - mkHsNegAppPV l (L lp p) = do + cs <- getCommentsFor l + r <- mkPatRec a (mk_rec_fields fs ddLoc) (ApiAnn (spanAsAnchor l) anns cs) + checkRecordSyntax (L (noAnnSrcSpan l) r) + mkHsNegAppPV l (L lp p) anns = do lit <- case p of - PatBuilderOverLit pos_lit -> return (L lp pos_lit) + PatBuilderOverLit pos_lit -> return (L (locA lp) pos_lit) _ -> patFail l (text "-" <> ppr p) - return $ L l (PatBuilderPat (mkNPat lit (Just noSyntaxExpr))) + cs <- getCommentsFor l + let an = ApiAnn (spanAsAnchor l) anns cs + return $ L (noAnnSrcSpan l) (PatBuilderPat (mkNPat lit (Just noSyntaxExpr) an)) mkHsSectionR_PV l op p = patFail l (pprInfixOcc (unLoc op) <> ppr p) - mkHsViewPatPV l a b = do + mkHsViewPatPV l a b anns = do p <- checkLPat b - return $ L l (PatBuilderPat (ViewPat noExtField a p)) - mkHsAsPatPV l v e = do + cs <- getCommentsFor l + return $ L (noAnnSrcSpan l) (PatBuilderPat (ViewPat (ApiAnn (spanAsAnchor l) anns cs) a p)) + mkHsAsPatPV l v e a = do p <- checkLPat e - return $ L l (PatBuilderPat (AsPat noExtField v p)) - mkHsLazyPatPV l e = do + cs <- getCommentsFor l + return $ L (noAnnSrcSpan l) (PatBuilderPat (AsPat (ApiAnn (spanAsAnchor l) a cs) v p)) + mkHsLazyPatPV l e a = do p <- checkLPat e - return $ L l (PatBuilderPat (LazyPat noExtField p)) - mkHsBangPatPV l e = do + cs <- getCommentsFor l + return $ L (noAnnSrcSpan l) (PatBuilderPat (LazyPat (ApiAnn (spanAsAnchor l) a cs) p)) + mkHsBangPatPV l e an = do p <- checkLPat e - let pb = BangPat noExtField p + cs <- getCommentsFor l + let pb = BangPat (ApiAnn (spanAsAnchor l) an cs) p hintBangPat l pb - return $ L l (PatBuilderPat pb) + return $ L (noAnnSrcSpan l) (PatBuilderPat pb) mkSumOrTuplePV = mkSumOrTuplePat rejectPragmaPV _ = return () @@ -1589,19 +1810,20 @@ checkUnboxedStringLitPat (L loc lit) = _ -> return () mkPatRec :: - Located (PatBuilder GhcPs) -> - HsRecFields GhcPs (Located (PatBuilder GhcPs)) -> + LocatedA (PatBuilder GhcPs) -> + HsRecFields GhcPs (LocatedA (PatBuilder GhcPs)) -> + ApiAnn -> PV (PatBuilder GhcPs) -mkPatRec (unLoc -> PatBuilderVar c) (HsRecFields fs dd) +mkPatRec (unLoc -> PatBuilderVar c) (HsRecFields fs dd) anns | isRdrDataCon (unLoc c) = do fs <- mapM checkPatField fs return $ PatBuilderPat $ ConPat - { pat_con_ext = noExtField + { pat_con_ext = anns , pat_con = c , pat_args = RecCon (HsRecFields fs dd) } -mkPatRec p _ = - addFatalError $ PsError (PsErrInvalidRecordCon (unLoc p)) [] (getLoc p) +mkPatRec p _ _ = + addFatalError $ PsError (PsErrInvalidRecordCon (unLoc p)) [] (getLocA p) -- | Disambiguate constructs that may appear when we do not know -- ahead of time whether we are parsing a type or a newtype/data constructor. @@ -1614,25 +1836,24 @@ mkPatRec p _ = class DisambTD b where -- | Process the head of a type-level function/constructor application, -- i.e. the @H@ in @H a b c@. - mkHsAppTyHeadPV :: LHsType GhcPs -> PV (Located b) + mkHsAppTyHeadPV :: LHsType GhcPs -> PV (LocatedA b) -- | Disambiguate @f x@ (function application or prefix data constructor). - mkHsAppTyPV :: Located b -> LHsType GhcPs -> PV (Located b) + mkHsAppTyPV :: LocatedA b -> LHsType GhcPs -> PV (LocatedA b) -- | Disambiguate @f \@t@ (visible kind application) - mkHsAppKindTyPV :: Located b -> SrcSpan -> LHsType GhcPs -> PV (Located b) + mkHsAppKindTyPV :: LocatedA b -> SrcSpan -> LHsType GhcPs -> PV (LocatedA b) -- | Disambiguate @f \# x@ (infix operator) - mkHsOpTyPV :: LHsType GhcPs -> Located RdrName -> LHsType GhcPs -> PV (Located b) + mkHsOpTyPV :: LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> PV (LocatedA b) -- | Disambiguate @{-\# UNPACK \#-} t@ (unpack/nounpack pragma) - mkUnpackednessPV :: Located UnpackednessPragma -> Located b -> PV (Located b) + mkUnpackednessPV :: Located UnpackednessPragma -> LocatedA b -> PV (LocatedA b) instance DisambTD (HsType GhcPs) where mkHsAppTyHeadPV = return mkHsAppTyPV t1 t2 = return (mkHsAppTy t1 t2) - mkHsAppKindTyPV t l_at ki = return (mkHsAppKindTy l' t ki) - where l' = combineSrcSpans l_at (getLoc ki) + mkHsAppKindTyPV t l_at ki = return (mkHsAppKindTy l_at t ki) mkHsOpTyPV t1 op t2 = return (mkLHsOpTy t1 op t2) mkUnpackednessPV = addUnpackednessP -dataConBuilderCon :: DataConBuilder -> Located RdrName +dataConBuilderCon :: DataConBuilder -> LocatedN RdrName dataConBuilderCon (PrefixDataConBuilder _ dc) = dc dataConBuilderCon (InfixDataConBuilder _ dc _) = dc @@ -1641,8 +1862,8 @@ dataConBuilderDetails :: DataConBuilder -> HsConDeclH98Details GhcPs -- Detect when the record syntax is used: -- data T = MkT { ... } dataConBuilderDetails (PrefixDataConBuilder flds _) - | [L l_t (HsRecTy _ fields)] <- toList flds - = RecCon (L l_t fields) + | [L l_t (HsRecTy an fields)] <- toList flds + = RecCon (L (SrcSpanAnn an (locA l_t)) fields) -- Normal prefix constructor, e.g. data T = MkT A B C dataConBuilderDetails (PrefixDataConBuilder flds _) @@ -1657,7 +1878,7 @@ instance DisambTD DataConBuilder where mkHsAppTyPV (L l (PrefixDataConBuilder flds fn)) t = return $ - L (combineSrcSpans l (getLoc t)) + L (noAnnSrcSpan $ combineSrcSpans (locA l) (getLocA t)) (PrefixDataConBuilder (flds `snocOL` t) fn) mkHsAppTyPV (L _ InfixDataConBuilder{}) _ = -- This case is impossible because of the way @@ -1667,15 +1888,15 @@ instance DisambTD DataConBuilder where mkHsAppKindTyPV lhs l_at ki = addFatalError $ PsError (PsErrUnexpectedKindAppInDataCon (unLoc lhs) (unLoc ki)) [] l_at - mkHsOpTyPV lhs (L l_tc tc) rhs = do + mkHsOpTyPV lhs tc rhs = do check_no_ops (unLoc rhs) -- check the RHS because parsing type operators is right-associative - data_con <- eitherToP $ tyConToDataCon l_tc tc + data_con <- eitherToP $ tyConToDataCon tc return $ L l (InfixDataConBuilder lhs data_con rhs) where - l = combineLocs lhs rhs + l = combineLocsA lhs rhs check_no_ops (HsBangTy _ _ t) = check_no_ops (unLoc t) check_no_ops (HsOpTy{}) = - addError $ PsError (PsErrInvalidInfixDataCon (unLoc lhs) tc (unLoc rhs)) [] l + addError $ PsError (PsErrInvalidInfixDataCon (unLoc lhs) (unLoc tc) (unLoc rhs)) [] (locA l) check_no_ops _ = return () mkUnpackednessPV unpk constr_stuff @@ -1683,21 +1904,21 @@ instance DisambTD DataConBuilder where = -- When the user writes data T = {-# UNPACK #-} Int :+ Bool -- we apply {-# UNPACK #-} to the LHS do lhs' <- addUnpackednessP unpk lhs - let l = combineLocs unpk constr_stuff + let l = combineLocsA (reLocA unpk) constr_stuff return $ L l (InfixDataConBuilder lhs' data_con rhs) | otherwise = do addError $ PsError PsErrUnpackDataCon [] (getLoc unpk) return constr_stuff -tyToDataConBuilder :: LHsType GhcPs -> PV (Located DataConBuilder) -tyToDataConBuilder (L l (HsTyVar _ NotPromoted (L _ v))) = do - data_con <- eitherToP $ tyConToDataCon l v +tyToDataConBuilder :: LHsType GhcPs -> PV (LocatedA DataConBuilder) +tyToDataConBuilder (L l (HsTyVar _ NotPromoted v)) = do + data_con <- eitherToP $ tyConToDataCon v return $ L l (PrefixDataConBuilder nilOL data_con) tyToDataConBuilder (L l (HsTupleTy _ HsBoxedOrConstraintTuple ts)) = do - let data_con = L l (getRdrName (tupleDataCon Boxed (length ts))) + let data_con = L (l2l l) (getRdrName (tupleDataCon Boxed (length ts))) return $ L l (PrefixDataConBuilder (toOL ts) data_con) tyToDataConBuilder t = - addFatalError $ PsError (PsErrInvalidDataCon (unLoc t)) [] (getLoc t) + addFatalError $ PsError (PsErrInvalidDataCon (unLoc t)) [] (getLocA t) {- Note [Ambiguous syntactic categories] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1768,13 +1989,13 @@ see Note [PatBuilder]). Consider the 'alts' production used to parse case-of alternatives: - alts :: { Located ([AddAnn],[LMatch GhcPs (LHsExpr GhcPs)]) } + alts :: { Located ([AddApiAnn],[LMatch GhcPs (LHsExpr GhcPs)]) } : alts1 { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } | ';' alts { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) } We abstract over LHsExpr GhcPs, and it becomes: - alts :: { forall b. DisambECP b => PV (Located ([AddAnn],[LMatch GhcPs (Located b)])) } + alts :: { forall b. DisambECP b => PV (Located ([AddApiAnn],[LMatch GhcPs (Located b)])) } : alts1 { $1 >>= \ $1 -> return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } | ';' alts { $2 >>= \ $2 -> @@ -1994,15 +2215,15 @@ However, there is a slight problem with this approach, namely code duplication in parser productions. Consider the 'alts' production used to parse case-of alternatives: - alts :: { Located ([AddAnn],[LMatch GhcPs (LHsExpr GhcPs)]) } + alts :: { Located ([AddApiAnn],[LMatch GhcPs (LHsExpr GhcPs)]) } : alts1 { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } | ';' alts { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) } Under the new scheme, we have to completely duplicate its type signature and each reduction rule: - alts :: { ( PV (Located ([AddAnn],[LMatch GhcPs (LHsExpr GhcPs)])) -- as an expression - , PV (Located ([AddAnn],[LMatch GhcPs (LHsCmd GhcPs)])) -- as a command + alts :: { ( PV (Located ([AddApiAnn],[LMatch GhcPs (LHsExpr GhcPs)])) -- as an expression + , PV (Located ([AddApiAnn],[LMatch GhcPs (LHsCmd GhcPs)])) -- as a command ) } : alts1 { ( checkExpOf2 $1 >>= \ $1 -> @@ -2038,13 +2259,13 @@ as a function from a GADT: Consider the 'alts' production used to parse case-of alternatives: - alts :: { Located ([AddAnn],[LMatch GhcPs (LHsExpr GhcPs)]) } + alts :: { Located ([AddApiAnn],[LMatch GhcPs (LHsExpr GhcPs)]) } : alts1 { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } | ';' alts { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) } We abstract over LHsExpr, and it becomes: - alts :: { forall b. ExpCmdG b -> PV (Located ([AddAnn],[LMatch GhcPs (Located (b GhcPs))])) } + alts :: { forall b. ExpCmdG b -> PV (Located ([AddApiAnn],[LMatch GhcPs (Located (b GhcPs))])) } : alts1 { \tag -> $1 tag >>= \ $1 -> return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } @@ -2068,7 +2289,7 @@ the scenes: And now the 'alts' production is simplified, as we no longer need to thread 'tag' explicitly: - alts :: { forall b. ExpCmdI b => PV (Located ([AddAnn],[LMatch GhcPs (Located (b GhcPs))])) } + alts :: { forall b. ExpCmdI b => PV (Located ([AddApiAnn],[LMatch GhcPs (Located (b GhcPs))])) } : alts1 { $1 >>= \ $1 -> return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } | ';' alts { $2 >>= \ $2 -> @@ -2125,8 +2346,8 @@ parsing results for patterns and function bindings: data PatBuilder p = PatBuilderPat (Pat p) - | PatBuilderApp (Located (PatBuilder p)) (Located (PatBuilder p)) - | PatBuilderOpApp (Located (PatBuilder p)) (Located RdrName) (Located (PatBuilder p)) + | PatBuilderApp (LocatedA (PatBuilder p)) (LocatedA (PatBuilder p)) + | PatBuilderOpApp (LocatedA (PatBuilder p)) (LocatedA RdrName) (LocatedA (PatBuilder p)) ... It can represent any pattern via 'PatBuilderPat', but it also has a variety of @@ -2140,8 +2361,8 @@ pattern match on the pattern stored inside 'PatBuilderPat'. -- | Check if a fixity is valid. We support bypassing the usual bound checks -- for some special operators. checkPrecP - :: Located (SourceText,Int) -- ^ precedence - -> Located (OrdList (Located RdrName)) -- ^ operators + :: Located (SourceText,Int) -- ^ precedence + -> Located (OrdList (LocatedN RdrName)) -- ^ operators -> P () checkPrecP (L l (_,i)) (L _ ol) | 0 <= i, i <= maxPrecedence = pure () @@ -2157,20 +2378,21 @@ mkRecConstrOrUpdate -> LHsExpr GhcPs -> SrcSpan -> ([Fbind (HsExpr GhcPs)], Maybe SrcSpan) + -> ApiAnn -> PV (HsExpr GhcPs) -mkRecConstrOrUpdate _ (L l (HsVar _ (L _ c))) _lrec (fbinds,dd) +mkRecConstrOrUpdate _ (L _ (HsVar _ (L l c))) _lrec (fbinds,dd) anns | isRdrDataCon c = do let (fs, ps) = partitionEithers fbinds if not (null ps) - then addFatalError $ PsError PsErrOverloadedRecordDotInvalid [] (getLoc (head ps)) - else return (mkRdrRecordCon (L l c) (mk_rec_fields fs dd)) -mkRecConstrOrUpdate overloaded_update exp _ (fs,dd) + then addFatalError $ PsError PsErrOverloadedRecordDotInvalid [] (getLocA (head ps)) + else return (mkRdrRecordCon (L l c) (mk_rec_fields fs dd) anns) +mkRecConstrOrUpdate overloaded_update exp _ (fs,dd) anns | Just dd_loc <- dd = addFatalError $ PsError PsErrDotsInRecordUpdate [] dd_loc - | otherwise = mkRdrRecordUpd overloaded_update exp fs + | otherwise = mkRdrRecordUpd overloaded_update exp fs anns -mkRdrRecordUpd :: Bool -> LHsExpr GhcPs -> [Fbind (HsExpr GhcPs)] -> PV (HsExpr GhcPs) -mkRdrRecordUpd overloaded_on exp@(L loc _) fbinds = do +mkRdrRecordUpd :: Bool -> LHsExpr GhcPs -> [Fbind (HsExpr GhcPs)] -> ApiAnn -> PV (HsExpr GhcPs) +mkRdrRecordUpd overloaded_on exp@(L loc _) fbinds anns = do -- We do not need to know if OverloadedRecordDot is in effect. We do -- however need to know if OverloadedRecordUpdate (passed in -- overloaded_on) is in effect because it affects the Left/Right nature @@ -2180,16 +2402,16 @@ mkRdrRecordUpd overloaded_on exp@(L loc _) fbinds = do case overloaded_on of False | not $ null ps -> -- A '.' was found in an update and OverloadedRecordUpdate isn't on. - addFatalError $ PsError PsErrOverloadedRecordUpdateNotEnabled [] loc + addFatalError $ PsError PsErrOverloadedRecordUpdateNotEnabled [] (locA loc) False -> -- This is just a regular record update. return RecordUpd { - rupd_ext = noExtField + rupd_ext = anns , rupd_expr = exp , rupd_flds = Left fs' } True -> do let qualifiedFields = - [ L l lbl | L _ (HsRecField (L l lbl) _ _) <- fs' + [ L l lbl | L _ (HsRecField _ (L l lbl) _ _) <- fs' , isQual . rdrNameAmbiguousFieldOcc $ lbl ] if not $ null qualifiedFields @@ -2197,7 +2419,7 @@ mkRdrRecordUpd overloaded_on exp@(L loc _) fbinds = do addFatalError $ PsError PsErrOverloadedRecordUpdateNoQualifiedFields [] (getLoc (head qualifiedFields)) else -- This is a RecordDotSyntax update. return RecordUpd { - rupd_ext = noExtField + rupd_ext = anns , rupd_expr = exp , rupd_flds = Right (toProjUpdates fbinds) } where @@ -2207,30 +2429,33 @@ mkRdrRecordUpd overloaded_on exp@(L loc _) fbinds = do -- Convert a top-level field update like {foo=2} or {bar} (punned) -- to a projection update. recFieldToProjUpdate :: LHsRecField GhcPs (LHsExpr GhcPs) -> LHsRecUpdProj GhcPs - recFieldToProjUpdate (L l (HsRecField (L _ (FieldOcc _ (L loc rdr))) arg pun)) = + recFieldToProjUpdate (L l (HsRecField anns (L _ (FieldOcc _ (L loc rdr))) arg pun)) = -- The idea here is to convert the label to a singleton [FastString]. let f = occNameFS . rdrNameOcc $ rdr - in mkRdrProjUpdate l (L loc [L loc f]) (punnedVar f) pun + fl = HsFieldLabel noAnn (L lf f) -- AZ: what about the ann? + lf = locA loc + in mkRdrProjUpdate l (L lf [L lf fl]) (punnedVar f) pun anns where -- If punning, compute HsVar "f" otherwise just arg. This -- has the effect that sentinel HsVar "pun-rhs" is replaced -- by HsVar "f" here, before the update is written to a -- setField expressions. punnedVar :: FastString -> LHsExpr GhcPs - punnedVar f = if not pun then arg else noLoc . HsVar noExtField . noLoc . mkRdrUnqual . mkVarOccFS $ f + punnedVar f = if not pun then arg else noLocA . HsVar noExtField . noLocA . mkRdrUnqual . mkVarOccFS $ f -mkRdrRecordCon :: Located RdrName -> HsRecordBinds GhcPs -> HsExpr GhcPs -mkRdrRecordCon con flds - = RecordCon { rcon_ext = noExtField, rcon_con = con, rcon_flds = flds } +mkRdrRecordCon + :: LocatedN RdrName -> HsRecordBinds GhcPs -> ApiAnn -> HsExpr GhcPs +mkRdrRecordCon con flds anns + = RecordCon { rcon_ext = anns, rcon_con = con, rcon_flds = flds } -mk_rec_fields :: [Located (HsRecField (GhcPass p) arg)] -> Maybe SrcSpan -> HsRecFields (GhcPass p) arg +mk_rec_fields :: [LocatedA (HsRecField (GhcPass p) arg)] -> Maybe SrcSpan -> HsRecFields (GhcPass p) arg mk_rec_fields fs Nothing = HsRecFields { rec_flds = fs, rec_dotdot = Nothing } mk_rec_fields fs (Just s) = HsRecFields { rec_flds = fs , rec_dotdot = Just (L s (length fs)) } mk_rec_upd_field :: HsRecField GhcPs (LHsExpr GhcPs) -> HsRecUpdField GhcPs -mk_rec_upd_field (HsRecField (L loc (FieldOcc _ rdr)) arg pun) - = HsRecField (L loc (Unambiguous noExtField rdr)) arg pun +mk_rec_upd_field (HsRecField noAnn (L loc (FieldOcc _ rdr)) arg pun) + = HsRecField noAnn (L loc (Unambiguous noExtField rdr)) arg pun mkInlinePragma :: SourceText -> (InlineSpec, RuleMatchInfo) -> Maybe Activation -> InlinePragma @@ -2257,9 +2482,9 @@ mkInlinePragma src (inl, match_info) mb_act -- mkImport :: Located CCallConv -> Located Safety - -> (Located StringLiteral, Located RdrName, LHsSigType GhcPs) - -> P (HsDecl GhcPs) -mkImport cconv safety (L loc (StringLiteral esrc entity), v, ty) = + -> (Located StringLiteral, LocatedN RdrName, LHsSigType GhcPs) + -> P (ApiAnn -> HsDecl GhcPs) +mkImport cconv safety (L loc (StringLiteral esrc entity _), v, ty) = case unLoc cconv of CCallConv -> mkCImport CApiConv -> mkCImport @@ -2287,8 +2512,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 @@ -2358,11 +2583,11 @@ parseCImport cconv safety nm str sourceText = -- construct a foreign export declaration -- mkExport :: Located CCallConv - -> (Located StringLiteral, Located RdrName, LHsSigType GhcPs) - -> P (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 + -> (Located StringLiteral, LocatedN RdrName, LHsSigType GhcPs) + -> P (ApiAnn -> HsDecl GhcPs) +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) } where @@ -2383,23 +2608,25 @@ mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm)) data ImpExpSubSpec = ImpExpAbs | ImpExpAll - | ImpExpList [Located ImpExpQcSpec] - | ImpExpAllWith [Located ImpExpQcSpec] + | ImpExpList [LocatedA ImpExpQcSpec] + | ImpExpAllWith [LocatedA ImpExpQcSpec] -data ImpExpQcSpec = ImpExpQcName (Located RdrName) - | ImpExpQcType (Located RdrName) +data ImpExpQcSpec = ImpExpQcName (LocatedN RdrName) + | ImpExpQcType AnnAnchor (LocatedN RdrName) | ImpExpQcWildcard -mkModuleImpExp :: Located ImpExpQcSpec -> ImpExpSubSpec -> P (IE GhcPs) -mkModuleImpExp (L l specname) subs = +mkModuleImpExp :: [AddApiAnn] -> LocatedA ImpExpQcSpec -> ImpExpSubSpec -> P (IE GhcPs) +mkModuleImpExp anns (L l specname) subs = do + cs <- getCommentsFor (locA l) -- AZ: IEVar can discard comments + let ann = ApiAnn (spanAsAnchor $ locA l) anns cs case subs of ImpExpAbs | isVarNameSpace (rdrNameSpace name) -> return $ IEVar noExtField (L l (ieNameFromSpec specname)) - | otherwise -> IEThingAbs noExtField . L l <$> nameT - ImpExpAll -> IEThingAll noExtField . L l <$> nameT + | otherwise -> IEThingAbs ann . L l <$> nameT + ImpExpAll -> IEThingAll ann . L l <$> nameT ImpExpList xs -> - (\newName -> IEThingWith noExtField (L l newName) + (\newName -> IEThingWith ann (L l newName) NoIEWildcard (wrapped xs)) <$> nameT ImpExpAllWith xs -> do allowed <- getBit PatternSynonymsBit @@ -2408,49 +2635,50 @@ mkModuleImpExp (L l specname) subs = let withs = map unLoc xs pos = maybe NoIEWildcard IEWildcard (findIndex isImpExpQcWildcard withs) + ies :: [LocatedA (IEWrappedName RdrName)] ies = wrapped $ filter (not . isImpExpQcWildcard . unLoc) xs in (\newName - -> IEThingWith noExtField (L l newName) pos ies) + -> IEThingWith ann (L l newName) pos ies) <$> nameT - else addFatalError $ PsError PsErrIllegalPatSynExport [] l + else addFatalError $ PsError PsErrIllegalPatSynExport [] (locA l) where name = ieNameVal specname nameT = if isVarNameSpace (rdrNameSpace name) - then addFatalError $ PsError (PsErrVarForTyCon name) [] l + then addFatalError $ PsError (PsErrVarForTyCon name) [] (locA l) else return $ ieNameFromSpec specname - ieNameVal (ImpExpQcName ln) = unLoc ln - ieNameVal (ImpExpQcType ln) = unLoc ln - ieNameVal (ImpExpQcWildcard) = panic "ieNameVal got wildcard" + ieNameVal (ImpExpQcName ln) = unLoc ln + ieNameVal (ImpExpQcType _ ln) = unLoc ln + ieNameVal (ImpExpQcWildcard) = panic "ieNameVal got wildcard" - ieNameFromSpec (ImpExpQcName ln) = IEName ln - ieNameFromSpec (ImpExpQcType ln) = IEType ln - ieNameFromSpec (ImpExpQcWildcard) = panic "ieName got wildcard" + ieNameFromSpec (ImpExpQcName ln) = IEName ln + ieNameFromSpec (ImpExpQcType r ln) = IEType r ln + ieNameFromSpec (ImpExpQcWildcard) = panic "ieName got wildcard" wrapped = map (mapLoc ieNameFromSpec) -mkTypeImpExp :: Located RdrName -- TcCls or Var name space - -> P (Located RdrName) +mkTypeImpExp :: LocatedN RdrName -- TcCls or Var name space + -> P (LocatedN RdrName) mkTypeImpExp name = do allowed <- getBit ExplicitNamespacesBit - unless allowed $ addError $ PsError PsErrIllegalExplicitNamespace [] (getLoc name) + unless allowed $ addError $ PsError PsErrIllegalExplicitNamespace [] (getLocA name) return (fmap (`setRdrNameSpace` tcClsName) name) -checkImportSpec :: Located [LIE GhcPs] -> P (Located [LIE GhcPs]) +checkImportSpec :: LocatedL [LIE GhcPs] -> P (LocatedL [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 $ PsError PsErrIllegalImportBundleForm [] l -- In the correct order -mkImpExpSubSpec :: [Located ImpExpQcSpec] -> P ([AddAnn], ImpExpSubSpec) +mkImpExpSubSpec :: [LocatedA ImpExpQcSpec] -> P ([AddApiAnn], ImpExpSubSpec) mkImpExpSubSpec [] = return ([], ImpExpList []) -mkImpExpSubSpec [L _ ImpExpQcWildcard] = - return ([], ImpExpAll) +mkImpExpSubSpec [L la ImpExpQcWildcard] = + return ([AddApiAnn AnnDotdot (AR $ la2r la)], ImpExpAll) mkImpExpSubSpec xs = if (any (isImpExpQcWildcard . unLoc) xs) then return $ ([], ImpExpAllWith xs) @@ -2476,10 +2704,10 @@ failOpImportQualifiedTwice loc = addError $ PsError PsErrImportQualifiedTwice [] warnStarIsType :: SrcSpan -> P () warnStarIsType span = addWarning Opt_WarnStarIsType (PsWarnStarIsType span) -failOpFewArgs :: MonadP m => Located RdrName -> m a +failOpFewArgs :: MonadP m => LocatedN RdrName -> m a failOpFewArgs (L loc op) = do { star_is_type <- getBit StarIsTypeBit - ; addFatalError $ PsError (PsErrOpFewArgs (StarIsType star_is_type) op) [] loc } + ; addFatalError $ PsError (PsErrOpFewArgs (StarIsType star_is_type) op) [] (locA loc) } ----------------------------------------------------------------------------- -- Misc utils @@ -2492,11 +2720,10 @@ data PV_Context = data PV_Accum = PV_Accum - { pv_warnings :: Bag PsWarning - , pv_errors :: Bag PsError - , pv_annotations :: [(ApiAnnKey,[RealSrcSpan])] - , pv_comment_q :: [RealLocated AnnotationComment] - , pv_annotations_comments :: [(RealSrcSpan,[RealLocated AnnotationComment])] + { pv_warnings :: Bag PsWarning + , pv_errors :: Bag PsError + , pv_header_comments :: Maybe [LAnnotationComment] + , pv_comment_q :: [LAnnotationComment] } data PV_Result a = PV_Ok PV_Accum a | PV_Failed PV_Accum @@ -2548,15 +2775,12 @@ runPV_hints hints m = pv_acc = PV_Accum { pv_warnings = warnings s , pv_errors = errors s - , pv_annotations = annotations s - , pv_comment_q = comment_q s - , pv_annotations_comments = annotations_comments s } + , pv_header_comments = header_comments s + , pv_comment_q = comment_q s } mkPState acc' = s { warnings = pv_warnings acc' , errors = pv_errors acc' - , annotations = pv_annotations acc' - , comment_q = pv_comment_q acc' - , annotations_comments = pv_annotations_comments acc' } + , comment_q = pv_comment_q acc' } in case unPV m pv_ctx pv_acc of PV_Ok acc' a -> POk (mkPState acc') a @@ -2584,19 +2808,25 @@ instance MonadP PV where PV $ \ctx acc -> let b = ext `xtest` pExtsBitmap (pv_options ctx) in PV_Ok acc $! b - addAnnotation (RealSrcSpan l _) a (RealSrcSpan v _) = - PV $ \_ acc -> - 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 - acc' = acc - { pv_annotations = annotations' - , pv_comment_q = comment_q' - , pv_annotations_comments = annotations_comments' } - in - PV_Ok acc' () - addAnnotation _ _ _ = return () + allocateCommentsP ss = PV $ \_ s -> + let (comment_q', newAnns) = allocateComments ss (pv_comment_q s) in + PV_Ok s { + pv_comment_q = comment_q' + } (AnnComments newAnns) + allocatePriorCommentsP ss = PV $ \_ s -> + let (header_comments', comment_q', newAnns) + = allocatePriorComments ss (pv_comment_q s) (pv_header_comments s) in + PV_Ok s { + pv_header_comments = header_comments', + pv_comment_q = comment_q' + } (AnnComments newAnns) + allocateFinalCommentsP ss = PV $ \_ s -> + let (header_comments', comment_q', newAnns) + = allocateFinalComments ss (pv_comment_q s) (pv_header_comments s) in + PV_Ok s { + pv_header_comments = header_comments', + pv_comment_q = comment_q' + } (AnnCommentsBalanced [] (reverse newAnns)) {- Note [Parser-Validator Hint] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2647,52 +2877,68 @@ hintBangPat span e = do unless bang_on $ addError $ PsError (PsErrIllegalBangPattern e) [] span -mkSumOrTupleExpr :: SrcSpan -> Boxity -> SumOrTuple (HsExpr GhcPs) -> PV (LHsExpr GhcPs) +mkSumOrTupleExpr :: SrcSpanAnnA -> Boxity -> SumOrTuple (HsExpr GhcPs) + -> [AddApiAnn] + -> PV (LHsExpr GhcPs) -- Tuple -mkSumOrTupleExpr l boxity (Tuple es) = - return $ L l (ExplicitTuple noExtField (map toTupArg es) boxity) +mkSumOrTupleExpr l boxity (Tuple es) anns = do + cs <- getCommentsFor (locA l) + return $ L l (ExplicitTuple (ApiAnn (spanAsAnchor $ locA l) anns cs) (map toTupArg es) boxity) where - toTupArg :: Located (Maybe (LHsExpr GhcPs)) -> LHsTupArg GhcPs - toTupArg = mapLoc (maybe missingTupArg (Present noExtField)) + toTupArg :: Either (ApiAnn' AnnAnchor) (LHsExpr GhcPs) -> HsTupArg GhcPs + toTupArg (Left ann) = missingTupArg ann + toTupArg (Right a) = Present noAnn a -- Sum -mkSumOrTupleExpr l Unboxed (Sum alt arity e) = - return $ L l (ExplicitSum noExtField alt arity e) -mkSumOrTupleExpr l Boxed a@Sum{} = - addFatalError $ PsError (PsErrUnsupportedBoxedSumExpr a) [] l - -mkSumOrTuplePat :: SrcSpan -> Boxity -> SumOrTuple (PatBuilder GhcPs) -> PV (Located (PatBuilder GhcPs)) +-- mkSumOrTupleExpr l Unboxed (Sum alt arity e) = +-- return $ L l (ExplicitSum noExtField alt arity e) +mkSumOrTupleExpr l Unboxed (Sum alt arity e barsp barsa) anns = do + let an = case anns of + [AddApiAnn AnnOpenPH o, AddApiAnn AnnClosePH c] -> + AnnExplicitSum o barsp barsa c + _ -> panic "mkSumOrTupleExpr" + cs <- getCommentsFor (locA l) + return $ L l (ExplicitSum (ApiAnn (spanAsAnchor $ locA l) an cs) alt arity e) +mkSumOrTupleExpr l Boxed a@Sum{} _ = + addFatalError $ PsError (PsErrUnsupportedBoxedSumExpr a) [] (locA l) + +mkSumOrTuplePat + :: SrcSpanAnnA -> Boxity -> SumOrTuple (PatBuilder GhcPs) -> [AddApiAnn] + -> PV (LocatedA (PatBuilder GhcPs)) -- Tuple -mkSumOrTuplePat l boxity (Tuple ps) = do +mkSumOrTuplePat l boxity (Tuple ps) anns = do ps' <- traverse toTupPat ps - return $ L l (PatBuilderPat (TuplePat noExtField ps' boxity)) + cs <- getCommentsFor (locA l) + return $ L l (PatBuilderPat (TuplePat (ApiAnn (spanAsAnchor $ locA l) anns cs) ps' boxity)) where - toTupPat :: Located (Maybe (Located (PatBuilder GhcPs))) -> PV (LPat GhcPs) + toTupPat :: Either (ApiAnn' AnnAnchor) (LocatedA (PatBuilder GhcPs)) -> PV (LPat GhcPs) -- Ignore the element location so that the error message refers to the -- entire tuple. See #19504 (and the discussion) for details. - toTupPat (L _ p) = case p of - Nothing -> addFatalError $ PsError PsErrTupleSectionInPat [] l - Just p' -> checkLPat p' + toTupPat p = case p of + Left _ -> addFatalError $ PsError PsErrTupleSectionInPat [] (locA l) + Right p' -> checkLPat p' -- Sum -mkSumOrTuplePat l Unboxed (Sum alt arity p) = do +mkSumOrTuplePat l Unboxed (Sum alt arity p barsb barsa) anns = do p' <- checkLPat p - return $ L l (PatBuilderPat (SumPat noExtField p' alt arity)) -mkSumOrTuplePat l Boxed a@Sum{} = - addFatalError $ PsError (PsErrUnsupportedBoxedSumPat a) [] l + cs <- getCommentsFor (locA l) + let an = ApiAnn (spanAsAnchor $ locA l) (ApiAnnSumPat anns barsb barsa) cs + return $ L l (PatBuilderPat (SumPat an p' alt arity)) +mkSumOrTuplePat l Boxed a@Sum{} _ = + addFatalError $ PsError (PsErrUnsupportedBoxedSumPat a) [] (locA l) -mkLHsOpTy :: LHsType GhcPs -> Located RdrName -> LHsType GhcPs -> LHsType GhcPs +mkLHsOpTy :: LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> LHsType GhcPs mkLHsOpTy x op y = - let loc = getLoc x `combineSrcSpans` getLoc op `combineSrcSpans` getLoc y + let loc = getLoc x `combineSrcSpansA` (noAnnSrcSpan $ getLocA op) `combineSrcSpansA` getLoc y in L loc (mkHsOpTy x op y) -mkMultTy :: IsUnicodeSyntax -> Located Token -> LHsType GhcPs -> (HsArrow GhcPs, AddAnn) +mkMultTy :: IsUnicodeSyntax -> Located Token -> LHsType GhcPs -> HsArrow GhcPs mkMultTy u tok t@(L _ (HsTyLit _ (HsNumTy (SourceText "1") 1))) -- See #18888 for the use of (SourceText "1") above - = (HsLinearArrow u, AddAnn AnnPercentOne (combineLocs tok t)) -mkMultTy u tok t = (HsExplicitMult u t, AddAnn AnnPercent (getLoc tok)) + = HsLinearArrow u (Just $ AddApiAnn AnnPercentOne (AR $ realSrcSpan $ combineLocs tok (reLoc t))) +mkMultTy u tok t = HsExplicitMult u (Just $ AddApiAnn AnnPercent (AR $ realSrcSpan $ getLoc tok)) t ----------------------------------------------------------------------------- -- Token symbols @@ -2704,27 +2950,31 @@ starSym False = "*" ----------------------------------------- -- Bits and pieces for RecordDotSyntax. -mkRdrGetField :: SrcSpan -> LHsExpr GhcPs -> Located FieldLabelString -> LHsExpr GhcPs -mkRdrGetField loc arg field = +mkRdrGetField :: SrcSpanAnnA -> LHsExpr GhcPs -> Located (HsFieldLabel GhcPs) + -> ApiAnnCO -> LHsExpr GhcPs +mkRdrGetField loc arg field anns = L loc HsGetField { - gf_ext = noExtField + gf_ext = anns , gf_expr = arg , gf_field = field } -mkRdrProjection :: SrcSpan -> [Located FieldLabelString] -> LHsExpr GhcPs -mkRdrProjection _ [] = panic "mkRdrProjection: The impossible has happened!" -mkRdrProjection loc flds = - L loc HsProjection { - proj_ext = noExtField +mkRdrProjection :: [Located (HsFieldLabel GhcPs)] -> ApiAnn' AnnProjection -> HsExpr GhcPs +mkRdrProjection [] _ = panic "mkRdrProjection: The impossible has happened!" +mkRdrProjection flds anns = + HsProjection { + proj_ext = anns , proj_flds = flds } -mkRdrProjUpdate :: SrcSpan -> Located [Located FieldLabelString] -> LHsExpr GhcPs -> Bool -> LHsRecProj GhcPs (LHsExpr GhcPs) -mkRdrProjUpdate _ (L _ []) _ _ = panic "mkRdrProjUpdate: The impossible has happened!" -mkRdrProjUpdate loc (L l flds) arg isPun = +mkRdrProjUpdate :: SrcSpanAnnA -> Located [Located (HsFieldLabel GhcPs)] + -> LHsExpr GhcPs -> Bool -> ApiAnn + -> LHsRecProj GhcPs (LHsExpr GhcPs) +mkRdrProjUpdate _ (L _ []) _ _ _ = panic "mkRdrProjUpdate: The impossible has happened!" +mkRdrProjUpdate loc (L l flds) arg isPun anns = L loc HsRecField { - hsRecFieldLbl = L l (FieldLabelStrings flds) + hsRecFieldAnn = anns + , hsRecFieldLbl = L l (FieldLabelStrings flds) , hsRecFieldArg = arg , hsRecPun = isPun } |