diff options
Diffstat (limited to 'compiler/parser/RdrHsSyn.hs')
| -rw-r--r-- | compiler/parser/RdrHsSyn.hs | 245 |
1 files changed, 124 insertions, 121 deletions
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs index d6fc6fb642..eb78073b66 100644 --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -6,6 +6,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} module RdrHsSyn ( mkHsOpApp, @@ -130,10 +131,10 @@ mkInstD :: LInstDecl n -> LHsDecl n mkInstD (L loc d) = L loc (InstD d) mkClassDecl :: SrcSpan - -> Located (Maybe (LHsContext RdrName), LHsType RdrName) + -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs) -> Located (a,[Located (FunDep (Located RdrName))]) - -> OrdList (LHsDecl RdrName) - -> P (LTyClDecl RdrName) + -> OrdList (LHsDecl GhcPs) + -> P (LTyClDecl GhcPs) mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls = do { (binds, sigs, ats, at_insts, _, docs) <- cvBindsAndSigs where_cls @@ -150,8 +151,8 @@ mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls , tcdATs = ats, tcdATDefs = at_defs, tcdDocs = docs , tcdFVs = placeHolderNames })) } -mkATDefault :: LTyFamInstDecl RdrName - -> Either (SrcSpan, SDoc) (LTyFamDefltEqn RdrName) +mkATDefault :: LTyFamInstDecl GhcPs + -> Either (SrcSpan, SDoc) (LTyFamDefltEqn GhcPs) -- Take a type-family instance declaration and turn it into -- a type-family default equation for a class declaration -- We parse things as the former and use this function to convert to the latter @@ -170,11 +171,11 @@ mkATDefault (L loc (TyFamInstDecl { tfid_eqn = L _ e })) mkTyData :: SrcSpan -> NewOrData -> Maybe (Located CType) - -> Located (Maybe (LHsContext RdrName), LHsType RdrName) - -> Maybe (LHsKind RdrName) - -> [LConDecl RdrName] - -> HsDeriving RdrName - -> P (LTyClDecl RdrName) + -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs) + -> Maybe (LHsKind GhcPs) + -> [LConDecl GhcPs] + -> HsDeriving GhcPs + -> 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 ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan @@ -188,11 +189,11 @@ mkTyData loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv mkDataDefn :: NewOrData -> Maybe (Located CType) - -> Maybe (LHsContext RdrName) - -> Maybe (LHsKind RdrName) - -> [LConDecl RdrName] - -> HsDeriving RdrName - -> P (HsDataDefn RdrName) + -> Maybe (LHsContext GhcPs) + -> Maybe (LHsKind GhcPs) + -> [LConDecl GhcPs] + -> HsDeriving GhcPs + -> P (HsDataDefn GhcPs) mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv = do { checkDatatypeContext mcxt ; let cxt = fromMaybe (noLoc []) mcxt @@ -204,9 +205,9 @@ mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv mkTySynonym :: SrcSpan - -> LHsType RdrName -- LHS - -> LHsType RdrName -- RHS - -> P (LTyClDecl RdrName) + -> LHsType GhcPs -- LHS + -> LHsType GhcPs -- RHS + -> P (LTyClDecl GhcPs) mkTySynonym loc lhs rhs = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan @@ -215,9 +216,9 @@ mkTySynonym loc lhs rhs , tcdFixity = fixity , tcdRhs = rhs, tcdFVs = placeHolderNames })) } -mkTyFamInstEqn :: LHsType RdrName - -> LHsType RdrName - -> P (TyFamInstEqn RdrName,[AddAnn]) +mkTyFamInstEqn :: LHsType GhcPs + -> LHsType GhcPs + -> P (TyFamInstEqn GhcPs,[AddAnn]) mkTyFamInstEqn lhs rhs = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs ; return (TyFamEqn { tfe_tycon = tc @@ -229,11 +230,11 @@ mkTyFamInstEqn lhs rhs mkDataFamInst :: SrcSpan -> NewOrData -> Maybe (Located CType) - -> Located (Maybe (LHsContext RdrName), LHsType RdrName) - -> Maybe (LHsKind RdrName) - -> [LConDecl RdrName] - -> HsDeriving RdrName - -> P (LInstDecl RdrName) + -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs) + -> Maybe (LHsKind GhcPs) + -> [LConDecl GhcPs] + -> HsDeriving GhcPs + -> P (LInstDecl GhcPs) mkDataFamInst loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan @@ -245,18 +246,18 @@ mkDataFamInst loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_ , dfid_defn = defn, dfid_fvs = placeHolderNames }))) } mkTyFamInst :: SrcSpan - -> LTyFamInstEqn RdrName - -> P (LInstDecl RdrName) + -> LTyFamInstEqn GhcPs + -> P (LInstDecl GhcPs) mkTyFamInst loc eqn = return (L loc (TyFamInstD (TyFamInstDecl { tfid_eqn = eqn , tfid_fvs = placeHolderNames }))) mkFamDecl :: SrcSpan - -> FamilyInfo RdrName - -> LHsType RdrName -- LHS - -> Located (FamilyResultSig RdrName) -- Optional result signature - -> Maybe (LInjectivityAnn RdrName) -- Injectivity annotation - -> P (LTyClDecl RdrName) + -> FamilyInfo GhcPs + -> LHsType GhcPs -- LHS + -> Located (FamilyResultSig GhcPs) -- Optional result signature + -> Maybe (LInjectivityAnn GhcPs) -- Injectivity annotation + -> P (LTyClDecl GhcPs) mkFamDecl loc info lhs ksig injAnn = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan @@ -272,7 +273,7 @@ mkFamDecl loc info lhs ksig injAnn OpenTypeFamily -> empty ClosedTypeFamily {} -> whereDots -mkSpliceDecl :: LHsExpr RdrName -> HsDecl RdrName +mkSpliceDecl :: LHsExpr GhcPs -> HsDecl GhcPs -- If the user wrote -- [pads| ... ] then return a QuasiQuoteD -- $(e) then return a SpliceD @@ -293,9 +294,9 @@ mkSpliceDecl lexpr@(L loc expr) = SpliceD (SpliceDecl (L loc (mkUntypedSplice NoParens lexpr)) ImplicitSplice) mkRoleAnnotDecl :: SrcSpan - -> Located RdrName -- type being annotated + -> Located RdrName -- type being annotated -> [Located (Maybe FastString)] -- roles - -> P (LRoleAnnotDecl RdrName) + -> P (LRoleAnnotDecl GhcPs) mkRoleAnnotDecl loc tycon roles = do { roles' <- mapM parse_role roles ; return $ L loc $ RoleAnnotDecl tycon roles' } @@ -332,25 +333,25 @@ mkRoleAnnotDecl loc tycon roles -- | Groups together bindings for a single function -cvTopDecls :: OrdList (LHsDecl RdrName) -> [LHsDecl RdrName] +cvTopDecls :: OrdList (LHsDecl GhcPs) -> [LHsDecl GhcPs] cvTopDecls decls = go (fromOL decls) where - go :: [LHsDecl RdrName] -> [LHsDecl RdrName] + go :: [LHsDecl GhcPs] -> [LHsDecl GhcPs] go [] = [] go (L l (ValD b) : ds) = L l' (ValD b') : go ds' where (L l' b', ds') = getMonoBind (L l b) ds go (d : ds) = d : go ds -- Declaration list may only contain value bindings and signatures. -cvBindGroup :: OrdList (LHsDecl RdrName) -> P (HsValBinds RdrName) +cvBindGroup :: OrdList (LHsDecl GhcPs) -> P (HsValBinds GhcPs) cvBindGroup binding = do { (mbs, sigs, fam_ds, tfam_insts, dfam_insts, _) <- cvBindsAndSigs binding ; ASSERT( null fam_ds && null tfam_insts && null dfam_insts) return $ ValBindsIn mbs sigs } -cvBindsAndSigs :: OrdList (LHsDecl RdrName) - -> P (LHsBinds RdrName, [LSig RdrName], [LFamilyDecl RdrName] - , [LTyFamInstDecl RdrName], [LDataFamInstDecl RdrName], [LDocDecl]) +cvBindsAndSigs :: OrdList (LHsDecl GhcPs) + -> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs] + , [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl]) -- 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. @@ -385,8 +386,8 @@ cvBindsAndSigs fb = go (fromOL fb) ----------------------------------------------------------------------------- -- Group function bindings into equation groups -getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName] - -> (LHsBind RdrName, [LHsDecl RdrName]) +getMonoBind :: LHsBind GhcPs -> [LHsDecl GhcPs] + -> (LHsBind GhcPs, [LHsDecl GhcPs]) -- Suppose (b',ds') = getMonoBind b ds -- ds is a list of parsed bindings -- b is a MonoBinds that has just been read off the front @@ -423,7 +424,7 @@ getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1), getMonoBind bind binds = (bind, binds) -has_args :: [LMatch RdrName (LHsExpr RdrName)] -> Bool +has_args :: [LMatch GhcPs (LHsExpr GhcPs)] -> Bool has_args [] = panic "RdrHsSyn:has_args" has_args ((L _ (Match _ args _ _)) : _) = not (null args) -- Don't group together FunBinds if they have @@ -462,8 +463,8 @@ So the plan is: it (Trac #12051). -} -splitCon :: LHsType RdrName - -> P (Located RdrName, HsConDeclDetails RdrName) +splitCon :: LHsType GhcPs + -> P (Located RdrName, HsConDeclDetails GhcPs) -- See Note [Parsing data constructors is hard] -- This gets given a "type" that should look like -- C Int Bool @@ -502,8 +503,8 @@ tyConToDataCon loc tc | otherwise = empty mkPatSynMatchGroup :: Located RdrName - -> Located (OrdList (LHsDecl RdrName)) - -> P (MatchGroup RdrName (LHsExpr RdrName)) + -> Located (OrdList (LHsDecl GhcPs)) + -> P (MatchGroup GhcPs (LHsExpr GhcPs)) mkPatSynMatchGroup (L loc patsyn_name) (L _ decls) = do { matches <- mapM fromDecl (fromOL decls) ; when (null matches) (wrongNumberErr loc) @@ -536,15 +537,15 @@ mkPatSynMatchGroup (L loc patsyn_name) (L _ decls) = text "pattern synonym 'where' clause cannot be empty" $$ text "In the pattern synonym declaration for: " <+> ppr (patsyn_name) -recordPatSynErr :: SrcSpan -> LPat RdrName -> P a +recordPatSynErr :: SrcSpan -> LPat GhcPs -> P a recordPatSynErr loc pat = parseErrorSDoc loc $ text "record syntax not supported for pattern synonym declarations:" $$ ppr pat -mkConDeclH98 :: Located RdrName -> Maybe [LHsTyVarBndr RdrName] - -> LHsContext RdrName -> HsConDeclDetails RdrName - -> ConDecl RdrName +mkConDeclH98 :: Located RdrName -> Maybe [LHsTyVarBndr GhcPs] + -> LHsContext GhcPs -> HsConDeclDetails GhcPs + -> ConDecl GhcPs mkConDeclH98 name mb_forall cxt details = ConDeclH98 { con_name = name @@ -556,8 +557,8 @@ mkConDeclH98 name mb_forall cxt details , con_doc = Nothing } mkGadtDecl :: [Located RdrName] - -> LHsSigType RdrName -- Always a HsForAllTy - -> ConDecl RdrName + -> LHsSigType GhcPs -- Always a HsForAllTy + -> ConDecl GhcPs mkGadtDecl names ty = ConDeclGADT { con_names = names , con_type = ty , con_doc = Nothing } @@ -664,7 +665,8 @@ really doesn't matter! -- * For PrefixCon we keep all the args in the res_ty -- * For RecCon we do not -checkTyVarsP :: SDoc -> SDoc -> Located RdrName -> [LHsType RdrName] -> P (LHsQTyVars RdrName) +checkTyVarsP :: SDoc -> SDoc -> Located RdrName -> [LHsType GhcPs] + -> P (LHsQTyVars GhcPs) -- Same as checkTyVars, but in the P monad checkTyVarsP pp_what equals_or_where tc tparms = eitherToP $ checkTyVars pp_what equals_or_where tc tparms @@ -674,8 +676,8 @@ eitherToP :: Either (SrcSpan, SDoc) a -> P a eitherToP (Left (loc, doc)) = parseErrorSDoc loc doc eitherToP (Right thing) = return thing -checkTyVars :: SDoc -> SDoc -> Located RdrName -> [LHsType RdrName] - -> Either (SrcSpan, SDoc) (LHsQTyVars RdrName) +checkTyVars :: SDoc -> SDoc -> Located RdrName -> [LHsType GhcPs] + -> Either (SrcSpan, SDoc) (LHsQTyVars GhcPs) -- Check whether the given list of type parameters are all type variables -- (possibly with a kind signature) -- We use the Either monad because it's also called (via mkATDefault) from @@ -708,7 +710,7 @@ whereDots, equalsDots :: SDoc whereDots = text "where ..." equalsDots = text "= ..." -checkDatatypeContext :: Maybe (LHsContext RdrName) -> P () +checkDatatypeContext :: Maybe (LHsContext GhcPs) -> P () checkDatatypeContext Nothing = return () checkDatatypeContext (Just (L loc c)) = do allowed <- extension datatypeContextsEnabled @@ -728,10 +730,10 @@ checkRecordSyntax lr@(L loc r) checkTyClHdr :: Bool -- True <=> class header -- False <=> type header - -> LHsType RdrName - -> P (Located RdrName, -- the head symbol (type or class name) - [LHsType RdrName], -- parameters of head symbol - LexicalFixity, -- the declaration is in infix format + -> LHsType GhcPs + -> P (Located RdrName, -- the head symbol (type or class name) + [LHsType GhcPs], -- parameters of head symbol + LexicalFixity, -- the declaration is in infix format [AddAnn]) -- 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]) @@ -769,7 +771,7 @@ checkTyClHdr is_cls ty = parseErrorSDoc l (text "Malformed head of type or class declaration:" <+> ppr ty) -checkContext :: LHsType RdrName -> P ([AddAnn],LHsContext RdrName) +checkContext :: LHsType GhcPs -> P ([AddAnn],LHsContext GhcPs) checkContext (L l orig_t) = check [] (L l orig_t) where @@ -794,17 +796,17 @@ checkContext (L l orig_t) -- We parse patterns as expressions and check for valid patterns below, -- converting the expression into a pattern at the same time. -checkPattern :: SDoc -> LHsExpr RdrName -> P (LPat RdrName) +checkPattern :: SDoc -> LHsExpr GhcPs -> P (LPat GhcPs) checkPattern msg e = checkLPat msg e -checkPatterns :: SDoc -> [LHsExpr RdrName] -> P [LPat RdrName] +checkPatterns :: SDoc -> [LHsExpr GhcPs] -> P [LPat GhcPs] checkPatterns msg es = mapM (checkPattern msg) es -checkLPat :: SDoc -> LHsExpr RdrName -> P (LPat RdrName) +checkLPat :: SDoc -> LHsExpr GhcPs -> P (LPat GhcPs) checkLPat msg e@(L l _) = checkPat msg l e [] -checkPat :: SDoc -> SrcSpan -> LHsExpr RdrName -> [LPat RdrName] - -> P (LPat RdrName) +checkPat :: SDoc -> SrcSpan -> LHsExpr GhcPs -> [LPat GhcPs] + -> P (LPat GhcPs) checkPat _ loc (L l e@(HsVar (L _ c))) args | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args))) | not (null args) && patIsRec c = @@ -824,7 +826,7 @@ checkPat msg loc (L _ e) [] checkPat msg loc e _ = patFail msg loc (unLoc e) -checkAPat :: SDoc -> SrcSpan -> HsExpr RdrName -> P (Pat RdrName) +checkAPat :: SDoc -> SrcSpan -> HsExpr GhcPs -> P (Pat GhcPs) checkAPat msg loc e0 = do pState <- getPState let opts = options pState @@ -895,7 +897,7 @@ checkAPat msg loc e0 = do -> return (SplicePat s) _ -> patFail msg loc e0 -placeHolderPunRhs :: LHsExpr RdrName +placeHolderPunRhs :: LHsExpr GhcPs -- 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 = noLoc (HsVar (noLoc pun_RDR)) @@ -905,12 +907,12 @@ plus_RDR = mkUnqual varName (fsLit "+") -- Hack bang_RDR = mkUnqual varName (fsLit "!") -- Hack pun_RDR = mkUnqual varName (fsLit "pun-right-hand-side") -checkPatField :: SDoc -> LHsRecField RdrName (LHsExpr RdrName) - -> P (LHsRecField RdrName (LPat RdrName)) +checkPatField :: SDoc -> LHsRecField GhcPs (LHsExpr GhcPs) + -> P (LHsRecField GhcPs (LPat GhcPs)) checkPatField msg (L l fld) = do p <- checkLPat msg (hsRecFieldArg fld) return (L l (fld { hsRecFieldArg = p })) -patFail :: SDoc -> SrcSpan -> HsExpr RdrName -> P a +patFail :: SDoc -> SrcSpan -> HsExpr GhcPs -> P a patFail msg loc e = parseErrorSDoc loc err where err = text "Parse error in pattern:" <+> ppr e $$ msg @@ -923,10 +925,10 @@ patIsRec e = e == mkUnqual varName (fsLit "rec") -- Check Equation Syntax checkValDef :: SDoc - -> LHsExpr RdrName - -> Maybe (LHsType RdrName) - -> Located (a,GRHSs RdrName (LHsExpr RdrName)) - -> P ([AddAnn],HsBind RdrName) + -> LHsExpr GhcPs + -> Maybe (LHsType GhcPs) + -> Located (a,GRHSs GhcPs (LHsExpr GhcPs)) + -> P ([AddAnn],HsBind GhcPs) checkValDef msg lhs (Just sig) grhss -- x :: ty = rhs parses as a *pattern* binding @@ -946,10 +948,10 @@ checkFunBind :: SDoc -> SrcSpan -> Located RdrName -> LexicalFixity - -> [LHsExpr RdrName] - -> Maybe (LHsType RdrName) - -> Located (GRHSs RdrName (LHsExpr RdrName)) - -> P ([AddAnn],HsBind RdrName) + -> [LHsExpr GhcPs] + -> Maybe (LHsType GhcPs) + -> Located (GRHSs GhcPs (LHsExpr GhcPs)) + -> P ([AddAnn],HsBind GhcPs) checkFunBind msg ann lhs_loc fun is_infix pats opt_sig (L rhs_span grhss) = do ps <- checkPatterns msg pats let match_span = combineSrcSpans lhs_loc rhs_span @@ -963,8 +965,8 @@ checkFunBind msg ann lhs_loc fun is_infix pats opt_sig (L rhs_span grhss) -- The span of the match covers the entire equation. -- That isn't quite right, but it'll do for now. -makeFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)] - -> HsBind RdrName +makeFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] + -> HsBind GhcPs -- Like HsUtils.mkFunBind, but we need to be able to set the fixity too makeFunBind fn ms = FunBind { fun_id = fn, @@ -974,15 +976,15 @@ makeFunBind fn ms fun_tick = [] } checkPatBind :: SDoc - -> LHsExpr RdrName - -> Located (a,GRHSs RdrName (LHsExpr RdrName)) - -> P ([AddAnn],HsBind RdrName) + -> LHsExpr GhcPs + -> Located (a,GRHSs GhcPs (LHsExpr GhcPs)) + -> P ([AddAnn],HsBind GhcPs) checkPatBind msg lhs (L _ (_,grhss)) = do { lhs <- checkPattern msg lhs ; return ([],PatBind lhs grhss placeHolderType placeHolderNames ([],[])) } -checkValSigLhs :: LHsExpr RdrName -> P (Located RdrName) +checkValSigLhs :: LHsExpr GhcPs -> P (Located RdrName) checkValSigLhs (L _ (HsVar lrdr@(L _ v))) | isUnqual v , not (isDataOcc (rdrNameOcc v)) @@ -1014,11 +1016,11 @@ checkValSigLhs lhs@(L l _) pattern_RDR = mkUnqual varName (fsLit "pattern") -checkDoAndIfThenElse :: LHsExpr RdrName +checkDoAndIfThenElse :: LHsExpr GhcPs -> Bool - -> LHsExpr RdrName + -> LHsExpr GhcPs -> Bool - -> LHsExpr RdrName + -> LHsExpr GhcPs -> P () checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr | semiThen || semiElse @@ -1038,7 +1040,7 @@ checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr -- The parser left-associates, so there should -- not be any OpApps inside the e's -splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName]) +splitBang :: LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, [LHsExpr GhcPs]) -- Splits (f ! g a b) into (f, [(! g), a, b]) splitBang (L _ (OpApp l_arg bang@(L _ (HsVar (L _ op))) _ r_arg)) | op == bang_RDR = Just (l_arg, L l' (SectionR bang arg1) : argns) @@ -1049,8 +1051,8 @@ splitBang (L _ (OpApp l_arg bang@(L _ (HsVar (L _ op))) _ r_arg)) split_bang e es = (e,es) splitBang _ = Nothing -isFunLhs :: LHsExpr RdrName - -> P (Maybe (Located RdrName, LexicalFixity, [LHsExpr RdrName],[AddAnn])) +isFunLhs :: LHsExpr GhcPs + -> P (Maybe (Located RdrName, LexicalFixity, [LHsExpr GhcPs],[AddAnn])) -- A variable binding is parsed as a FunBind. -- Just (fun, is_infix, arg_pats) if e is a function LHS -- @@ -1104,7 +1106,7 @@ isFunLhs e = go e [] [] -- | Transform btype_no_ops with strict_mark's into HsEqTy's -- (((~a) ~b) c) ~d ==> ((~a) ~ (b c)) ~ d -splitTilde :: LHsType RdrName -> P (LHsType RdrName) +splitTilde :: LHsType GhcPs -> P (LHsType GhcPs) splitTilde t = go t where go (L loc (HsAppTy t1 t2)) | L lo (HsBangTy (HsSrcBang NoSourceText NoSrcUnpack SrcLazy) t2') @@ -1129,7 +1131,7 @@ splitTilde t = go t -- | Transform tyapps with strict_marks into uses of twiddle -- [~a, ~b, c, ~d] ==> (~a) ~ b c ~ d -splitTildeApps :: [LHsAppType RdrName] -> P [LHsAppType RdrName] +splitTildeApps :: [LHsAppType GhcPs] -> P [LHsAppType GhcPs] splitTildeApps [] = return [] splitTildeApps (t : rest) = do rest' <- concatMapM go rest @@ -1170,13 +1172,13 @@ checkMonadComp = do -- We parse arrow syntax as expressions and check for valid syntax below, -- converting the expression into a pattern at the same time. -checkCommand :: LHsExpr RdrName -> P (LHsCmd RdrName) +checkCommand :: LHsExpr GhcPs -> P (LHsCmd GhcPs) checkCommand lc = locMap checkCmd lc locMap :: (SrcSpan -> a -> P b) -> Located a -> P (Located b) locMap f (L l a) = f l a >>= (\b -> return $ L l b) -checkCmd :: SrcSpan -> HsExpr RdrName -> P (HsCmd RdrName) +checkCmd :: SrcSpan -> HsExpr GhcPs -> P (HsCmd GhcPs) checkCmd _ (HsArrApp e1 e2 ptt haat b) = return $ HsCmdArrApp e1 e2 ptt haat b checkCmd _ (HsArrForm e mf args) = @@ -1208,10 +1210,10 @@ checkCmd _ (OpApp eLeft op _fixity eRight) = do checkCmd l e = cmdFail l e -checkCmdLStmt :: ExprLStmt RdrName -> P (CmdLStmt RdrName) +checkCmdLStmt :: ExprLStmt GhcPs -> P (CmdLStmt GhcPs) checkCmdLStmt = locMap checkCmdStmt -checkCmdStmt :: SrcSpan -> ExprStmt RdrName -> P (CmdStmt RdrName) +checkCmdStmt :: SrcSpan -> ExprStmt GhcPs -> P (CmdStmt GhcPs) checkCmdStmt _ (LastStmt e s r) = checkCommand e >>= (\c -> return $ LastStmt c s r) checkCmdStmt _ (BindStmt pat e b f t) = @@ -1224,7 +1226,8 @@ checkCmdStmt _ stmt@(RecStmt { recS_stmts = stmts }) = do return $ stmt { recS_stmts = ss } checkCmdStmt l stmt = cmdStmtFail l stmt -checkCmdMatchGroup :: MatchGroup RdrName (LHsExpr RdrName) -> P (MatchGroup RdrName (LHsCmd RdrName)) +checkCmdMatchGroup :: MatchGroup GhcPs (LHsExpr GhcPs) + -> P (MatchGroup GhcPs (LHsCmd GhcPs)) checkCmdMatchGroup mg@(MG { mg_alts = L l ms }) = do ms' <- mapM (locMap $ const convert) ms return $ mg { mg_alts = L l ms' } @@ -1232,12 +1235,12 @@ checkCmdMatchGroup mg@(MG { mg_alts = L l ms }) = do grhss' <- checkCmdGRHSs grhss return $ Match mf pat mty grhss' -checkCmdGRHSs :: GRHSs RdrName (LHsExpr RdrName) -> P (GRHSs RdrName (LHsCmd RdrName)) +checkCmdGRHSs :: GRHSs GhcPs (LHsExpr GhcPs) -> P (GRHSs GhcPs (LHsCmd GhcPs)) checkCmdGRHSs (GRHSs grhss binds) = do grhss' <- mapM checkCmdGRHS grhss return $ GRHSs grhss' binds -checkCmdGRHS :: LGRHS RdrName (LHsExpr RdrName) -> P (LGRHS RdrName (LHsCmd RdrName)) +checkCmdGRHS :: LGRHS GhcPs (LHsExpr GhcPs) -> P (LGRHS GhcPs (LHsCmd GhcPs)) checkCmdGRHS = locMap $ const convert where convert (GRHS stmts e) = do @@ -1246,9 +1249,9 @@ checkCmdGRHS = locMap $ const convert return $ GRHS {- cmdStmts -} stmts c -cmdFail :: SrcSpan -> HsExpr RdrName -> P a +cmdFail :: SrcSpan -> HsExpr GhcPs -> P a cmdFail loc e = parseErrorSDoc loc (text "Parse error in command:" <+> ppr e) -cmdStmtFail :: SrcSpan -> Stmt RdrName (LHsExpr RdrName) -> P a +cmdStmtFail :: SrcSpan -> Stmt GhcPs (LHsExpr GhcPs) -> P a cmdStmtFail loc e = parseErrorSDoc loc (text "Parse error in command statement:" <+> ppr e) @@ -1262,10 +1265,10 @@ checkPrecP (L l (src,i)) = parseErrorSDoc l (text ("Precedence out of range: " ++ show i)) mkRecConstrOrUpdate - :: LHsExpr RdrName + :: LHsExpr GhcPs -> SrcSpan - -> ([LHsRecField RdrName (LHsExpr RdrName)], Bool) - -> P (HsExpr RdrName) + -> ([LHsRecField GhcPs (LHsExpr GhcPs)], Bool) + -> P (HsExpr GhcPs) mkRecConstrOrUpdate (L l (HsVar (L _ c))) _ (fs,dd) | isRdrDataCon c @@ -1274,14 +1277,14 @@ mkRecConstrOrUpdate exp@(L l _) _ (fs,dd) | dd = parseErrorSDoc l (text "You cannot use `..' in a record update") | otherwise = return (mkRdrRecordUpd exp (map (fmap mk_rec_upd_field) fs)) -mkRdrRecordUpd :: LHsExpr RdrName -> [LHsRecUpdField RdrName] -> HsExpr RdrName +mkRdrRecordUpd :: LHsExpr GhcPs -> [LHsRecUpdField GhcPs] -> HsExpr GhcPs mkRdrRecordUpd exp flds = RecordUpd { rupd_expr = exp , rupd_flds = flds , rupd_cons = PlaceHolder, rupd_in_tys = PlaceHolder , rupd_out_tys = PlaceHolder, rupd_wrap = PlaceHolder } -mkRdrRecordCon :: Located RdrName -> HsRecordBinds RdrName -> HsExpr RdrName +mkRdrRecordCon :: Located RdrName -> HsRecordBinds GhcPs -> HsExpr GhcPs mkRdrRecordCon con flds = RecordCon { rcon_con_name = con, rcon_flds = flds , rcon_con_expr = noPostTcExpr, rcon_con_like = PlaceHolder } @@ -1290,7 +1293,7 @@ mk_rec_fields :: [LHsRecField id arg] -> Bool -> HsRecFields id arg mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing } mk_rec_fields fs True = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) } -mk_rec_upd_field :: HsRecField RdrName (LHsExpr RdrName) -> HsRecUpdField RdrName +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 rdr PlaceHolder)) arg pun @@ -1319,8 +1322,8 @@ mkInlinePragma src (inl, match_info) mb_act -- mkImport :: Located CCallConv -> Located Safety - -> (Located StringLiteral, Located RdrName, LHsSigType RdrName) - -> P (HsDecl RdrName) + -> (Located StringLiteral, Located RdrName, LHsSigType GhcPs) + -> P (HsDecl GhcPs) mkImport cconv safety (L loc (StringLiteral esrc entity), v, ty) = case cconv of L _ CCallConv -> mkCImport @@ -1419,8 +1422,8 @@ parseCImport cconv safety nm str sourceText = -- construct a foreign export declaration -- mkExport :: Located CCallConv - -> (Located StringLiteral, Located RdrName, LHsSigType RdrName) - -> P (HsDecl RdrName) + -> (Located StringLiteral, Located RdrName, LHsSigType GhcPs) + -> P (HsDecl GhcPs) mkExport (L lc cconv) (L le (StringLiteral esrc entity), v, ty) = return $ ForD $ ForeignExport { fd_name = v, fd_sig_ty = ty @@ -1452,7 +1455,7 @@ data ImpExpQcSpec = ImpExpQcName (Located RdrName) | ImpExpQcType (Located RdrName) | ImpExpQcWildcard -mkModuleImpExp :: Located ImpExpQcSpec -> ImpExpSubSpec -> P (IE RdrName) +mkModuleImpExp :: Located ImpExpQcSpec -> ImpExpSubSpec -> P (IE GhcPs) mkModuleImpExp (L l specname) subs = case subs of ImpExpAbs @@ -1506,7 +1509,7 @@ mkTypeImpExp name = else parseErrorSDoc (getLoc name) (text "Illegal keyword 'type' (use ExplicitNamespaces to enable)") -checkImportSpec :: Located [LIE RdrName] -> P (Located [LIE RdrName]) +checkImportSpec :: Located [LIE GhcPs] -> P (Located [LIE GhcPs]) checkImportSpec ie@(L _ specs) = case [l | (L l (IEThingWith _ (IEWildcard _) _ _)) <- specs] of [] -> return ie @@ -1538,10 +1541,10 @@ parseErrorSDoc :: SrcSpan -> SDoc -> P a parseErrorSDoc span s = failSpanMsgP span s data SumOrTuple - = Sum ConTag Arity (LHsExpr RdrName) - | Tuple [LHsTupArg RdrName] + = Sum ConTag Arity (LHsExpr GhcPs) + | Tuple [LHsTupArg GhcPs] -mkSumOrTuple :: Boxity -> SrcSpan -> SumOrTuple -> P (HsExpr RdrName) +mkSumOrTuple :: Boxity -> SrcSpan -> SumOrTuple -> P (HsExpr GhcPs) -- Tuple mkSumOrTuple boxity _ (Tuple es) = return (ExplicitTuple es boxity) @@ -1552,7 +1555,7 @@ mkSumOrTuple Unboxed _ (Sum alt arity e) = mkSumOrTuple Boxed l (Sum alt arity (L _ e)) = parseErrorSDoc l (hang (text "Boxed sums not supported:") 2 (ppr_boxed_sum alt arity e)) where - ppr_boxed_sum :: ConTag -> Arity -> HsExpr RdrName -> SDoc + ppr_boxed_sum :: ConTag -> Arity -> HsExpr GhcPs -> SDoc ppr_boxed_sum alt arity e = text "(" <+> ppr_bars (alt - 1) <+> ppr e <+> ppr_bars (arity - alt) <+> text ")" |