diff options
Diffstat (limited to 'compiler/hsSyn')
| -rw-r--r-- | compiler/hsSyn/Convert.hs | 78 | ||||
| -rw-r--r-- | compiler/hsSyn/HsExpr.hs | 480 | ||||
| -rw-r--r-- | compiler/hsSyn/HsExtension.hs | 122 | ||||
| -rw-r--r-- | compiler/hsSyn/HsPat.hs | 10 | ||||
| -rw-r--r-- | compiler/hsSyn/HsUtils.hs | 174 | ||||
| -rw-r--r-- | compiler/hsSyn/PlaceHolder.hs | 6 |
6 files changed, 569 insertions, 301 deletions
diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs index 119f31afa0..c64ea53b1a 100644 --- a/compiler/hsSyn/Convert.hs +++ b/compiler/hsSyn/Convert.hs @@ -774,77 +774,87 @@ cvtClause ctxt (Clause ps body wheres) cvtl :: TH.Exp -> CvtM (LHsExpr GhcPs) cvtl e = wrapL (cvt e) where - cvt (VarE s) = do { s' <- vName s; return $ HsVar (noLoc s') } - cvt (ConE s) = do { s' <- cName s; return $ HsVar (noLoc s') } + cvt (VarE s) = do { s' <- vName s; return $ HsVar noExt (noLoc s') } + cvt (ConE s) = do { s' <- cName s; return $ HsVar noExt (noLoc s') } cvt (LitE l) - | overloadedLit l = do { l' <- cvtOverLit l; return $ HsOverLit l' } - | otherwise = do { l' <- cvtLit l; return $ HsLit l' } + | overloadedLit l = do { l' <- cvtOverLit l; return $ HsOverLit noExt l' } + | otherwise = do { l' <- cvtLit l; return $ HsLit noExt l' } cvt (AppE x@(LamE _ _) y) = do { x' <- cvtl x; y' <- cvtl y - ; return $ HsApp (mkLHsPar x') (mkLHsPar y')} + ; return $ HsApp noExt (mkLHsPar x') + (mkLHsPar y')} cvt (AppE x y) = do { x' <- cvtl x; y' <- cvtl y - ; return $ HsApp (mkLHsPar x') (mkLHsPar y')} + ; return $ HsApp noExt (mkLHsPar x') + (mkLHsPar y')} cvt (AppTypeE e t) = do { e' <- cvtl e ; t' <- cvtType t ; tp <- wrap_apps t' - ; return $ HsAppType e' $ mkHsWildCardBndrs tp } + ; return $ HsAppType (mkHsWildCardBndrs tp) e' } cvt (LamE [] e) = cvt e -- Degenerate case. We convert the body as its -- own expression to avoid pretty-printing -- oddities that can result from zero-argument -- lambda expressions. See #13856. cvt (LamE ps e) = do { ps' <- cvtPats ps; e' <- cvtl e - ; return $ HsLam (mkMatchGroup FromSource + ; return $ HsLam noExt (mkMatchGroup FromSource [mkSimpleMatch LambdaExpr ps' e'])} cvt (LamCaseE ms) = do { ms' <- mapM (cvtMatch LambdaExpr) ms - ; return $ HsLamCase (mkMatchGroup FromSource ms') + ; return $ HsLamCase noExt + (mkMatchGroup FromSource ms') } - cvt (TupE [e]) = do { e' <- cvtl e; return $ HsPar e' } + cvt (TupE [e]) = do { e' <- cvtl e; return $ HsPar noExt e' } -- Note [Dropping constructors] -- Singleton tuples treated like nothing (just parens) cvt (TupE es) = do { es' <- mapM cvtl es - ; return $ ExplicitTuple (map (noLoc . Present) es') - Boxed } + ; return $ ExplicitTuple noExt + (map (noLoc . Present) es') Boxed } cvt (UnboxedTupE es) = do { es' <- mapM cvtl es - ; return $ ExplicitTuple + ; return $ ExplicitTuple noExt (map (noLoc . Present) es') Unboxed } cvt (UnboxedSumE e alt arity) = do { e' <- cvtl e ; unboxedSumChecks alt arity - ; return $ ExplicitSum - alt arity e' placeHolderType } + ; return $ ExplicitSum noExt + alt arity e'} cvt (CondE x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; - ; return $ HsIf (Just noSyntaxExpr) x' y' z' } + ; return $ HsIf noExt (Just noSyntaxExpr) x' y' z' } cvt (MultiIfE alts) | null alts = failWith (text "Multi-way if-expression with no alternatives") | otherwise = do { alts' <- mapM cvtpair alts - ; return $ HsMultiIf placeHolderType alts' } + ; return $ HsMultiIf noExt alts' } cvt (LetE ds e) = do { ds' <- cvtLocalDecs (text "a let expression") ds - ; e' <- cvtl e; return $ HsLet (noLoc ds') e' } + ; e' <- cvtl e; return $ HsLet noExt (noLoc ds') e'} cvt (CaseE e ms) = do { e' <- cvtl e; ms' <- mapM (cvtMatch CaseAlt) ms - ; return $ HsCase e' (mkMatchGroup FromSource ms') } + ; return $ HsCase noExt e' + (mkMatchGroup FromSource ms') } cvt (DoE ss) = cvtHsDo DoExpr ss cvt (CompE ss) = cvtHsDo ListComp ss - cvt (ArithSeqE dd) = do { dd' <- cvtDD dd; return $ ArithSeq noPostTcExpr Nothing dd' } + cvt (ArithSeqE dd) = do { dd' <- cvtDD dd + ; return $ ArithSeq noExt Nothing dd' } cvt (ListE xs) - | Just s <- allCharLs xs = do { l' <- cvtLit (StringL s); return (HsLit l') } + | Just s <- allCharLs xs = do { l' <- cvtLit (StringL s) + ; return (HsLit noExt l') } -- Note [Converting strings] | otherwise = do { xs' <- mapM cvtl xs - ; return $ ExplicitList placeHolderType Nothing xs' + ; return $ ExplicitList noExt Nothing xs' } -- Infix expressions cvt (InfixE (Just x) s (Just y)) = do { x' <- cvtl x; s' <- cvtl s; y' <- cvtl y - ; wrapParL HsPar $ - OpApp (mkLHsPar x') s' undefined (mkLHsPar y') } + ; wrapParL (HsPar noExt) $ + OpApp noExt (mkLHsPar x') s' + (mkLHsPar y') } -- Parenthesise both arguments and result, -- to ensure this operator application does -- does not get re-associated -- See Note [Operator association] cvt (InfixE Nothing s (Just y)) = do { s' <- cvtl s; y' <- cvtl y - ; wrapParL HsPar $ SectionR s' y' } + ; wrapParL (HsPar noExt) + $ SectionR noExt s' y' } -- See Note [Sections in HsSyn] in HsExpr cvt (InfixE (Just x) s Nothing ) = do { x' <- cvtl x; s' <- cvtl s - ; wrapParL HsPar $ SectionL x' s' } + ; wrapParL (HsPar noExt) + $ SectionL noExt x' s' } - cvt (InfixE Nothing s Nothing ) = do { s' <- cvtl s; return $ HsPar s' } + cvt (InfixE Nothing s Nothing ) = do { s' <- cvtl s + ; return $ HsPar noExt s' } -- Can I indicate this is an infix thing? -- Note [Dropping constructors] @@ -854,9 +864,9 @@ cvtl e = wrapL (cvt e) _ -> mkLHsPar x' ; cvtOpApp x'' s y } -- Note [Converting UInfix] - cvt (ParensE e) = do { e' <- cvtl e; return $ HsPar e' } + cvt (ParensE e) = do { e' <- cvtl e; return $ HsPar noExt e' } cvt (SigE e t) = do { e' <- cvtl e; t' <- cvtType t - ; return $ ExprWithTySig e' (mkLHsSigWcType t') } + ; return $ ExprWithTySig (mkLHsSigWcType t') e' } cvt (RecConE c flds) = do { c' <- cNameL c ; flds' <- mapM (cvtFld (mkFieldOcc . noLoc)) flds ; return $ mkRdrRecordCon c' (HsRecFields flds' Nothing) } @@ -865,9 +875,9 @@ cvtl e = wrapL (cvt e) <- mapM (cvtFld (mkAmbiguousFieldOcc . noLoc)) flds ; return $ mkRdrRecordUpd e' flds' } - cvt (StaticE e) = fmap (HsStatic placeHolderNames) $ cvtl e - cvt (UnboundVarE s) = do { s' <- vName s; return $ HsVar (noLoc s') } - cvt (LabelE s) = do { return $ HsOverLabel Nothing (fsLit s) } + cvt (StaticE e) = fmap (HsStatic noExt) $ cvtl e + cvt (UnboundVarE s) = do { s' <- vName s; return $ HsVar noExt (noLoc s') } + cvt (LabelE s) = do { return $ HsOverLabel noExt Nothing (fsLit s) } {- Note [Dropping constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -958,7 +968,7 @@ cvtOpApp x op1 (UInfixE y op2 z) cvtOpApp x op y = do { op' <- cvtl op ; y' <- cvtl y - ; return (OpApp x op' undefined y') } + ; return (OpApp noExt x op' y') } ------------------------------------- -- Do notation and statements @@ -975,7 +985,7 @@ cvtHsDo do_or_lc stmts L loc (BodyStmt body _ _ _) -> return (L loc (mkLastStmt body)) _ -> failWith (bad_last last') - ; return $ HsDo do_or_lc (noLoc (stmts'' ++ [last''])) placeHolderType } + ; return $ HsDo noExt do_or_lc (noLoc (stmts'' ++ [last''])) } where bad_last stmt = vcat [ text "Illegal last statement of" <+> pprAStmtContext do_or_lc <> colon , nest 2 $ Outputable.ppr stmt diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs index 82e7f27b46..6fd4d0ec14 100644 --- a/compiler/hsSyn/HsExpr.hs +++ b/compiler/hsSyn/HsExpr.hs @@ -12,6 +12,7 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} -- | Abstract Haskell syntax for expressions. module HsExpr where @@ -21,6 +22,7 @@ module HsExpr where -- friends: import GhcPrelude +import PlaceHolder import HsDecls import HsPat import HsLit @@ -83,7 +85,7 @@ type PostTcExpr = HsExpr GhcTc type PostTcTable = [(Name, PostTcExpr)] noPostTcExpr :: PostTcExpr -noPostTcExpr = HsLit (HsString noSourceText (fsLit "noPostTcExpr")) +noPostTcExpr = HsLit noExt (HsString noSourceText (fsLit "noPostTcExpr")) noPostTcTable :: PostTcTable noPostTcTable = [] @@ -114,13 +116,13 @@ deriving instance (DataIdLR p p) => Data (SyntaxExpr p) -- | This is used for rebindable-syntax pieces that are too polymorphic -- for tcSyntaxOp (trS_fmap and the mzip in ParStmt) -noExpr :: SourceTextX p => HsExpr p -noExpr = HsLit (HsString (sourceText "noExpr") (fsLit "noExpr")) +noExpr :: SourceTextX (GhcPass p) => HsExpr (GhcPass p) +noExpr = HsLit noExt (HsString (sourceText "noExpr") (fsLit "noExpr")) -noSyntaxExpr :: SourceTextX p => SyntaxExpr p +noSyntaxExpr :: SourceTextX (GhcPass p) => SyntaxExpr (GhcPass p) -- Before renaming, and sometimes after, -- (if the syntax slot makes no sense) -noSyntaxExpr = SyntaxExpr { syn_expr = HsLit (HsString noSourceText +noSyntaxExpr = SyntaxExpr { syn_expr = HsLit noExt (HsString noSourceText (fsLit "noSyntaxExpr")) , syn_arg_wraps = [] , syn_res_wrap = WpHole } @@ -128,7 +130,7 @@ noSyntaxExpr = SyntaxExpr { syn_expr = HsLit (HsString noSourceText -- | Make a 'SyntaxExpr Name' (the "rn" is because this is used in the -- renamer), missing its HsWrappers. mkRnSyntaxExpr :: Name -> SyntaxExpr GhcRn -mkRnSyntaxExpr name = SyntaxExpr { syn_expr = HsVar $ noLoc name +mkRnSyntaxExpr name = SyntaxExpr { syn_expr = HsVar noExt $ noLoc name , syn_arg_wraps = [] , syn_res_wrap = WpHole } -- don't care about filling in syn_arg_wraps because we're clearly @@ -279,11 +281,13 @@ information to use is the GlobalRdrEnv itself. -- | A Haskell expression. data HsExpr p - = HsVar (Located (IdP p)) -- ^ Variable + = HsVar (XVar p) + (Located (IdP p)) -- ^ Variable -- See Note [Located RdrNames] - | HsUnboundVar UnboundVar -- ^ Unbound variable; also used for "holes" + | HsUnboundVar (XUnboundVar p) + UnboundVar -- ^ Unbound variable; also used for "holes" -- (_ or _x). -- Turned from HsVar to HsUnboundVar by the -- renamer, when it finds an out-of-scope @@ -291,24 +295,31 @@ data HsExpr p -- Turned into HsVar by type checker, to support -- deferred type errors. - | HsConLikeOut ConLike -- ^ After typechecker only; must be different + | HsConLikeOut (XConLikeOut p) + ConLike -- ^ After typechecker only; must be different -- HsVar for pretty printing - | HsRecFld (AmbiguousFieldOcc p) -- ^ Variable pointing to record selector + | HsRecFld (XRecFld p) + (AmbiguousFieldOcc p) -- ^ Variable pointing to record selector -- Not in use after typechecking - | HsOverLabel (Maybe (IdP p)) FastString + | HsOverLabel (XOverLabel p) + (Maybe (IdP p)) FastString -- ^ Overloaded label (Note [Overloaded labels] in GHC.OverloadedLabels) -- @Just id@ means @RebindableSyntax@ is in use, and gives the id of the -- in-scope 'fromLabel'. -- NB: Not in use after typechecking - | HsIPVar HsIPName -- ^ Implicit parameter (not in use after typechecking) - | HsOverLit (HsOverLit p) -- ^ Overloaded literals + | HsIPVar (XIPVar p) + HsIPName -- ^ Implicit parameter (not in use after typechecking) + | HsOverLit (XOverLitE p) + (HsOverLit p) -- ^ Overloaded literals - | HsLit (HsLit p) -- ^ Simple (non-overloaded) literals + | HsLit (XLitE p) + (HsLit p) -- ^ Simple (non-overloaded) literals - | HsLam (MatchGroup p (LHsExpr p)) + | HsLam (XLam p) + (MatchGroup p (LHsExpr p)) -- ^ Lambda abstraction. Currently always a single match -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLam', @@ -316,7 +327,7 @@ data HsExpr p -- For details on above see note [Api annotations] in ApiAnnotation - | HsLamCase (MatchGroup p (LHsExpr p)) -- ^ Lambda-case + | HsLamCase (XLamCase p) (MatchGroup p (LHsExpr p)) -- ^ Lambda-case -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLam', -- 'ApiAnnotation.AnnCase','ApiAnnotation.AnnOpen', @@ -324,28 +335,24 @@ data HsExpr p -- For details on above see note [Api annotations] in ApiAnnotation - | HsApp (LHsExpr p) (LHsExpr p) -- ^ Application + | HsApp (XApp p) (LHsExpr p) (LHsExpr p) -- ^ Application - | HsAppType (LHsExpr p) (LHsWcType p) -- ^ Visible type application + | HsAppType (XAppTypeE p) (LHsExpr p) -- ^ Visible type application -- -- Explicit type argument; e.g f @Int x y -- NB: Has wildcards, but no implicit quantification -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt', - -- TODO:AZ: Sort out Name - | HsAppTypeOut (LHsExpr p) (LHsWcType GhcRn) -- just for pretty-printing - - -- | Operator applications: -- NB Bracketed ops such as (+) come out as Vars. -- NB We need an expr for the operator in an OpApp/Section since -- the typechecker may need to apply the operator to a few types. - | OpApp (LHsExpr p) -- left operand + | OpApp (XOpApp p) + (LHsExpr p) -- left operand (LHsExpr p) -- operator - (PostRn p Fixity) -- Renamer adds fixity; bottom until then (LHsExpr p) -- right operand -- | Negation operator. Contains the negated expression and the name @@ -354,18 +361,22 @@ data HsExpr p -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnMinus' -- For details on above see note [Api annotations] in ApiAnnotation - | NegApp (LHsExpr p) + | NegApp (XNegApp p) + (LHsExpr p) (SyntaxExpr p) -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@, -- 'ApiAnnotation.AnnClose' @')'@ -- For details on above see note [Api annotations] in ApiAnnotation - | HsPar (LHsExpr p) -- ^ Parenthesised expr; see Note [Parens in HsSyn] + | HsPar (XPar p) + (LHsExpr p) -- ^ Parenthesised expr; see Note [Parens in HsSyn] - | SectionL (LHsExpr p) -- operand; see Note [Sections in HsSyn] + | SectionL (XSectionL p) + (LHsExpr p) -- operand; see Note [Sections in HsSyn] (LHsExpr p) -- operator - | SectionR (LHsExpr p) -- operator; see Note [Sections in HsSyn] + | SectionR (XSectionR p) + (LHsExpr p) -- operator; see Note [Sections in HsSyn] (LHsExpr p) -- operand -- | Used for explicit tuples and sections thereof @@ -375,6 +386,7 @@ data HsExpr p -- For details on above see note [Api annotations] in ApiAnnotation | ExplicitTuple + (XExplicitTuple p) [LHsTupArg p] Boxity @@ -386,17 +398,18 @@ data HsExpr p -- There will be multiple 'ApiAnnotation.AnnVbar', (1 - alternative) before -- the expression, (arity - alternative) after it | ExplicitSum + (XExplicitSum p) ConTag -- Alternative (one-based) Arity -- Sum arity (LHsExpr p) - (PostTc p [Type]) -- the type arguments -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnCase', -- 'ApiAnnotation.AnnOf','ApiAnnotation.AnnOpen' @'{'@, -- 'ApiAnnotation.AnnClose' @'}'@ -- For details on above see note [Api annotations] in ApiAnnotation - | HsCase (LHsExpr p) + | HsCase (XCase p) + (LHsExpr p) (MatchGroup p (LHsExpr p)) -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnIf', @@ -405,7 +418,8 @@ data HsExpr p -- 'ApiAnnotation.AnnElse', -- For details on above see note [Api annotations] in ApiAnnotation - | HsIf (Maybe (SyntaxExpr p)) -- cond function + | HsIf (XIf p) + (Maybe (SyntaxExpr p)) -- cond function -- Nothing => use the built-in 'if' -- See Note [Rebindable if] (LHsExpr p) -- predicate @@ -418,7 +432,7 @@ data HsExpr p -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose', -- For details on above see note [Api annotations] in ApiAnnotation - | HsMultiIf (PostTc p Type) [LGRHS p (LHsExpr p)] + | HsMultiIf (XMultiIf p) [LGRHS p (LHsExpr p)] -- | let(rec) -- @@ -427,7 +441,8 @@ data HsExpr p -- 'ApiAnnotation.AnnClose' @'}'@,'ApiAnnotation.AnnIn' -- For details on above see note [Api annotations] in ApiAnnotation - | HsLet (LHsLocalBinds p) + | HsLet (XLet p) + (LHsLocalBinds p) (LHsExpr p) -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDo', @@ -436,11 +451,11 @@ data HsExpr p -- 'ApiAnnotation.AnnClose' -- For details on above see note [Api annotations] in ApiAnnotation - | HsDo (HsStmtContext Name) -- The parameterisation is unimportant + | HsDo (XDo p) -- Type of the whole expression + (HsStmtContext Name) -- The parameterisation is unimportant -- because in this context we never use -- the PatGuard or ParStmt variant (Located [ExprLStmt p]) -- "do":one or more stmts - (PostTc p Type) -- Type of the whole expression -- | Syntactic list: [a,b,c,...] -- @@ -449,7 +464,7 @@ data HsExpr p -- For details on above see note [Api annotations] in ApiAnnotation | ExplicitList - (PostTc p Type) -- Gives type of components of list + (XExplicitList p) -- Gives type of components of list (Maybe (SyntaxExpr p)) -- For OverloadedLists, the fromListN witness [LHsExpr p] @@ -463,7 +478,7 @@ data HsExpr p -- For details on above see note [Api annotations] in ApiAnnotation | ExplicitPArr - (PostTc p Type) -- type of elements of the parallel array + (XExplicitPArr p) -- type of elements of the parallel array [LHsExpr p] -- | Record construction @@ -473,11 +488,9 @@ data HsExpr p -- For details on above see note [Api annotations] in ApiAnnotation | RecordCon - { rcon_con_name :: Located (IdP p) -- The constructor name; + { rcon_ext :: XRecordCon p + , rcon_con_name :: Located (IdP p) -- The constructor name; -- not used after type checking - , rcon_con_like :: PostTc p ConLike - -- The data constructor or pattern synonym - , rcon_con_expr :: PostTcExpr -- Instantiated constructor function , rcon_flds :: HsRecordBinds p } -- The fields -- | Record update @@ -487,18 +500,9 @@ data HsExpr p -- For details on above see note [Api annotations] in ApiAnnotation | RecordUpd - { rupd_expr :: LHsExpr p + { rupd_ext :: XRecordUpd p + , rupd_expr :: LHsExpr p , rupd_flds :: [LHsRecUpdField p] - , rupd_cons :: PostTc p [ConLike] - -- Filled in by the type checker to the - -- _non-empty_ list of DataCons that have - -- all the upd'd fields - - , rupd_in_tys :: PostTc p [Type] -- Argument types of *input* record type - , rupd_out_tys :: PostTc p [Type] -- and *output* record type - -- The original type can be reconstructed - -- with conLikeResTy - , rupd_wrap :: PostTc p HsWrapper -- See note [Record Update HsWrapper] } -- For a type family, the arg types are of the *instance* tycon, -- not the family tycon @@ -509,14 +513,10 @@ data HsExpr p -- For details on above see note [Api annotations] in ApiAnnotation | ExprWithTySig - (LHsExpr p) - (LHsSigWcType p) - - | ExprWithTySigOut -- Post typechecking - (LHsExpr p) - (LHsSigWcType GhcRn) -- Retain the signature, + (XExprWithTySig p) -- Retain the signature, -- as HsSigType Name, for -- round-tripping purposes + (LHsExpr p) -- | Arithmetic sequence -- @@ -526,7 +526,7 @@ data HsExpr p -- For details on above see note [Api annotations] in ApiAnnotation | ArithSeq - PostTcExpr + (XArithSeq p) (Maybe (SyntaxExpr p)) -- For OverloadedLists, the fromList witness (ArithSeqInfo p) @@ -542,7 +542,7 @@ data HsExpr p -- For details on above see note [Api annotations] in ApiAnnotation | PArrSeq - PostTcExpr + (XPArrSeq p) (ArithSeqInfo p) -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{-\# SCC'@, @@ -550,7 +550,8 @@ data HsExpr p -- 'ApiAnnotation.AnnClose' @'\#-}'@ -- For details on above see note [Api annotations] in ApiAnnotation - | HsSCC SourceText -- Note [Pragma source text] in BasicTypes + | HsSCC (XSCC p) + SourceText -- Note [Pragma source text] in BasicTypes StringLiteral -- "set cost centre" SCC pragma (LHsExpr p) -- expr whose cost is to be measured @@ -558,7 +559,8 @@ data HsExpr p -- 'ApiAnnotation.AnnVal', 'ApiAnnotation.AnnClose' @'\#-}'@ -- For details on above see note [Api annotations] in ApiAnnotation - | HsCoreAnn SourceText -- Note [Pragma source text] in BasicTypes + | HsCoreAnn (XCoreAnn p) + SourceText -- Note [Pragma source text] in BasicTypes StringLiteral -- hdaume: core annotation (LHsExpr p) @@ -570,15 +572,17 @@ data HsExpr p -- 'ApiAnnotation.AnnClose','ApiAnnotation.AnnCloseQ' -- For details on above see note [Api annotations] in ApiAnnotation - | HsBracket (HsBracket p) + | HsBracket (XBracket p) (HsBracket p) -- See Note [Pending Splices] | HsRnBracketOut + (XRnBracketOut p) (HsBracket GhcRn) -- Output of the renamer is the *original* renamed -- expression, plus [PendingRnSplice] -- _renamed_ splices to be type checked | HsTcBracketOut + (XTcBracketOut p) (HsBracket GhcRn) -- Output of the type checker is the *original* -- renamed expression, plus [PendingTcSplice] -- _typechecked_ splices to be @@ -588,7 +592,7 @@ data HsExpr p -- 'ApiAnnotation.AnnClose' -- For details on above see note [Api annotations] in ApiAnnotation - | HsSpliceE (HsSplice p) + | HsSpliceE (XSpliceE p) (HsSplice p) ----------------------------------------------------------- -- Arrow notation extension @@ -599,7 +603,8 @@ data HsExpr p -- 'ApiAnnotation.AnnRarrow' -- For details on above see note [Api annotations] in ApiAnnotation - | HsProc (LPat p) -- arrow abstraction, proc + | HsProc (XProc p) + (LPat p) -- arrow abstraction, proc (LHsCmdTop p) -- body of the abstraction -- always has an empty stack @@ -608,7 +613,7 @@ data HsExpr p -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnStatic', -- For details on above see note [Api annotations] in ApiAnnotation - | HsStatic (PostRn p NameSet) -- Free variables of the body + | HsStatic (XStatic p) -- Free variables of the body (LHsExpr p) -- Body --------------------------------------- @@ -622,10 +627,10 @@ data HsExpr p -- For details on above see note [Api annotations] in ApiAnnotation | HsArrApp -- Arrow tail, or arrow application (f -< arg) + (XArrApp p) -- type of the arrow expressions f, + -- of the form a t t', where arg :: t (LHsExpr p) -- arrow expression, f (LHsExpr p) -- input expression, arg - (PostTc p Type) -- type of the arrow expressions f, - -- of the form a t t', where arg :: t HsArrAppType -- higher-order (-<<) or first-order (-<) Bool -- True => right-to-left (f -< arg) -- False => left-to-right (arg >- f) @@ -635,6 +640,7 @@ data HsExpr p -- For details on above see note [Api annotations] in ApiAnnotation | HsArrForm -- Command formation, (| e cmd1 .. cmdn |) + (XArrForm p) (LHsExpr p) -- the operator -- after type-checking, a type abstraction to be -- applied to the type of the local environment tuple @@ -646,10 +652,12 @@ data HsExpr p -- Haskell program coverage (Hpc) Support | HsTick + (XTick p) (Tickish (IdP p)) (LHsExpr p) -- sub-expression | HsBinTick + (XBinTick p) Int -- module-local tick number for True Int -- module-local tick number for False (LHsExpr p) -- sub-expression @@ -665,6 +673,7 @@ data HsExpr p -- For details on above see note [Api annotations] in ApiAnnotation | HsTickPragma -- A pragma introduced tick + (XTickPragma p) SourceText -- Note [Pragma source text] in BasicTypes (StringLiteral,(Int,Int),(Int,Int)) -- external span for this tick @@ -677,24 +686,26 @@ data HsExpr p -- These constructors only appear temporarily in the parser. -- The renamer translates them into the Right Thing. - | EWildPat -- wildcard + | EWildPat (XEWildPat p) -- wildcard -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt' -- For details on above see note [Api annotations] in ApiAnnotation - | EAsPat (Located (IdP p)) -- as pattern + | EAsPat (XEAsPat p) + (Located (IdP p)) -- as pattern (LHsExpr p) -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow' -- For details on above see note [Api annotations] in ApiAnnotation - | EViewPat (LHsExpr p) -- view pattern + | EViewPat (XEViewPat p) + (LHsExpr p) -- view pattern (LHsExpr p) -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnTilde' -- For details on above see note [Api annotations] in ApiAnnotation - | ELazyPat (LHsExpr p) -- ~ pattern + | ELazyPat (XELazyPat p) (LHsExpr p) -- ~ pattern --------------------------------------- @@ -703,11 +714,140 @@ data HsExpr p -- See Note [Detecting forced eta expansion] in DsExpr. This invariant -- is maintained by HsUtils.mkHsWrap. - | HsWrap HsWrapper -- TRANSLATION + | HsWrap (XWrap p) + HsWrapper -- TRANSLATION (HsExpr p) + | XExpr (XXExpr p) -- Note [Trees that Grow] extension constructor + deriving instance (DataIdLR p p) => Data (HsExpr p) +-- | Extra data fields for a 'RecordCon', added by the type checker +data RecordConTc = RecordConTc + { rcon_con_like :: ConLike -- The data constructor or pattern synonym + , rcon_con_expr :: PostTcExpr -- Instantiated constructor function + } deriving Data + + +-- | Extra data fields for a 'RecordUpd', added by the type checker +data RecordUpdTc = RecordUpdTc + { rupd_cons :: [ConLike] + -- Filled in by the type checker to the + -- _non-empty_ list of DataCons that have + -- all the upd'd fields + + , rupd_in_tys :: [Type] -- Argument types of *input* record type + , rupd_out_tys :: [Type] -- and *output* record type + -- The original type can be reconstructed + -- with conLikeResTy + , rupd_wrap :: HsWrapper -- See note [Record Update HsWrapper] + } deriving Data + +-- --------------------------------------------------------------------- +type instance XVarPat (GhcPass _) = PlaceHolder + +type instance XVar (GhcPass _) = PlaceHolder +type instance XUnboundVar (GhcPass _) = PlaceHolder +type instance XConLikeOut (GhcPass _) = PlaceHolder +type instance XRecFld (GhcPass _) = PlaceHolder +type instance XOverLabel (GhcPass _) = PlaceHolder +type instance XIPVar (GhcPass _) = PlaceHolder +type instance XOverLitE (GhcPass _) = PlaceHolder +type instance XLitE (GhcPass _) = PlaceHolder +type instance XLam (GhcPass _) = PlaceHolder +type instance XLamCase (GhcPass _) = PlaceHolder +type instance XApp (GhcPass _) = PlaceHolder + +type instance XAppTypeE GhcPs = LHsWcType GhcPs +type instance XAppTypeE GhcRn = LHsWcType GhcRn +type instance XAppTypeE GhcTc = LHsWcType GhcRn + +type instance XOpApp GhcPs = PlaceHolder +type instance XOpApp GhcRn = Fixity +type instance XOpApp GhcTc = Fixity + +type instance XNegApp (GhcPass _) = PlaceHolder +type instance XPar (GhcPass _) = PlaceHolder +type instance XSectionL (GhcPass _) = PlaceHolder +type instance XSectionR (GhcPass _) = PlaceHolder +type instance XExplicitTuple (GhcPass _) = PlaceHolder + +type instance XExplicitSum GhcPs = PlaceHolder +type instance XExplicitSum GhcRn = PlaceHolder +type instance XExplicitSum GhcTc = [Type] + +type instance XCase (GhcPass _) = PlaceHolder +type instance XIf (GhcPass _) = PlaceHolder + +type instance XMultiIf GhcPs = PlaceHolder +type instance XMultiIf GhcRn = PlaceHolder +type instance XMultiIf GhcTc = Type + +type instance XLet (GhcPass _) = PlaceHolder + +type instance XDo GhcPs = PlaceHolder +type instance XDo GhcRn = PlaceHolder +type instance XDo GhcTc = Type + +type instance XExplicitList GhcPs = PlaceHolder +type instance XExplicitList GhcRn = PlaceHolder +type instance XExplicitList GhcTc = Type + +type instance XExplicitPArr GhcPs = PlaceHolder +type instance XExplicitPArr GhcRn = PlaceHolder +type instance XExplicitPArr GhcTc = Type + +type instance XRecordCon GhcPs = PlaceHolder +type instance XRecordCon GhcRn = PlaceHolder +type instance XRecordCon GhcTc = RecordConTc + +type instance XRecordUpd GhcPs = PlaceHolder +type instance XRecordUpd GhcRn = PlaceHolder +type instance XRecordUpd GhcTc = RecordUpdTc + +type instance XExprWithTySig GhcPs = (LHsSigWcType GhcPs) +type instance XExprWithTySig GhcRn = (LHsSigWcType GhcRn) +type instance XExprWithTySig GhcTc = (LHsSigWcType GhcRn) + +type instance XArithSeq GhcPs = PlaceHolder +type instance XArithSeq GhcRn = PlaceHolder +type instance XArithSeq GhcTc = PostTcExpr + +type instance XPArrSeq GhcPs = PlaceHolder +type instance XPArrSeq GhcRn = PlaceHolder +type instance XPArrSeq GhcTc = PostTcExpr + +type instance XSCC (GhcPass _) = PlaceHolder +type instance XCoreAnn (GhcPass _) = PlaceHolder +type instance XBracket (GhcPass _) = PlaceHolder + +type instance XRnBracketOut (GhcPass _) = PlaceHolder +type instance XTcBracketOut (GhcPass _) = PlaceHolder + +type instance XSpliceE (GhcPass _) = PlaceHolder +type instance XProc (GhcPass _) = PlaceHolder + +type instance XStatic GhcPs = PlaceHolder +type instance XStatic GhcRn = NameSet +type instance XStatic GhcTc = NameSet + +type instance XArrApp GhcPs = PlaceHolder +type instance XArrApp GhcRn = PlaceHolder +type instance XArrApp GhcTc = Type + +type instance XArrForm (GhcPass _) = PlaceHolder +type instance XTick (GhcPass _) = PlaceHolder +type instance XBinTick (GhcPass _) = PlaceHolder +type instance XTickPragma (GhcPass _) = PlaceHolder +type instance XEWildPat (GhcPass _) = PlaceHolder +type instance XEAsPat (GhcPass _) = PlaceHolder +type instance XEViewPat (GhcPass _) = PlaceHolder +type instance XELazyPat (GhcPass _) = PlaceHolder +type instance XWrap (GhcPass _) = PlaceHolder +type instance XXExpr (GhcPass _) = PlaceHolder + +-- --------------------------------------------------------------------- + -- | Located Haskell Tuple Argument -- -- 'HsTupArg' is used for tuple sections @@ -821,12 +961,11 @@ isQuietHsExpr :: HsExpr id -> Bool -- Parentheses do display something, but it gives little info and -- if we go deeper when we go inside them then we get ugly things -- like (...) -isQuietHsExpr (HsPar _) = True +isQuietHsExpr (HsPar {}) = True -- applications don't display anything themselves -isQuietHsExpr (HsApp _ _) = True -isQuietHsExpr (HsAppType _ _) = True -isQuietHsExpr (HsAppTypeOut _ _) = True -isQuietHsExpr (OpApp _ _ _ _) = True +isQuietHsExpr (HsApp {}) = True +isQuietHsExpr (HsAppType {}) = True +isQuietHsExpr (OpApp {}) = True isQuietHsExpr _ = False pprBinds :: (SourceTextX (GhcPass idL), SourceTextX (GhcPass idR), @@ -841,38 +980,37 @@ ppr_lexpr e = ppr_expr (unLoc e) ppr_expr :: forall p. (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) => HsExpr (GhcPass p) -> SDoc -ppr_expr (HsVar (L _ v)) = pprPrefixOcc v -ppr_expr (HsUnboundVar uv)= pprPrefixOcc (unboundVarOcc uv) -ppr_expr (HsConLikeOut c) = pprPrefixOcc c -ppr_expr (HsIPVar v) = ppr v -ppr_expr (HsOverLabel _ l)= char '#' <> ppr l -ppr_expr (HsLit lit) = ppr lit -ppr_expr (HsOverLit lit) = ppr lit -ppr_expr (HsPar e) = parens (ppr_lexpr e) - -ppr_expr (HsCoreAnn stc (StringLiteral sta s) e) +ppr_expr (HsVar _ (L _ v)) = pprPrefixOcc v +ppr_expr (HsUnboundVar _ uv)= pprPrefixOcc (unboundVarOcc uv) +ppr_expr (HsConLikeOut _ c) = pprPrefixOcc c +ppr_expr (HsIPVar _ v) = ppr v +ppr_expr (HsOverLabel _ _ l)= char '#' <> ppr l +ppr_expr (HsLit _ lit) = ppr lit +ppr_expr (HsOverLit _ lit) = ppr lit +ppr_expr (HsPar _ e) = parens (ppr_lexpr e) + +ppr_expr (HsCoreAnn _ stc (StringLiteral sta s) e) = vcat [pprWithSourceText stc (text "{-# CORE") <+> pprWithSourceText sta (doubleQuotes $ ftext s) <+> text "#-}" , ppr_lexpr e] ppr_expr e@(HsApp {}) = ppr_apps e [] ppr_expr e@(HsAppType {}) = ppr_apps e [] -ppr_expr e@(HsAppTypeOut {}) = ppr_apps e [] -ppr_expr (OpApp e1 op _ e2) +ppr_expr (OpApp _ e1 op e2) | Just pp_op <- should_print_infix (unLoc op) = pp_infixly pp_op | otherwise = pp_prefixly where - should_print_infix (HsVar (L _ v)) = Just (pprInfixOcc v) - should_print_infix (HsConLikeOut c)= Just (pprInfixOcc (conLikeName c)) - should_print_infix (HsRecFld f) = Just (pprInfixOcc f) - should_print_infix (HsUnboundVar h@TrueExprHole{}) + should_print_infix (HsVar _ (L _ v)) = Just (pprInfixOcc v) + should_print_infix (HsConLikeOut _ c)= Just (pprInfixOcc (conLikeName c)) + should_print_infix (HsRecFld _ f) = Just (pprInfixOcc f) + should_print_infix (HsUnboundVar _ h@TrueExprHole{}) = Just (pprInfixOcc (unboundVarOcc h)) - should_print_infix EWildPat = Just (text "`_`") - should_print_infix (HsWrap _ e) = should_print_infix e + should_print_infix (EWildPat _) = Just (text "`_`") + should_print_infix (HsWrap _ _ e) = should_print_infix e should_print_infix _ = Nothing pp_e1 = pprDebugParendExpr e1 -- In debug mode, add parens @@ -884,33 +1022,35 @@ ppr_expr (OpApp e1 op _ e2) pp_infixly pp_op = hang pp_e1 2 (sep [pp_op, nest 2 pp_e2]) -ppr_expr (NegApp e _) = char '-' <+> pprDebugParendExpr e +ppr_expr (NegApp _ e _) = char '-' <+> pprDebugParendExpr e -ppr_expr (SectionL expr op) +ppr_expr (SectionL _ expr op) = case unLoc op of - HsVar (L _ v) -> pp_infixly v - HsConLikeOut c -> pp_infixly (conLikeName c) - _ -> pp_prefixly + HsVar _ (L _ v) -> pp_infixly v + HsConLikeOut _ c -> pp_infixly_n (conLikeName c) + _ -> pp_prefixly where pp_expr = pprDebugParendExpr expr pp_prefixly = hang (hsep [text " \\ x_ ->", ppr op]) 4 (hsep [pp_expr, text "x_ )"]) - pp_infixly v = (sep [pp_expr, pprInfixOcc v]) + pp_infixly_n v = (sep [pp_expr, pprInfixOcc v]) + pp_infixly v = (sep [pp_expr, pprInfixOcc v]) -ppr_expr (SectionR op expr) +ppr_expr (SectionR _ op expr) = case unLoc op of - HsVar (L _ v) -> pp_infixly v - HsConLikeOut c -> pp_infixly (conLikeName c) - _ -> pp_prefixly + HsVar _ (L _ v) -> pp_infixly v + HsConLikeOut _ c -> pp_infixly_n (conLikeName c) + _ -> pp_prefixly where pp_expr = pprDebugParendExpr expr pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, text "x_"]) 4 (pp_expr <> rparen) - pp_infixly v = sep [pprInfixOcc v, pp_expr] + pp_infixly v = sep [pprInfixOcc v, pp_expr] + pp_infixly_n v = sep [pprInfixOcc v, pp_expr] -ppr_expr (ExplicitTuple exprs boxity) +ppr_expr (ExplicitTuple _ exprs boxity) = tupleParens (boxityTupleSort boxity) (fcat (ppr_tup_args $ map unLoc exprs)) where ppr_tup_args [] = [] @@ -921,26 +1061,26 @@ ppr_expr (ExplicitTuple exprs boxity) punc (Missing {} : _) = comma punc [] = empty -ppr_expr (ExplicitSum alt arity expr _) +ppr_expr (ExplicitSum _ alt arity expr) = text "(#" <+> ppr_bars (alt - 1) <+> ppr expr <+> ppr_bars (arity - alt) <+> text "#)" where ppr_bars n = hsep (replicate n (char '|')) -ppr_expr (HsLam matches) +ppr_expr (HsLam _ matches) = pprMatches matches -ppr_expr (HsLamCase matches) +ppr_expr (HsLamCase _ matches) = sep [ sep [text "\\case"], nest 2 (pprMatches matches) ] -ppr_expr (HsCase expr matches@(MG { mg_alts = L _ [_] })) +ppr_expr (HsCase _ expr matches@(MG { mg_alts = L _ [_] })) = sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of {")], nest 2 (pprMatches matches) <+> char '}'] -ppr_expr (HsCase expr matches) +ppr_expr (HsCase _ expr matches) = sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of")], nest 2 (pprMatches matches) ] -ppr_expr (HsIf _ e1 e2 e3) +ppr_expr (HsIf _ _ e1 e2 e3) = sep [hsep [text "if", nest 2 (ppr e1), ptext (sLit "then")], nest 4 (ppr e2), text "else", @@ -957,15 +1097,15 @@ ppr_expr (HsMultiIf _ alts) , text "->" <+> pprDeeper (ppr expr) ] -- special case: let ... in let ... -ppr_expr (HsLet (L _ binds) expr@(L _ (HsLet _ _))) +ppr_expr (HsLet _ (L _ binds) expr@(L _ (HsLet _ _ _))) = sep [hang (text "let") 2 (hsep [pprBinds binds, ptext (sLit "in")]), ppr_lexpr expr] -ppr_expr (HsLet (L _ binds) expr) +ppr_expr (HsLet _ (L _ binds) expr) = sep [hang (text "let") 2 (pprBinds binds), hang (text "in") 2 (ppr expr)] -ppr_expr (HsDo do_or_list_comp (L _ stmts) _) = pprDo do_or_list_comp stmts +ppr_expr (HsDo _ do_or_list_comp (L _ stmts)) = pprDo do_or_list_comp stmts ppr_expr (ExplicitList _ _ exprs) = brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs))) @@ -979,49 +1119,46 @@ ppr_expr (RecordCon { rcon_con_name = con_id, rcon_flds = rbinds }) ppr_expr (RecordUpd { rupd_expr = L _ aexp, rupd_flds = rbinds }) = hang (ppr aexp) 2 (braces (fsep (punctuate comma (map ppr rbinds)))) -ppr_expr (ExprWithTySig expr sig) - = hang (nest 2 (ppr_lexpr expr) <+> dcolon) - 4 (ppr sig) -ppr_expr (ExprWithTySigOut expr sig) +ppr_expr (ExprWithTySig sig expr) = hang (nest 2 (ppr_lexpr expr) <+> dcolon) 4 (ppr sig) ppr_expr (ArithSeq _ _ info) = brackets (ppr info) -ppr_expr (PArrSeq _ info) = paBrackets (ppr info) +ppr_expr (PArrSeq _ info) = paBrackets (ppr info) -ppr_expr EWildPat = char '_' -ppr_expr (ELazyPat e) = char '~' <> ppr e -ppr_expr (EAsPat v e) = ppr v <> char '@' <> ppr e -ppr_expr (EViewPat p e) = ppr p <+> text "->" <+> ppr e +ppr_expr (EWildPat _) = char '_' +ppr_expr (ELazyPat _ e) = char '~' <> ppr e +ppr_expr (EAsPat _ v e) = ppr v <> char '@' <> ppr e +ppr_expr (EViewPat _ p e) = ppr p <+> text "->" <+> ppr e -ppr_expr (HsSCC st (StringLiteral stl lbl) expr) +ppr_expr (HsSCC _ st (StringLiteral stl lbl) expr) = sep [ pprWithSourceText st (text "{-# SCC") -- no doublequotes if stl empty, for the case where the SCC was written -- without quotes. <+> pprWithSourceText stl (ftext lbl) <+> text "#-}", ppr expr ] -ppr_expr (HsWrap co_fn e) +ppr_expr (HsWrap _ co_fn e) = pprHsWrapper co_fn (\parens -> if parens then pprExpr e else pprExpr e) -ppr_expr (HsSpliceE s) = pprSplice s -ppr_expr (HsBracket b) = pprHsBracket b -ppr_expr (HsRnBracketOut e []) = ppr e -ppr_expr (HsRnBracketOut e ps) = ppr e $$ text "pending(rn)" <+> ppr ps -ppr_expr (HsTcBracketOut e []) = ppr e -ppr_expr (HsTcBracketOut e ps) = ppr e $$ text "pending(tc)" <+> ppr ps +ppr_expr (HsSpliceE _ s) = pprSplice s +ppr_expr (HsBracket _ b) = pprHsBracket b +ppr_expr (HsRnBracketOut _ e []) = ppr e +ppr_expr (HsRnBracketOut _ e ps) = ppr e $$ text "pending(rn)" <+> ppr ps +ppr_expr (HsTcBracketOut _ e []) = ppr e +ppr_expr (HsTcBracketOut _ e ps) = ppr e $$ text "pending(tc)" <+> ppr ps -ppr_expr (HsProc pat (L _ (HsCmdTop cmd _ _ _))) +ppr_expr (HsProc _ pat (L _ (HsCmdTop cmd _ _ _))) = hsep [text "proc", ppr pat, ptext (sLit "->"), ppr cmd] ppr_expr (HsStatic _ e) = hsep [text "static", ppr e] -ppr_expr (HsTick tickish exp) +ppr_expr (HsTick _ tickish exp) = pprTicks (ppr exp) $ ppr tickish <+> ppr_lexpr exp -ppr_expr (HsBinTick tickIdTrue tickIdFalse exp) +ppr_expr (HsBinTick _ tickIdTrue tickIdFalse exp) = pprTicks (ppr exp) $ hcat [text "bintick<", ppr tickIdTrue, @@ -1029,7 +1166,7 @@ ppr_expr (HsBinTick tickIdTrue tickIdFalse exp) ppr tickIdFalse, text ">(", ppr exp, text ")"] -ppr_expr (HsTickPragma _ externalSrcLoc _ exp) +ppr_expr (HsTickPragma _ _ externalSrcLoc _ exp) = pprTicks (ppr exp) $ hcat [text "tickpragma<", pprExternalSrcLoc externalSrcLoc, @@ -1037,23 +1174,24 @@ ppr_expr (HsTickPragma _ externalSrcLoc _ exp) ppr exp, text ")"] -ppr_expr (HsArrApp arrow arg _ HsFirstOrderApp True) +ppr_expr (HsArrApp _ arrow arg HsFirstOrderApp True) = hsep [ppr_lexpr arrow, larrowt, ppr_lexpr arg] -ppr_expr (HsArrApp arrow arg _ HsFirstOrderApp False) +ppr_expr (HsArrApp _ arrow arg HsFirstOrderApp False) = hsep [ppr_lexpr arg, arrowt, ppr_lexpr arrow] -ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp True) +ppr_expr (HsArrApp _ arrow arg HsHigherOrderApp True) = hsep [ppr_lexpr arrow, larrowtt, ppr_lexpr arg] -ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp False) +ppr_expr (HsArrApp _ arrow arg HsHigherOrderApp False) = hsep [ppr_lexpr arg, arrowtt, ppr_lexpr arrow] -ppr_expr (HsArrForm (L _ (HsVar (L _ v))) (Just _) [arg1, arg2]) +ppr_expr (HsArrForm _ (L _ (HsVar _ (L _ v))) (Just _) [arg1, arg2]) = sep [pprCmdArg (unLoc arg1), hsep [pprInfixOcc v, pprCmdArg (unLoc arg2)]] -ppr_expr (HsArrForm (L _ (HsConLikeOut c)) (Just _) [arg1, arg2]) +ppr_expr (HsArrForm _ (L _ (HsConLikeOut _ c)) (Just _) [arg1, arg2]) = sep [pprCmdArg (unLoc arg1), hsep [pprInfixOcc (conLikeName c), pprCmdArg (unLoc arg2)]] -ppr_expr (HsArrForm op _ args) +ppr_expr (HsArrForm _ op _ args) = hang (text "(|" <+> ppr_lexpr op) 4 (sep (map (pprCmdArg.unLoc) args) <+> text "|)") -ppr_expr (HsRecFld f) = ppr f +ppr_expr (HsRecFld _ f) = ppr f +ppr_expr (XExpr x) = ppr x -- We must tiresomely make the "id" parameter to the LHsWcType existential -- because it's different in the HsAppType case and the HsAppTypeOut case @@ -1062,21 +1200,23 @@ data LHsWcTypeX = forall p. ( SourceTextX (GhcPass p) , OutputableBndrId (GhcPass p)) => LHsWcTypeX (LHsWcType (GhcPass p)) -ppr_apps :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) +ppr_apps :: forall p. (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) => HsExpr (GhcPass p) - -> [Either (LHsExpr (GhcPass p)) LHsWcTypeX] + -- -> [Either (LHsExpr (GhcPass p)) LHsWcTypeX] + -> [Either (LHsExpr (GhcPass p)) (XAppTypeE (GhcPass p))] -> SDoc -ppr_apps (HsApp (L _ fun) arg) args +ppr_apps (HsApp _ (L _ fun) arg) args = ppr_apps fun (Left arg : args) -ppr_apps (HsAppType (L _ fun) arg) args - = ppr_apps fun (Right (LHsWcTypeX arg) : args) -ppr_apps (HsAppTypeOut (L _ fun) arg) args - = ppr_apps fun (Right (LHsWcTypeX arg) : args) +ppr_apps (HsAppType arg (L _ fun)) args + = ppr_apps fun (Right arg : args) ppr_apps fun args = hang (ppr_expr fun) 2 (sep (map pp args)) where + -- pp :: Either (LHsExpr (GhcPass p)) (XAppTypeE (GhcPass p)) -> SDoc pp (Left arg) = ppr arg - pp (Right (LHsWcTypeX (HsWC { hswc_body = L _ arg }))) - = char '@' <> pprHsType arg + -- pp (Right (HsWC { hswc_body = L _ arg })) + -- = char '@' <> pprHsType arg + pp (Right arg) + = char '@' <> ppr arg pprExternalSrcLoc :: (StringLiteral,(Int,Int),(Int,Int)) -> SDoc pprExternalSrcLoc (StringLiteral _ src,(n1,n2),(n3,n4)) @@ -1132,13 +1272,13 @@ hsExprNeedsParens (HsPar {}) = False hsExprNeedsParens (HsBracket {}) = False hsExprNeedsParens (HsRnBracketOut {}) = False hsExprNeedsParens (HsTcBracketOut {}) = False -hsExprNeedsParens (HsDo sc _ _) +hsExprNeedsParens (HsDo _ sc _) | isListCompExpr sc = False hsExprNeedsParens (HsRecFld{}) = False hsExprNeedsParens (RecordCon{}) = False hsExprNeedsParens (HsSpliceE{}) = False hsExprNeedsParens (RecordUpd{}) = False -hsExprNeedsParens (HsWrap _ e) = hsExprNeedsParens e +hsExprNeedsParens (HsWrap _ _ e) = hsExprNeedsParens e hsExprNeedsParens _ = True @@ -1151,8 +1291,8 @@ isAtomicHsExpr (HsOverLit {}) = True isAtomicHsExpr (HsIPVar {}) = True isAtomicHsExpr (HsOverLabel {}) = True isAtomicHsExpr (HsUnboundVar {}) = True -isAtomicHsExpr (HsWrap _ e) = isAtomicHsExpr e -isAtomicHsExpr (HsPar e) = isAtomicHsExpr (unLoc e) +isAtomicHsExpr (HsWrap _ _ e) = isAtomicHsExpr e +isAtomicHsExpr (HsPar _ e) = isAtomicHsExpr (unLoc e) isAtomicHsExpr (HsRecFld{}) = True isAtomicHsExpr _ = False @@ -1353,16 +1493,16 @@ ppr_cmd (HsCmdArrApp arrow arg _ HsHigherOrderApp True) ppr_cmd (HsCmdArrApp arrow arg _ HsHigherOrderApp False) = hsep [ppr_lexpr arg, arrowtt, ppr_lexpr arrow] -ppr_cmd (HsCmdArrForm (L _ (HsVar (L _ v))) _ (Just _) [arg1, arg2]) +ppr_cmd (HsCmdArrForm (L _ (HsVar _ (L _ v))) _ (Just _) [arg1, arg2]) = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc v , pprCmdArg (unLoc arg2)]) -ppr_cmd (HsCmdArrForm (L _ (HsVar (L _ v))) Infix _ [arg1, arg2]) +ppr_cmd (HsCmdArrForm (L _ (HsVar _ (L _ v))) Infix _ [arg1, arg2]) = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc v , pprCmdArg (unLoc arg2)]) -ppr_cmd (HsCmdArrForm (L _ (HsConLikeOut c)) _ (Just _) [arg1, arg2]) +ppr_cmd (HsCmdArrForm (L _ (HsConLikeOut _ c)) _ (Just _) [arg1, arg2]) = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc (conLikeName c) , pprCmdArg (unLoc arg2)]) -ppr_cmd (HsCmdArrForm (L _ (HsConLikeOut c)) Infix _ [arg1, arg2]) +ppr_cmd (HsCmdArrForm (L _ (HsConLikeOut _ c)) Infix _ [arg1, arg2]) = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc (conLikeName c) , pprCmdArg (unLoc arg2)]) ppr_cmd (HsCmdArrForm op _ _ args) @@ -1697,7 +1837,7 @@ data StmtLR idL idR body -- body should always be (LHs**** idR) -- | ApplicativeStmt [ ( SyntaxExpr idR - , ApplicativeArg idL idR) ] + , ApplicativeArg idL) ] -- [(<$>, e1), (<*>, e2), ..., (<*>, en)] (Maybe (SyntaxExpr idR)) -- 'join', if necessary (PostTc idR Type) -- Type of the body @@ -1803,7 +1943,7 @@ data ParStmtBlock idL idR deriving instance (DataIdLR idL idR) => Data (ParStmtBlock idL idR) -- | Applicative Argument -data ApplicativeArg idL idR +data ApplicativeArg idL = ApplicativeArgOne -- A single statement (BindStmt or BodyStmt) (LPat idL) -- WildPat if it was a BodyStmt (see below) (LHsExpr idL) @@ -1815,7 +1955,7 @@ data ApplicativeArg idL idR [ExprLStmt idL] -- stmts (HsExpr idL) -- return (v1,..,vn), or just (v1,..,vn) (LPat idL) -- (v1,...,vn) -deriving instance (DataIdLR idL idR) => Data (ApplicativeArg idL idR) +deriving instance (DataIdLR idL idL) => Data (ApplicativeArg idL) {- Note [The type of bind in Stmts] @@ -2031,10 +2171,10 @@ pprStmt (ApplicativeStmt args mb_join _) -- ppr directly rather than transforming here, because we need to -- inject a "return" which is hard when we're polymorphic in the id -- type. - flattenStmt :: ExprLStmt (GhcPass idL) -> [SDoc] flattenStmt (L _ (ApplicativeStmt args _ _)) = concatMap flattenArg args flattenStmt stmt = [ppr stmt] + flattenArg :: (a, ApplicativeArg (GhcPass idL)) -> [SDoc] flattenArg (_, ApplicativeArgOne pat expr isBody) | isBody = -- See Note [Applicative BodyStmt] [ppr (BodyStmt expr noSyntaxExpr noSyntaxExpr (panic "pprStmt") @@ -2053,6 +2193,7 @@ pprStmt (ApplicativeStmt args mb_join _) then ap_expr else text "join" <+> parens ap_expr + pp_arg :: (a, ApplicativeArg (GhcPass idL)) -> SDoc pp_arg (_, ApplicativeArgOne pat expr isBody) | isBody = -- See Note [Applicative BodyStmt] ppr (BodyStmt expr noSyntaxExpr noSyntaxExpr (panic "pprStmt") @@ -2063,9 +2204,8 @@ pprStmt (ApplicativeStmt args mb_join _) pp_arg (_, ApplicativeArgMany stmts return pat) = ppr pat <+> text "<-" <+> - ppr (HsDo DoExpr (noLoc - (stmts ++ [noLoc (LastStmt (noLoc return) False noSyntaxExpr)])) - (error "pprStmt")) + ppr (HsDo (panic "pprStmt") DoExpr (noLoc + (stmts ++ [noLoc (LastStmt (noLoc return) False noSyntaxExpr)]))) pprTransformStmt :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) => [IdP (GhcPass p)] -> LHsExpr (GhcPass p) diff --git a/compiler/hsSyn/HsExtension.hs b/compiler/hsSyn/HsExtension.hs index b641670108..fb689c56d2 100644 --- a/compiler/hsSyn/HsExtension.hs +++ b/compiler/hsSyn/HsExtension.hs @@ -154,9 +154,6 @@ type ForallXValBindsLR (c :: * -> Constraint) (x :: *) (x' :: *)= , c (XXValBindsLR x x') ) - - - -- We define a type family for each HsLit extension point. This is based on -- prepending 'X' to the constructor name, for ease of reference. type family XHsChar x @@ -306,6 +303,112 @@ type ForallXAmbiguousFieldOcc (c :: * -> Constraint) (x :: *) = ) -- --------------------------------------------------------------------- +-- Type families for the HsExpr type families + +type family XVar x +type family XUnboundVar x +type family XConLikeOut x +type family XRecFld x +type family XOverLabel x +type family XIPVar x +type family XOverLitE x +type family XLitE x +type family XLam x +type family XLamCase x +type family XApp x +type family XAppTypeE x +type family XOpApp x +type family XNegApp x +type family XPar x +type family XSectionL x +type family XSectionR x +type family XExplicitTuple x +type family XExplicitSum x +type family XCase x +type family XIf x +type family XMultiIf x +type family XLet x +type family XDo x +type family XExplicitList x +type family XExplicitPArr x +type family XRecordCon x +type family XRecordUpd x +type family XExprWithTySig x +type family XArithSeq x +type family XPArrSeq x +type family XSCC x +type family XCoreAnn x +type family XBracket x +type family XRnBracketOut x +type family XTcBracketOut x +type family XSpliceE x +type family XProc x +type family XStatic x +type family XArrApp x +type family XArrForm x +type family XTick x +type family XBinTick x +type family XTickPragma x +type family XEWildPat x +type family XEAsPat x +type family XEViewPat x +type family XELazyPat x +type family XWrap x +type family XXExpr x + +type ForallXExpr (c :: * -> Constraint) (x :: *) = + ( c (XVar x) + , c (XUnboundVar x) + , c (XConLikeOut x) + , c (XRecFld x) + , c (XOverLabel x) + , c (XIPVar x) + , c (XOverLitE x) + , c (XLitE x) + , c (XLam x) + , c (XLamCase x) + , c (XApp x) + , c (XAppTypeE x) + , c (XOpApp x) + , c (XNegApp x) + , c (XPar x) + , c (XSectionL x) + , c (XSectionR x) + , c (XExplicitTuple x) + , c (XExplicitSum x) + , c (XCase x) + , c (XIf x) + , c (XMultiIf x) + , c (XLet x) + , c (XDo x) + , c (XExplicitList x) + , c (XExplicitPArr x) + , c (XRecordCon x) + , c (XRecordUpd x) + , c (XExprWithTySig x) + , c (XArithSeq x) + , c (XPArrSeq x) + , c (XSCC x) + , c (XCoreAnn x) + , c (XBracket x) + , c (XRnBracketOut x) + , c (XTcBracketOut x) + , c (XSpliceE x) + , c (XProc x) + , c (XStatic x) + , c (XArrApp x) + , c (XArrForm x) + , c (XTick x) + , c (XBinTick x) + , c (XTickPragma x) + , c (XEWildPat x) + , c (XEAsPat x) + , c (XEViewPat x) + , c (XELazyPat x) + , c (XWrap x) + , c (XXExpr x) + ) +-- --------------------------------------------------------------------- -- | The 'SourceText' fields have been moved into the extension fields, thus -- placing a requirement in the extension field to contain a 'SourceText' so @@ -383,11 +486,21 @@ type ConvertIdX a b = type OutputableX p = ( Outputable (XXPat p) , Outputable (XXPat GhcRn) + , Outputable (XSigPat p) , Outputable (XSigPat GhcRn) + , Outputable (XXLit p) + , Outputable (XXOverLit p) + , Outputable (XXType p) + + , Outputable (XExprWithTySig p) + , Outputable (XExprWithTySig GhcRn) + + , Outputable (XAppTypeE p) + , Outputable (XAppTypeE GhcRn) ) -- TODO: Should OutputableX be included in OutputableBndrId? @@ -405,6 +518,7 @@ type DataId p = , ForallXPat Data (GhcPass 'Renamed) -- , ForallXPat Data (GhcPass 'Typechecked) , ForallXType Data (GhcPass 'Renamed) + , ForallXExpr Data (GhcPass 'Renamed) , ForallXOverLit Data p , ForallXType Data p @@ -413,6 +527,8 @@ type DataId p = , ForallXFieldOcc Data p , ForallXAmbiguousFieldOcc Data p + , ForallXExpr Data p + , Data (NameOrRdrName (IdP p)) , Data (IdP p) diff --git a/compiler/hsSyn/HsPat.hs b/compiler/hsSyn/HsPat.hs index e837f522cf..71f932c2e6 100644 --- a/compiler/hsSyn/HsPat.hs +++ b/compiler/hsSyn/HsPat.hs @@ -19,7 +19,6 @@ module HsPat ( Pat(..), InPat, OutPat, LPat, - ListPatTc(..), HsConPatDetails, hsConPatArgs, HsRecFields(..), HsRecField'(..), LHsRecField', @@ -282,15 +281,6 @@ data Pat p (XXPat p) deriving instance (DataIdLR p p) => Data (Pat p) --- | The typechecker-specific information for a 'ListPat' -data ListPatTc = - ListPatTc Type -- The type of the elements - (Maybe (Type, SyntaxExpr GhcTc)) -- For rebindable syntax - -- For OverloadedLists a Just (ty,fn) gives - -- overall type of the pattern, and the toList - -- function to convert the scrutinee to a list value - deriving Data - -- --------------------------------------------------------------------- type instance XWildPat GhcPs = PlaceHolder diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs index f839e4f386..edd5da674c 100644 --- a/compiler/hsSyn/HsUtils.hs +++ b/compiler/hsSyn/HsUtils.hs @@ -140,8 +140,8 @@ from their components, compared with the nl* functions below which just attach noSrcSpan to everything. -} -mkHsPar :: LHsExpr id -> LHsExpr id -mkHsPar e = L (getLoc e) (HsPar e) +mkHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) +mkHsPar e = L (getLoc e) (HsPar noExt e) mkSimpleMatch :: HsMatchContext (NameOrRdrName (IdP id)) -> [LPat id] -> Located (body id) @@ -174,20 +174,21 @@ mkLocatedList :: [Located a] -> Located [Located a] mkLocatedList [] = noLoc [] mkLocatedList ms = L (combineLocs (head ms) (last ms)) ms -mkHsApp :: LHsExpr name -> LHsExpr name -> LHsExpr name -mkHsApp e1 e2 = addCLoc e1 e2 (HsApp e1 e2) +mkHsApp :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) +mkHsApp e1 e2 = addCLoc e1 e2 (HsApp noExt e1 e2) -mkHsAppType :: LHsExpr name -> LHsWcType name -> LHsExpr name -mkHsAppType e t = addCLoc e (hswc_body t) (HsAppType e t) +mkHsAppType :: LHsExpr GhcRn -> LHsWcType GhcRn -> LHsExpr GhcRn +mkHsAppType e t = addCLoc e (hswc_body t) (HsAppType t e) -mkHsAppTypes :: LHsExpr name -> [LHsWcType name] -> LHsExpr name +mkHsAppTypes :: LHsExpr GhcRn -> [LHsWcType GhcRn] -> LHsExpr GhcRn mkHsAppTypes = foldl mkHsAppType +-- AZ:TODO this can go, in favour of mkHsAppType. ? mkHsAppTypeOut :: LHsExpr GhcTc -> LHsWcType GhcRn -> LHsExpr GhcTc -mkHsAppTypeOut e t = addCLoc e (hswc_body t) (HsAppTypeOut e t) +mkHsAppTypeOut e t = addCLoc e (hswc_body t) (HsAppType t e) mkHsLam :: [LPat GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs -mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches)) +mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam noExt matches)) where matches = mkMatchGroup Generated [mkSimpleMatch LambdaExpr pats body] @@ -202,17 +203,19 @@ mkHsCaseAlt :: LPat id -> (Located (body id)) -> LMatch id (Located (body id)) mkHsCaseAlt pat expr = mkSimpleMatch CaseAlt [pat] expr -nlHsTyApp :: IdP name -> [Type] -> LHsExpr name -nlHsTyApp fun_id tys = noLoc (mkHsWrap (mkWpTyApps tys) (HsVar (noLoc fun_id))) +nlHsTyApp :: IdP (GhcPass id) -> [Type] -> LHsExpr (GhcPass id) +nlHsTyApp fun_id tys + = noLoc (mkHsWrap (mkWpTyApps tys) (HsVar noExt (noLoc fun_id))) -nlHsTyApps :: IdP name -> [Type] -> [LHsExpr name] -> LHsExpr name +nlHsTyApps :: IdP (GhcPass id) -> [Type] -> [LHsExpr (GhcPass id)] + -> LHsExpr (GhcPass id) nlHsTyApps fun_id tys xs = foldl nlHsApp (nlHsTyApp fun_id tys) xs --------- Adding parens --------- -mkLHsPar :: LHsExpr name -> LHsExpr name +mkLHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -- Wrap in parens if hsExprNeedsParens says it needs them -- So 'f x' becomes '(f x)', but '3' stays as '3' -mkLHsPar le@(L loc e) | hsExprNeedsParens e = L loc (HsPar le) +mkLHsPar le@(L loc e) | hsExprNeedsParens e = L loc (HsPar noExt le) | otherwise = le mkParPat :: LPat (GhcPass name) -> LPat (GhcPass name) @@ -237,17 +240,19 @@ mkNPat :: Located (HsOverLit GhcPs) -> Maybe (SyntaxExpr GhcPs) -> Pat GhcPs mkNPlusKPat :: Located RdrName -> Located (HsOverLit GhcPs) -> Pat GhcPs -mkLastStmt :: SourceTextX idR - => Located (bodyR idR) -> StmtLR idL idR (Located (bodyR idR)) +mkLastStmt :: SourceTextX (GhcPass idR) + => Located (bodyR (GhcPass idR)) + -> StmtLR (GhcPass idL) (GhcPass idR) (Located (bodyR (GhcPass idR))) mkBodyStmt :: Located (bodyR GhcPs) -> StmtLR idL GhcPs (Located (bodyR GhcPs)) -mkBindStmt :: (SourceTextX idR, PostTc idR Type ~ PlaceHolder) - => LPat idL -> Located (bodyR idR) - -> StmtLR idL idR (Located (bodyR idR)) +mkBindStmt :: (SourceTextX (GhcPass idR), + PostTc (GhcPass idR) Type ~ PlaceHolder) + => LPat (GhcPass idL) -> Located (bodyR (GhcPass idR)) + -> StmtLR (GhcPass idL) (GhcPass idR) (Located (bodyR (GhcPass idR))) mkTcBindStmt :: LPat GhcTc -> Located (bodyR GhcTc) -> StmtLR GhcTc GhcTc (Located (bodyR GhcTc)) -emptyRecStmt :: StmtLR idL GhcPs bodyR +emptyRecStmt :: StmtLR (GhcPass idL) GhcPs bodyR emptyRecStmtName :: StmtLR GhcRn GhcRn bodyR emptyRecStmtId :: StmtLR GhcTc GhcTc bodyR mkRecStmt :: [LStmtLR idL GhcPs bodyR] -> StmtLR idL GhcPs bodyR @@ -260,33 +265,42 @@ mkHsIsString src s = OverLit noExt (HsIsString src s) noExpr noRebindableInfo :: PlaceHolder noRebindableInfo = PlaceHolder -- Just another placeholder; -mkHsDo ctxt stmts = HsDo ctxt (mkLocatedList stmts) placeHolderType +mkHsDo ctxt stmts = HsDo noExt ctxt (mkLocatedList stmts) mkHsComp ctxt stmts expr = mkHsDo ctxt (stmts ++ [last_stmt]) where last_stmt = L (getLoc expr) $ mkLastStmt expr -mkHsIf :: SourceTextX p => LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p -mkHsIf c a b = HsIf (Just noSyntaxExpr) c a b +mkHsIf :: SourceTextX (GhcPass p) + => LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) + -> HsExpr (GhcPass p) +mkHsIf c a b = HsIf noExt (Just noSyntaxExpr) c a b mkNPat lit neg = NPat noExt lit neg noSyntaxExpr mkNPlusKPat id lit = NPlusKPat noExt id lit (unLoc lit) noSyntaxExpr noSyntaxExpr -mkTransformStmt :: (SourceTextX idR, PostTc idR Type ~ PlaceHolder) - => [ExprLStmt idL] -> LHsExpr idR - -> StmtLR idL idR (LHsExpr idL) -mkTransformByStmt :: (SourceTextX idR, PostTc idR Type ~ PlaceHolder) - => [ExprLStmt idL] -> LHsExpr idR -> LHsExpr idR - -> StmtLR idL idR (LHsExpr idL) -mkGroupUsingStmt :: (SourceTextX idR, PostTc idR Type ~ PlaceHolder) - => [ExprLStmt idL] -> LHsExpr idR - -> StmtLR idL idR (LHsExpr idL) -mkGroupByUsingStmt :: (SourceTextX idR, PostTc idR Type ~ PlaceHolder) - => [ExprLStmt idL] -> LHsExpr idR -> LHsExpr idR - -> StmtLR idL idR (LHsExpr idL) - -emptyTransStmt :: (SourceTextX idR, PostTc idR Type ~ PlaceHolder) - => StmtLR idL idR (LHsExpr idR) +mkTransformStmt :: (SourceTextX (GhcPass idR), + PostTc (GhcPass idR) Type ~ PlaceHolder) + => [ExprLStmt (GhcPass idL)] -> LHsExpr (GhcPass idR) + -> StmtLR (GhcPass idL) (GhcPass idR) (LHsExpr (GhcPass idL)) +mkTransformByStmt :: (SourceTextX (GhcPass idR), + PostTc (GhcPass idR) Type ~ PlaceHolder) + => [ExprLStmt (GhcPass idL)] -> LHsExpr (GhcPass idR) + -> LHsExpr (GhcPass idR) + -> StmtLR (GhcPass idL) (GhcPass idR) (LHsExpr (GhcPass idL)) +mkGroupUsingStmt :: (SourceTextX (GhcPass idR), + PostTc (GhcPass idR) Type ~ PlaceHolder) + => [ExprLStmt (GhcPass idL)] -> LHsExpr (GhcPass idR) + -> StmtLR (GhcPass idL) (GhcPass idR) (LHsExpr (GhcPass idL)) +mkGroupByUsingStmt :: (SourceTextX (GhcPass idR), + PostTc (GhcPass idR) Type ~ PlaceHolder) + => [ExprLStmt (GhcPass idL)] -> LHsExpr (GhcPass idR) + -> LHsExpr (GhcPass idR) + -> StmtLR (GhcPass idL) (GhcPass idR) (LHsExpr (GhcPass idL)) + +emptyTransStmt :: (SourceTextX (GhcPass idR), + PostTc (GhcPass idR) Type ~ PlaceHolder) + => StmtLR idL (GhcPass idR) (LHsExpr (GhcPass idR)) emptyTransStmt = TransStmt { trS_form = panic "emptyTransStmt: form" , trS_stmts = [], trS_bndrs = [] , trS_by = Nothing, trS_using = noLoc noExpr @@ -304,8 +318,8 @@ mkBindStmt pat body = BindStmt pat body noSyntaxExpr noSyntaxExpr PlaceHolder mkTcBindStmt pat body = BindStmt pat body noSyntaxExpr noSyntaxExpr unitTy -- don't use placeHolderTypeTc above, because that panics during zonking -emptyRecStmt' :: forall idL idR body. SourceTextX idR => - PostTc idR Type -> StmtLR idL idR body +emptyRecStmt' :: forall idL idR body. SourceTextX (GhcPass idR) => + PostTc (GhcPass idR) Type -> StmtLR (GhcPass idL) (GhcPass idR) body emptyRecStmt' tyVal = RecStmt { recS_stmts = [], recS_later_ids = [] @@ -324,9 +338,8 @@ mkRecStmt stmts = emptyRecStmt { recS_stmts = stmts } ------------------------------- --- A useful function for building @OpApps@. The operator is always a -- variable, and we don't know the fixity yet. -mkHsOpApp :: LHsExpr id -> IdP id -> LHsExpr id -> HsExpr id -mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar (noLoc op))) - (error "mkOpApp:fixity") e2 +mkHsOpApp :: LHsExpr GhcPs -> IdP GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs +mkHsOpApp e1 op e2 = OpApp noExt e1 (noLoc (HsVar noExt (noLoc op))) e2 unqualSplice :: RdrName unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice")) @@ -335,10 +348,11 @@ mkUntypedSplice :: SpliceDecoration -> LHsExpr GhcPs -> HsSplice GhcPs mkUntypedSplice hasParen e = HsUntypedSplice hasParen unqualSplice e mkHsSpliceE :: SpliceDecoration -> LHsExpr GhcPs -> HsExpr GhcPs -mkHsSpliceE hasParen e = HsSpliceE (mkUntypedSplice hasParen e) +mkHsSpliceE hasParen e = HsSpliceE noExt (mkUntypedSplice hasParen e) mkHsSpliceTE :: SpliceDecoration -> LHsExpr GhcPs -> HsExpr GhcPs -mkHsSpliceTE hasParen e = HsSpliceE (HsTypedSplice hasParen unqualSplice e) +mkHsSpliceTE hasParen e + = HsSpliceE noExt (HsTypedSplice hasParen unqualSplice e) mkHsSpliceTy :: SpliceDecoration -> LHsExpr GhcPs -> HsType GhcPs mkHsSpliceTy hasParen e = HsSpliceTy noExt @@ -379,18 +393,18 @@ userHsTyVarBndrs loc bndrs = [ L loc (UserTyVar noExt (L loc v)) ************************************************************************ -} -nlHsVar :: IdP id -> LHsExpr id -nlHsVar n = noLoc (HsVar (noLoc n)) +nlHsVar :: IdP (GhcPass id) -> LHsExpr (GhcPass id) +nlHsVar n = noLoc (HsVar noExt (noLoc n)) -- NB: Only for LHsExpr **Id** nlHsDataCon :: DataCon -> LHsExpr GhcTc -nlHsDataCon con = noLoc (HsConLikeOut (RealDataCon con)) +nlHsDataCon con = noLoc (HsConLikeOut noExt (RealDataCon con)) -nlHsLit :: HsLit p -> LHsExpr p -nlHsLit n = noLoc (HsLit n) +nlHsLit :: HsLit (GhcPass p) -> LHsExpr (GhcPass p) +nlHsLit n = noLoc (HsLit noExt n) nlHsIntLit :: Integer -> LHsExpr (GhcPass p) -nlHsIntLit n = noLoc (HsLit (HsInt noExt (mkIntegralLit n))) +nlHsIntLit n = noLoc (HsLit noExt (HsInt noExt (mkIntegralLit n))) nlVarPat :: IdP (GhcPass id) -> LPat (GhcPass id) nlVarPat n = noLoc (VarPat noExt (noLoc n)) @@ -398,10 +412,11 @@ nlVarPat n = noLoc (VarPat noExt (noLoc n)) nlLitPat :: HsLit GhcPs -> LPat GhcPs nlLitPat l = noLoc (LitPat noExt l) -nlHsApp :: LHsExpr id -> LHsExpr id -> LHsExpr id -nlHsApp f x = noLoc (HsApp f (mkLHsPar x)) +nlHsApp :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) +nlHsApp f x = noLoc (HsApp noExt f (mkLHsPar x)) -nlHsSyntaxApps :: SyntaxExpr id -> [LHsExpr id] -> LHsExpr id +nlHsSyntaxApps :: SyntaxExpr (GhcPass id) -> [LHsExpr (GhcPass id)] + -> LHsExpr (GhcPass id) nlHsSyntaxApps (SyntaxExpr { syn_expr = fun , syn_arg_wraps = arg_wraps , syn_res_wrap = res_wrap }) args @@ -413,13 +428,14 @@ nlHsSyntaxApps (SyntaxExpr { syn_expr = fun = mkLHsWrap res_wrap (foldl nlHsApp (noLoc fun) (zipWithEqual "nlHsSyntaxApps" mkLHsWrap arg_wraps args)) -nlHsApps :: IdP id -> [LHsExpr id] -> LHsExpr id +nlHsApps :: IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id) nlHsApps f xs = foldl nlHsApp (nlHsVar f) xs -nlHsVarApps :: IdP id -> [IdP id] -> LHsExpr id -nlHsVarApps f xs = noLoc (foldl mk (HsVar (noLoc f)) (map (HsVar . noLoc) xs)) +nlHsVarApps :: IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id) +nlHsVarApps f xs = noLoc (foldl mk (HsVar noExt (noLoc f)) + (map ((HsVar noExt) . noLoc) xs)) where - mk f a = HsApp (noLoc f) (noLoc a) + mk f a = HsApp noExt (noLoc f) (noLoc a) nlConVarPat :: RdrName -> [RdrName] -> LPat GhcPs nlConVarPat con vars = nlConPat con (map nlVarPat vars) @@ -457,26 +473,28 @@ nlHsDo :: HsStmtContext Name -> [LStmt GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs nlHsDo ctxt stmts = noLoc (mkHsDo ctxt stmts) -nlHsOpApp :: LHsExpr id -> IdP id -> LHsExpr id -> LHsExpr id +nlHsOpApp :: LHsExpr GhcPs -> IdP GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2) nlHsLam :: LMatch GhcPs (LHsExpr GhcPs) -> LHsExpr GhcPs -nlHsPar :: LHsExpr id -> LHsExpr id -nlHsIf :: LHsExpr id -> LHsExpr id -> LHsExpr id -> LHsExpr id +nlHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) +nlHsIf :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) + -> LHsExpr (GhcPass id) nlHsCase :: LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs nlList :: [LHsExpr GhcPs] -> LHsExpr GhcPs -nlHsLam match = noLoc (HsLam (mkMatchGroup Generated [match])) -nlHsPar e = noLoc (HsPar e) +nlHsLam match = noLoc (HsLam noExt (mkMatchGroup Generated [match])) +nlHsPar e = noLoc (HsPar noExt e) -- Note [Rebindable nlHsIf] -- nlHsIf should generate if-expressions which are NOT subject to -- RebindableSyntax, so the first field of HsIf is Nothing. (#12080) -nlHsIf cond true false = noLoc (HsIf Nothing cond true false) +nlHsIf cond true false = noLoc (HsIf noExt Nothing cond true false) -nlHsCase expr matches = noLoc (HsCase expr (mkMatchGroup Generated matches)) -nlList exprs = noLoc (ExplicitList placeHolderType Nothing exprs) +nlHsCase expr matches + = noLoc (HsCase noExt expr (mkMatchGroup Generated matches)) +nlList exprs = noLoc (ExplicitList noExt Nothing exprs) nlHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) nlHsTyVar :: IdP (GhcPass p) -> LHsType (GhcPass p) @@ -496,12 +514,12 @@ Tuples. All these functions are *pre-typechecker* because they lack types on the tuple. -} -mkLHsTupleExpr :: [LHsExpr a] -> LHsExpr a +mkLHsTupleExpr :: [LHsExpr (GhcPass a)] -> LHsExpr (GhcPass a) -- Makes a pre-typechecker boxed tuple, deals with 1 case mkLHsTupleExpr [e] = e -mkLHsTupleExpr es = noLoc $ ExplicitTuple (map (noLoc . Present) es) Boxed +mkLHsTupleExpr es = noLoc $ ExplicitTuple noExt (map (noLoc . Present) es) Boxed -mkLHsVarTuple :: [IdP a] -> LHsExpr a +mkLHsVarTuple :: [IdP (GhcPass a)] -> LHsExpr (GhcPass a) mkLHsVarTuple ids = mkLHsTupleExpr (map nlHsVar ids) nlTuplePat :: [LPat GhcPs] -> Boxity -> LPat GhcPs @@ -516,10 +534,10 @@ mkLHsPatTup [lpat] = lpat mkLHsPatTup lpats = L (getLoc (head lpats)) $ TuplePat noExt lpats Boxed -- The Big equivalents for the source tuple expressions -mkBigLHsVarTup :: [IdP id] -> LHsExpr id +mkBigLHsVarTup :: [IdP (GhcPass id)] -> LHsExpr (GhcPass id) mkBigLHsVarTup ids = mkBigLHsTup (map nlHsVar ids) -mkBigLHsTup :: [LHsExpr id] -> LHsExpr id +mkBigLHsTup :: [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id) mkBigLHsTup = mkChunkified mkLHsTupleExpr -- The Big equivalents for the source tuple patterns @@ -665,25 +683,25 @@ typeToLHsType ty * * ********************************************************************* -} -mkLHsWrap :: HsWrapper -> LHsExpr id -> LHsExpr id +mkLHsWrap :: HsWrapper -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e) -- Avoid (HsWrap co (HsWrap co' _)). -- See Note [Detecting forced eta expansion] in DsExpr -mkHsWrap :: HsWrapper -> HsExpr id -> HsExpr id +mkHsWrap :: HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id) mkHsWrap co_fn e | isIdHsWrapper co_fn = e -mkHsWrap co_fn (HsWrap co_fn' e) = mkHsWrap (co_fn <.> co_fn') e -mkHsWrap co_fn e = HsWrap co_fn e +mkHsWrap co_fn (HsWrap _ co_fn' e) = mkHsWrap (co_fn <.> co_fn') e +mkHsWrap co_fn e = HsWrap noExt co_fn e mkHsWrapCo :: TcCoercionN -- A Nominal coercion a ~N b - -> HsExpr id -> HsExpr id + -> HsExpr (GhcPass id) -> HsExpr (GhcPass id) mkHsWrapCo co e = mkHsWrap (mkWpCastN co) e mkHsWrapCoR :: TcCoercionR -- A Representational coercion a ~R b - -> HsExpr id -> HsExpr id + -> HsExpr (GhcPass id) -> HsExpr (GhcPass id) mkHsWrapCoR co e = mkHsWrap (mkWpCastR co) e -mkLHsWrapCo :: TcCoercionN -> LHsExpr id -> LHsExpr id +mkLHsWrapCo :: TcCoercionN -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) mkLHsWrapCo co (L loc e) = L loc (mkHsWrapCo co e) mkHsCmdWrap :: HsWrapper -> HsCmd id -> HsCmd id diff --git a/compiler/hsSyn/PlaceHolder.hs b/compiler/hsSyn/PlaceHolder.hs index 55778d9adf..19b4af017d 100644 --- a/compiler/hsSyn/PlaceHolder.hs +++ b/compiler/hsSyn/PlaceHolder.hs @@ -36,12 +36,6 @@ data PlaceHolder = PlaceHolder instance Outputable PlaceHolder where ppr _ = text "PlaceHolder" -placeHolderKind :: PlaceHolder -placeHolderKind = PlaceHolder - -placeHolderFixity :: PlaceHolder -placeHolderFixity = PlaceHolder - placeHolderType :: PlaceHolder placeHolderType = PlaceHolder |