From b71734ef7a8de2596fddc1efb785e7a42864dfc1 Mon Sep 17 00:00:00 2001 From: Vladislav Zavialov Date: Tue, 12 Feb 2019 13:22:35 +0300 Subject: Introduce ExpPatFrame --- compiler/ghc.cabal.in | 1 + compiler/hsSyn/HsUtils.hs | 5 +- compiler/parser/ExpPatFrame.hs | 340 +++++++++++++++++++++++++++++++++++++++++ compiler/parser/Parser.y | 311 ++++++++++++++++++------------------- compiler/parser/RdrHsSyn.hs | 307 +++++++++++++++++++------------------ 5 files changed, 646 insertions(+), 318 deletions(-) create mode 100644 compiler/parser/ExpPatFrame.hs diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index a02ce1297d..df5581c111 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -412,6 +412,7 @@ Library OptCoercion Parser RdrHsSyn + ExpPatFrame ApiAnnotation ForeignCall KnownUniques diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs index 23cca4c737..64bb37d2fc 100644 --- a/compiler/hsSyn/HsUtils.hs +++ b/compiler/hsSyn/HsUtils.hs @@ -33,7 +33,7 @@ module HsUtils( nlHsLit, nlHsApp, nlHsApps, nlHsSyntaxApps, nlHsIntLit, nlHsVarApps, nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList, - mkLHsTupleExpr, mkLHsVarTuple, missingTupArg, + mkLHsTupleExpr, mkLHsVarTuple, typeToLHsType, -- * Constructing general big tuples @@ -522,9 +522,6 @@ mkLHsVarTuple ids = mkLHsTupleExpr (map nlHsVar ids) nlTuplePat :: [LPat GhcPs] -> Boxity -> LPat GhcPs nlTuplePat pats box = noLoc (TuplePat noExt pats box) -missingTupArg :: HsTupArg GhcPs -missingTupArg = Missing noExt - mkLHsPatTup :: [LPat GhcRn] -> LPat GhcRn mkLHsPatTup [] = noLoc $ TuplePat noExt [] Boxed mkLHsPatTup [lpat] = lpat diff --git a/compiler/parser/ExpPatFrame.hs b/compiler/parser/ExpPatFrame.hs new file mode 100644 index 0000000000..e24cd560a2 --- /dev/null +++ b/compiler/parser/ExpPatFrame.hs @@ -0,0 +1,340 @@ +{-# LANGUAGE ViewPatterns #-} + +module ExpPatFrame ( + + -- * The expression/pattern frame + ExpPatFrame(..), + LExpPatFrame, + + -- * Tuple elements + TupArgFrame(..), + LTupArgFrame, + + -- * Record elements + FrameRecordBinds, + FrameRecUpdField, + LFrameRecUpdField, + + -- * Match elements + FrameMatch(..), + LFrameMatch, + FrameGRHSs(..), + FrameGRHS(..), + LFrameGRHS, + + -- * Statements + FrameStmt(..), + LFrameStmt, + + -- * Conversion + fromTupArgPresent, + checkExpr, + checkExprStmt, + checkExprMatch, + checkExprGRHSs, + checkExprGRHS, + + -- * Construction + unguardedFrameRHS + + ) where + +import GhcPrelude +import FastString +import Outputable +import SrcLoc +import Name +import RdrName +import BasicTypes +import HsSyn + +type LExpPatFrame = Located ExpPatFrame + +{- + +There are places in the grammar where we do not know whether we are parsing an +expression or a pattern without infinite lookahead (which we do not have in +'happy'): + +1. View patterns: + f (Con a b ) = ... -- 'Con a b' is a pattern + f (Con a b -> x) = ... -- 'Con a b' is an expression + +2. do-notation: + do { Con a b <- x } -- 'Con a b' is a pattern + do { Con a b } -- 'Con a b' is an expression + +3. Guards: + x | True <- p && q = ... -- 'True' is a pattern + x | True = ... -- 'True' is an expression + +4. Top-level value/function declarations (FunBind/PatBind): + f !a -- TH splice + f !a = ... -- function declaration + Until we encounter the = sign, we don't know if it's a top-level + TemplateHaskell splice where ! is an infix operator, or if it's a function + declaration where ! is a strictness annotation. + +An ExpPatFrame (expression/pattern frame) is an intermediate data structure for +parsing expressions and patterns. We convert to HsExpr or HsPat when we can +resolve the ambiguity. + +See https://ghc.haskell.org/trac/ghc/wiki/Design/ExpPatFrame for details. + +-} +data ExpPatFrame + = FrameVar RdrName + -- ^ Identifier: Just, map, BS.length + | FrameIPVar HsIPName + -- ^ Implicit parameter: ?x + | FrameOverLabel FastString + -- ^ Overloaded label: #label + | FrameLit (HsLit GhcPs) + -- ^ Non-overloaded literal: 'c', "str" + | FrameOverLit (HsOverLit GhcPs) + -- ^ Overloaded literal: 15, 2.4 + | FramePar LExpPatFrame + -- ^ Parentheses + | FrameSum ConTag Arity LExpPatFrame + -- ^ Sum: (a||), (|a|), (||a) + | FrameTuple [LTupArgFrame] Boxity + -- ^ Tuple (section): (a,b) (a,b,c) (a,,) (,a,) + | FrameList [LExpPatFrame] + -- ^ List: [1, 2, 3] + | FrameComp (HsStmtContext Name) [LFrameStmt] LExpPatFrame + -- ^ List/monad comprehension: [ a | x <- f n, p, q ] + | FrameArithSeq (ArithSeqInfo GhcPs) + -- ^ Arithmetic sequence: [1..], [1,2..], [1..5] + | FrameWild + -- ^ Wildcard: _ + | FrameSplice (HsSplice GhcPs) + -- ^ TH splice: $a, $(expr), $$(expr), [quasi| ... |] + | FrameBracket (HsBracket GhcPs) + -- ^ TH bracket: [|expr|], [p|pat|], 'x, ''T + | FrameArrForm LExpPatFrame [LHsCmdTop GhcPs] + -- ^ Command formation (arrows): (| e cmd1 cmd2 cmd3 |) + | FrameRecordUpd LExpPatFrame [LFrameRecUpdField] + -- ^ Record update: (f x) { a = z } + | FrameRecordCon (Located RdrName) FrameRecordBinds + -- ^ Record constructor: D { x, y = f t, .. } + | FrameAsPat (Located RdrName) LExpPatFrame + -- ^ As-pattern: x@(D a b) + | FrameLam [LPat GhcPs] LExpPatFrame + -- ^ Lambda-expression: \x -> e + | FrameLet (LHsLocalBinds GhcPs) LExpPatFrame + -- ^ Let-expression: let p = t in e + | FrameLamCase [LFrameMatch] + -- ^ Lambda-expression: \x -> e + | FrameIf LExpPatFrame LExpPatFrame LExpPatFrame + -- ^ If-expression: if p then x else y + | FrameMultiIf [LFrameGRHS] + -- ^ Multi-way if-expression: if | p = x \n | q = x + | FrameCase LExpPatFrame [LFrameMatch] + -- ^ Case-expression: case x of { p1 -> e1; p2 -> e2 } + | FrameDo (HsStmtContext Name) [LFrameStmt] + -- ^ Do-expression: do { s1; a <- s2; s3 } + | FrameProc (LPat GhcPs) (LHsCmdTop GhcPs) + -- ^ Proc-expression: proc p -> cmd + | FrameViewPat LExpPatFrame LExpPatFrame + -- ^ View pattern: e -> p + | FrameTySig LExpPatFrame (LHsSigWcType GhcPs) + -- ^ Type signature: x :: ty + | FrameArrApp LExpPatFrame LExpPatFrame HsArrAppType Bool + -- ^ Arrow application: f -< arg, f -<< arg, arg >- f, arg >>- f + | FrameSCC SourceText StringLiteral LExpPatFrame + -- ^ SCC annotation: {-# SCC .. #-} e + | FrameTickPragma + SourceText + (StringLiteral,(Int,Int),(Int,Int)) + ((SourceText,SourceText),(SourceText,SourceText)) + LExpPatFrame + -- ^ Tick pragma: {-# GENERATED .. #-} e + | FrameCoreAnn SourceText StringLiteral LExpPatFrame + -- ^ Core annotation: {-# CORE .. #-} e + | FrameApp LExpPatFrame LExpPatFrame + -- ^ Function application: f a + | FrameAppType LExpPatFrame (LHsWcType GhcPs) + -- ^ Visible type application: f @t + | FrameOpApp LExpPatFrame LExpPatFrame LExpPatFrame + -- ^ Operator application: x # y + | FrameSectionL LExpPatFrame LExpPatFrame + -- ^ Left section: (x #) + | FrameSectionR LExpPatFrame LExpPatFrame + -- ^ Right section: (# y) + | FrameNegApp LExpPatFrame + -- ^ Prefix negation: -a + | FrameLazyPat LExpPatFrame + -- ^ Lazy pattern: ~a + | FrameStatic LExpPatFrame + -- ^ Static expression: static e + +instance Outputable ExpPatFrame where + ppr = ppr . unLoc . checkExpr . noLoc + +type FrameRecordBinds = HsRecFields GhcPs LExpPatFrame +type FrameRecUpdField = HsRecField' (AmbiguousFieldOcc GhcPs) LExpPatFrame +type LFrameRecUpdField = Located FrameRecUpdField + +type LTupArgFrame = Located TupArgFrame + +data TupArgFrame + = TupArgFramePresent LExpPatFrame + | TupArgFrameMissing + +fromTupArgPresent :: TupArgFrame -> Maybe LExpPatFrame +fromTupArgPresent (TupArgFramePresent e) = Just e +fromTupArgPresent TupArgFrameMissing = Nothing + +type LFrameMatch = Located FrameMatch + +data FrameMatch = + FrameMatch (HsMatchContext RdrName) [LPat GhcPs] FrameGRHSs + +type LFrameStmt = Located FrameStmt + +data FrameGRHSs = + FrameGRHSs [LFrameGRHS] (LHsLocalBinds GhcPs) + +type LFrameGRHS = Located FrameGRHS + +data FrameGRHS = FrameGRHS [GuardLStmt GhcPs] LExpPatFrame + +data FrameStmt + = FrameTransformStmt [LFrameStmt] LExpPatFrame + -- ^ TransformListComp statement: then f + | FrameTransformByStmt [LFrameStmt] LExpPatFrame LExpPatFrame + -- ^ TransformListComp statement: then f by e + | FrameGroupUsingStmt [LFrameStmt] LExpPatFrame + -- ^ TransformListComp statement: then group using f + | FrameGroupByUsingStmt [LFrameStmt] LExpPatFrame LExpPatFrame + -- ^ TransformListComp statement: then group by e using f + | FrameBindStmt (LPat GhcPs) LExpPatFrame + -- ^ Binding statement: p <- e + | FrameBodyStmt LExpPatFrame + -- ^ Body statement: e + | FrameLetStmt (LHsLocalBinds GhcPs) + -- ^ Let statement: let p = t + | FrameRecStmt [LFrameStmt] + -- ^ Rec statement: rec { s1; s2; ... } + | FrameParStmt [[LFrameStmt]] + -- ^ Parallel statement: s1 | s2 + +instance Outputable FrameStmt where + ppr = ppr . unLoc . checkExprStmt . noLoc + +{- + +Convert an expression/pattern frame to an expression. In the future, this +function will perform validation and reject FrameAsPat, FrameViewPat, +FrameLazyPat, and so on: + + checkExpr :: LExpPatFrame -> P (LHsExpr GhcPs) + +-} +checkExpr :: LExpPatFrame -> LHsExpr GhcPs +checkExpr (dL->L l epf) = cL l $ case epf of + FrameVar name -> HsVar noExt (cL l name) + FrameIPVar ipname -> HsIPVar noExt ipname + FrameOverLabel str -> HsOverLabel noExt Nothing str + FrameLit lit -> HsLit noExt lit + FrameOverLit lit -> HsOverLit noExt lit + FramePar e -> HsPar noExt (checkExpr e) + FrameSum alt arity e -> ExplicitSum noExt alt arity (checkExpr e) + FrameTuple args boxity -> + ExplicitTuple noExt (map checkExprTupArg args) boxity + FrameList xs -> ExplicitList noExt Nothing (map checkExpr xs) + FrameComp ctxt quals e -> + mkHsComp ctxt (map checkExprStmt quals) (checkExpr e) + FrameArithSeq a -> ArithSeq noExt Nothing a + FrameWild -> EWildPat noExt + FrameSplice splice -> HsSpliceE noExt splice + FrameBracket br -> HsBracket noExt br + FrameArrForm op cmds -> HsArrForm noExt (checkExpr op) Nothing cmds + FrameRecordUpd exp flds -> + RecordUpd noExt (checkExpr exp) ((fmap.fmap.fmap) checkExpr flds) + FrameRecordCon con flds -> RecordCon noExt con (fmap checkExpr flds) + FrameAsPat v e -> EAsPat noExt v (checkExpr e) + FrameLam ps e -> + HsLam noExt $ + mkMatchGroup FromSource + [cL l $ Match { m_ext = noExt + , m_ctxt = LambdaExpr + , m_pats = ps + , m_grhss = unguardedGRHSs (checkExpr e) }] + FrameLet binds expr -> HsLet noExt binds (checkExpr expr) + FrameLamCase matches -> + HsLamCase noExt $ + mkMatchGroup FromSource (map checkExprMatch matches) + FrameIf c a b -> mkHsIf (checkExpr c) (checkExpr a) (checkExpr b) + FrameMultiIf alts -> HsMultiIf noExt (map checkExprGRHS alts) + FrameCase scrut matches -> + HsCase noExt (checkExpr scrut) $ + mkMatchGroup FromSource (map checkExprMatch matches) + FrameDo ctxt stmts -> mkHsDo ctxt (map checkExprStmt stmts) + FrameProc pat cmd -> HsProc noExt pat cmd + FrameViewPat p e -> EViewPat noExt (checkExpr p) (checkExpr e) + FrameTySig e sig -> ExprWithTySig noExt (checkExpr e) sig + FrameArrApp f a haat b -> + HsArrApp noExt (checkExpr f) (checkExpr a) haat b + FrameSCC src lbl e -> HsSCC noExt src lbl (checkExpr e) + FrameTickPragma src info srcInfo e -> + HsTickPragma noExt src info srcInfo (checkExpr e) + FrameCoreAnn src lbl e -> HsCoreAnn noExt src lbl (checkExpr e) + FrameApp f a -> HsApp noExt (checkExpr f) (checkExpr a) + FrameAppType f t -> HsAppType noExt (checkExpr f) t + FrameOpApp e1 op e2 -> + OpApp noExt (checkExpr e1) (checkExpr op) (checkExpr e2) + FrameSectionL e1 op -> SectionL noExt (checkExpr e1) (checkExpr op) + FrameSectionR op e2 -> SectionR noExt (checkExpr op) (checkExpr e2) + FrameNegApp e -> NegApp noExt (checkExpr e) noSyntaxExpr + FrameLazyPat p -> ELazyPat noExt (checkExpr p) + FrameStatic e -> HsStatic noExt (checkExpr e) + +checkExprTupArg :: LTupArgFrame -> LHsTupArg GhcPs +checkExprTupArg = mapLoc go + where + go (TupArgFramePresent e) = Present noExt (checkExpr e) + go TupArgFrameMissing = Missing noExt + +checkExprStmt :: LFrameStmt -> LStmt GhcPs (LHsExpr GhcPs) +checkExprStmt (dL->L l stmt) = cL l $ case stmt of + FrameTransformStmt ss f -> + mkTransformStmt (map checkExprStmt ss) (checkExpr f) + FrameTransformByStmt ss f e -> + mkTransformByStmt (map checkExprStmt ss) (checkExpr f) (checkExpr e) + FrameGroupUsingStmt ss f -> + mkGroupUsingStmt (map checkExprStmt ss) (checkExpr f) + FrameGroupByUsingStmt ss e f -> + mkGroupByUsingStmt (map checkExprStmt ss) (checkExpr e) (checkExpr f) + FrameBindStmt p e -> mkBindStmt p (checkExpr e) + FrameBodyStmt e -> mkBodyStmt (checkExpr e) + FrameLetStmt binds -> LetStmt noExt binds + FrameRecStmt ss -> mkRecStmt (map checkExprStmt ss) + FrameParStmt qss -> + ParStmt noExt + [ParStmtBlock noExt (map checkExprStmt qs) [] noSyntaxExpr + | qs <- qss] + noExpr + noSyntaxExpr + +checkExprMatch :: LFrameMatch -> LMatch GhcPs (LHsExpr GhcPs) +checkExprMatch (dL->L l match) = cL l $ + let FrameMatch ctxt pats grhss = match in + Match { m_ext = NoExt, + m_ctxt = ctxt, + m_pats = pats, + m_grhss = checkExprGRHSs grhss } + +checkExprGRHSs :: FrameGRHSs -> GRHSs GhcPs (LHsExpr GhcPs) +checkExprGRHSs (FrameGRHSs grhss binds) = + GRHSs { grhssExt = noExt + , grhssGRHSs = map checkExprGRHS grhss + , grhssLocalBinds = binds } + +checkExprGRHS :: LFrameGRHS -> LGRHS GhcPs (LHsExpr GhcPs) +checkExprGRHS (dL->L l grhs) = cL l $ + let FrameGRHS guards rhs = grhs in + GRHS noExt guards (checkExpr rhs) + +unguardedFrameRHS :: SrcSpan -> LExpPatFrame -> [LFrameGRHS] +unguardedFrameRHS loc rhs = [cL loc (FrameGRHS [] rhs)] diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index 820144d930..c331db7b8a 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -1060,7 +1060,7 @@ topdecl :: { LHsDecl GhcPs } -- The $(..) form is one possible form of infixexp -- but we treat an arbitrary expression just as if -- it had a $(..) wrapped around it - | infixexp_top { sLL $1 $> $ mkSpliceDecl $1 } + | infixexp_top { sLL $1 $> $ mkSpliceDecl (checkExpr $1) } -- Type classes -- @@ -1648,7 +1648,7 @@ rule :: { LRuleDecl GhcPs } , rd_name = cL (gl $1) (getSTRINGs $1, getSTRING $1) , rd_act = (snd $2) `orElse` AlwaysActive , rd_tyvs = sndOf3 $3, rd_tmvs = thdOf3 $3 - , rd_lhs = $4, rd_rhs = $6 }) + , rd_lhs = checkExpr $4, rd_rhs = checkExpr $6 }) (mj AnnEqual $5 : (fst $2) ++ (fstOf3 $3)) } -- Rules can be specified to be NeverActive, unlike inline/specialize pragmas @@ -1755,17 +1755,17 @@ stringlist :: { Located (OrdList (Located StringLiteral)) } annotation :: { LHsDecl GhcPs } : '{-# ANN' name_var aexp '#-}' {% ams (sLL $1 $> (AnnD noExt $ HsAnnotation noExt (getANN_PRAGs $1) - (ValueAnnProvenance $2) $3)) + (ValueAnnProvenance $2) (checkExpr $3))) [mo $1,mc $4] } | '{-# ANN' 'type' tycon aexp '#-}' {% ams (sLL $1 $> (AnnD noExt $ HsAnnotation noExt (getANN_PRAGs $1) - (TypeAnnProvenance $3) $4)) + (TypeAnnProvenance $3) (checkExpr $4))) [mo $1,mj AnnType $2,mc $5] } | '{-# ANN' 'module' aexp '#-}' {% ams (sLL $1 $> (AnnD noExt $ HsAnnotation noExt (getANN_PRAGs $1) - ModuleAnnProvenance $3)) + ModuleAnnProvenance (checkExpr $3))) [mo $1,mj AnnModule $2,mc $4] } @@ -2373,7 +2373,7 @@ docdecld :: { LDocDecl } decl_no_th :: { LHsDecl GhcPs } : sigdecl { $1 } - | '!' aexp rhs {% do { let { e = sLL $1 $2 (SectionR noExt (sL1 $1 (HsVar noExt (sL1 $1 bang_RDR))) $2) + | '!' aexp rhs {% do { let { e = sLL $1 $2 (FrameSectionR (sL1 $1 (FrameVar bang_RDR)) $2) ; l = comb2 $1 $> }; (ann, r) <- checkValDef empty SrcStrict e Nothing $3 ; hintBangPat (comb2 $1 $2) (unLoc e) ; @@ -2410,23 +2410,23 @@ decl :: { LHsDecl GhcPs } -- Why do we only allow naked declaration splices in top-level -- declarations and not here? Short answer: because readFail009 -- fails terribly with a panic in cvBindsAndSigs otherwise. - | splice_exp { sLL $1 $> $ mkSpliceDecl $1 } + | splice_exp { sLL $1 $> $ mkSpliceDecl (checkExpr $1) } -rhs :: { Located ([AddAnn],GRHSs GhcPs (LHsExpr GhcPs)) } +rhs :: { Located ([AddAnn],FrameGRHSs) } : '=' exp wherebinds { sL (comb3 $1 $2 $3) ((mj AnnEqual $1 : (fst $ unLoc $3)) - ,GRHSs noExt (unguardedRHS (comb3 $1 $2 $3) $2) + ,FrameGRHSs (unguardedFrameRHS (comb3 $1 $2 $3) $2) (snd $ unLoc $3)) } | gdrhs wherebinds { sLL $1 $> (fst $ unLoc $2 - ,GRHSs noExt (reverse (unLoc $1)) + ,FrameGRHSs (reverse (unLoc $1)) (snd $ unLoc $2)) } -gdrhs :: { Located [LGRHS GhcPs (LHsExpr GhcPs)] } +gdrhs :: { Located [LFrameGRHS] } : gdrhs gdrh { sLL $1 $> ($2 : unLoc $1) } | gdrh { sL1 $1 [$1] } -gdrh :: { LGRHS GhcPs (LHsExpr GhcPs) } - : '|' guardquals '=' exp {% ams (sL (comb2 $1 $>) $ GRHS noExt (unLoc $2) $4) +gdrh :: { LFrameGRHS } + : '|' guardquals '=' exp {% ams (sL (comb2 $1 $>) $ FrameGRHS (unLoc $2) $4) [mj AnnVbar $1,mj AnnEqual $3] } sigdecl :: { LHsDecl GhcPs } @@ -2525,59 +2525,59 @@ quasiquote :: { Located (HsSplice GhcPs) } ; quoterId = mkQual varName (qual, quoter) } in sL (getLoc $1) (mkHsQuasiQuote quoterId (RealSrcSpan quoteSpan) quote) } -exp :: { LHsExpr GhcPs } - : infixexp '::' sigtype {% ams (sLL $1 $> $ ExprWithTySig noExt $1 (mkLHsSigWcType $3)) +exp :: { LExpPatFrame } + : infixexp '::' sigtype {% ams (sLL $1 $> $ FrameTySig $1 (mkLHsSigWcType $3)) [mu AnnDcolon $2] } - | infixexp '-<' exp {% ams (sLL $1 $> $ HsArrApp noExt $1 $3 + | infixexp '-<' exp {% ams (sLL $1 $> $ FrameArrApp $1 $3 HsFirstOrderApp True) [mu Annlarrowtail $2] } - | infixexp '>-' exp {% ams (sLL $1 $> $ HsArrApp noExt $3 $1 + | infixexp '>-' exp {% ams (sLL $1 $> $ FrameArrApp $3 $1 HsFirstOrderApp False) [mu Annrarrowtail $2] } - | infixexp '-<<' exp {% ams (sLL $1 $> $ HsArrApp noExt $1 $3 + | infixexp '-<<' exp {% ams (sLL $1 $> $ FrameArrApp $1 $3 HsHigherOrderApp True) [mu AnnLarrowtail $2] } - | infixexp '>>-' exp {% ams (sLL $1 $> $ HsArrApp noExt $3 $1 + | infixexp '>>-' exp {% ams (sLL $1 $> $ FrameArrApp $3 $1 HsHigherOrderApp False) [mu AnnRarrowtail $2] } | infixexp { $1 } -infixexp :: { LHsExpr GhcPs } +infixexp :: { LExpPatFrame } : exp10 { $1 } - | infixexp qop exp10 {% ams (sLL $1 $> (OpApp noExt $1 $2 $3)) + | infixexp qop exp10 {% ams (sLL $1 $> (FrameOpApp $1 $2 $3)) [mj AnnVal $2] } -- AnnVal annotation for NPlusKPat, which discards the operator -infixexp_top :: { LHsExpr GhcPs } +infixexp_top :: { LExpPatFrame } : exp10_top { $1 } | infixexp_top qop exp10_top {% do { when (srcSpanEnd (getLoc $2) == srcSpanStart (getLoc $3) && checkIfBang $2) $ warnSpaceAfterBang (comb2 $2 $3); - ams (sLL $1 $> (OpApp noExt $1 $2 $3)) + ams (sLL $1 $> (FrameOpApp $1 $2 $3)) [mj AnnVal $2] } } -exp10_top :: { LHsExpr GhcPs } - : '-' fexp {% ams (sLL $1 $> $ NegApp noExt $2 noSyntaxExpr) +exp10_top :: { LExpPatFrame } + : '-' fexp {% ams (sLL $1 $> $ FrameNegApp $2) [mj AnnMinus $1] } - | hpc_annot exp {% ams (sLL $1 $> $ HsTickPragma noExt (snd $ fst $ fst $ unLoc $1) + | hpc_annot exp {% ams (sLL $1 $> $ FrameTickPragma (snd $ fst $ fst $ unLoc $1) (snd $ fst $ unLoc $1) (snd $ unLoc $1) $2) (fst $ fst $ fst $ unLoc $1) } - | '{-# CORE' STRING '#-}' exp {% ams (sLL $1 $> $ HsCoreAnn noExt (getCORE_PRAGs $1) (getStringLiteral $2) $4) + | '{-# CORE' STRING '#-}' exp {% ams (sLL $1 $> $ FrameCoreAnn (getCORE_PRAGs $1) (getStringLiteral $2) $4) [mo $1,mj AnnVal $2 ,mc $3] } -- hdaume: core annotation | fexp { $1 } -exp10 :: { LHsExpr GhcPs } +exp10 :: { LExpPatFrame } : exp10_top { $1 } - | scc_annot exp {% ams (sLL $1 $> $ HsSCC noExt (snd $ fst $ unLoc $1) (snd $ unLoc $1) $2) + | scc_annot exp {% ams (sLL $1 $> $ FrameSCC (snd $ fst $ unLoc $1) (snd $ unLoc $1) $2) (fst $ fst $ unLoc $1) } optSemi :: { ([Located Token],Bool) } @@ -2619,141 +2619,134 @@ hpc_annot :: { Located ( (([AddAnn],SourceText),(StringLiteral,(Int,Int),(Int,In ))) } -fexp :: { LHsExpr GhcPs } +fexp :: { LExpPatFrame } : fexp aexp {% checkBlockArguments $1 >> checkBlockArguments $2 >> - return (sLL $1 $> $ (HsApp noExt $1 $2)) } + return (sLL $1 $> $ (FrameApp $1 $2)) } | fexp TYPEAPP atype {% checkBlockArguments $1 >> - ams (sLL $1 $> $ HsAppType noExt $1 (mkHsWildCardBndrs $3)) + ams (sLL $1 $> $ FrameAppType $1 (mkHsWildCardBndrs $3)) [mj AnnAt $2] } - | 'static' aexp {% ams (sLL $1 $> $ HsStatic noExt $2) + | 'static' aexp {% ams (sLL $1 $> $ FrameStatic $2) [mj AnnStatic $1] } | aexp { $1 } -aexp :: { LHsExpr GhcPs } - : qvar '@' aexp {% ams (sLL $1 $> $ EAsPat noExt $1 $3) [mj AnnAt $2] } +aexp :: { LExpPatFrame } + : qvar '@' aexp {% ams (sLL $1 $> $ FrameAsPat $1 $3) [mj AnnAt $2] } -- If you change the parsing, make sure to understand -- Note [Lexing type applications] in Lexer.x - | '~' aexp {% ams (sLL $1 $> $ ELazyPat noExt $2) [mj AnnTilde $1] } + | '~' aexp {% ams (sLL $1 $> $ FrameLazyPat $2) [mj AnnTilde $1] } | '\\' apat apats '->' exp - {% ams (sLL $1 $> $ HsLam noExt (mkMatchGroup FromSource - [sLL $1 $> $ Match { m_ext = noExt - , m_ctxt = LambdaExpr - , m_pats = $2:$3 - , m_grhss = unguardedGRHSs $5 }])) + {% ams (sLL $1 $> $ FrameLam ($2:$3) $5) [mj AnnLam $1, mu AnnRarrow $4] } - | 'let' binds 'in' exp {% ams (sLL $1 $> $ HsLet noExt (snd $ unLoc $2) $4) + | 'let' binds 'in' exp {% ams (sLL $1 $> $ FrameLet (snd $ unLoc $2) $4) (mj AnnLet $1:mj AnnIn $3 :(fst $ unLoc $2)) } | '\\' 'lcase' altslist - {% ams (sLL $1 $> $ HsLamCase noExt - (mkMatchGroup FromSource (snd $ unLoc $3))) + {% ams (sLL $1 $> $ FrameLamCase (snd $ unLoc $3)) (mj AnnLam $1:mj AnnCase $2:(fst $ unLoc $3)) } | 'if' exp optSemi 'then' exp optSemi 'else' exp {% checkDoAndIfThenElse $2 (snd $3) $5 (snd $6) $8 >> - ams (sLL $1 $> $ mkHsIf $2 $5 $8) + ams (sLL $1 $> $ FrameIf $2 $5 $8) (mj AnnIf $1:mj AnnThen $4 :mj AnnElse $7 :(map (\l -> mj AnnSemi l) (fst $3)) ++(map (\l -> mj AnnSemi l) (fst $6))) } | 'if' ifgdpats {% hintMultiWayIf (getLoc $1) >> - ams (sLL $1 $> $ HsMultiIf noExt + ams (sLL $1 $> $ FrameMultiIf (reverse $ snd $ unLoc $2)) (mj AnnIf $1:(fst $ unLoc $2)) } | 'case' exp 'of' altslist {% ams (cL (comb3 $1 $3 $4) $ - HsCase noExt $2 (mkMatchGroup - FromSource (snd $ unLoc $4))) + FrameCase $2 (snd $ unLoc $4)) (mj AnnCase $1:mj AnnOf $3 :(fst $ unLoc $4)) } | 'do' stmtlist {% ams (cL (comb2 $1 $2) - (mkHsDo DoExpr (snd $ unLoc $2))) + (FrameDo DoExpr (snd $ unLoc $2))) (mj AnnDo $1:(fst $ unLoc $2)) } | 'mdo' stmtlist {% ams (cL (comb2 $1 $2) - (mkHsDo MDoExpr (snd $ unLoc $2))) + (FrameDo MDoExpr (snd $ unLoc $2))) (mj AnnMdo $1:(fst $ unLoc $2)) } | 'proc' aexp '->' exp {% checkPattern empty $2 >>= \ p -> checkCommand $4 >>= \ cmd -> - ams (sLL $1 $> $ HsProc noExt p (sLL $1 $> $ HsCmdTop noExt cmd)) + ams (sLL $1 $> $ FrameProc p (sLL $1 $> $ HsCmdTop noExt cmd)) -- TODO: is LL right here? [mj AnnProc $1,mu AnnRarrow $3] } | aexp1 { $1 } -aexp1 :: { LHsExpr GhcPs } +aexp1 :: { LExpPatFrame } : aexp1 '{' fbinds '}' {% do { r <- mkRecConstrOrUpdate $1 (comb2 $2 $4) (snd $3) ; _ <- amsL (comb2 $1 $>) (moc $2:mcc $4:(fst $3)) ; checkRecordSyntax (sLL $1 $> r) }} | aexp2 { $1 } -aexp2 :: { LHsExpr GhcPs } - : qvar { sL1 $1 (HsVar noExt $! $1) } - | qcon { sL1 $1 (HsVar noExt $! $1) } - | ipvar { sL1 $1 (HsIPVar noExt $! unLoc $1) } - | overloaded_label { sL1 $1 (HsOverLabel noExt Nothing $! unLoc $1) } - | literal { sL1 $1 (HsLit noExt $! unLoc $1) } +aexp2 :: { LExpPatFrame } + : qvar { sL1 $1 (FrameVar $! unLoc $1) } + | qcon { sL1 $1 (FrameVar $! unLoc $1) } + | ipvar { sL1 $1 (FrameIPVar $! unLoc $1) } + | overloaded_label { sL1 $1 (FrameOverLabel $! unLoc $1) } + | literal { sL1 $1 (FrameLit $! unLoc $1) } -- This will enable overloaded strings permanently. Normally the renamer turns HsString -- into HsOverLit when -foverloaded-strings is on. --- | STRING { sL (getLoc $1) (HsOverLit $! mkHsIsString (getSTRINGs $1) +-- | STRING { sL (getLoc $1) (FrameOverLit $! mkHsIsString (getSTRINGs $1) -- (getSTRING $1) noExt) } - | INTEGER { sL (getLoc $1) (HsOverLit noExt $! mkHsIntegral (getINTEGER $1) ) } - | RATIONAL { sL (getLoc $1) (HsOverLit noExt $! mkHsFractional (getRATIONAL $1) ) } + | INTEGER { sL (getLoc $1) (FrameOverLit $! mkHsIntegral (getINTEGER $1) ) } + | RATIONAL { sL (getLoc $1) (FrameOverLit $! mkHsFractional (getRATIONAL $1) ) } -- N.B.: sections get parsed by these next two productions. -- This allows you to write, e.g., '(+ 3, 4 -)', which isn't -- correct Haskell (you'd have to write '((+ 3), (4 -))') -- but the less cluttered version fell out of having texps. - | '(' texp ')' {% ams (sLL $1 $> (HsPar noExt $2)) [mop $1,mcp $3] } + | '(' texp ')' {% ams (sLL $1 $> (FramePar $2)) [mop $1,mcp $3] } | '(' tup_exprs ')' {% do { e <- mkSumOrTuple Boxed (comb2 $1 $3) (snd $2) ; ams (sLL $1 $> e) ((mop $1:fst $2) ++ [mcp $3]) } } - | '(#' texp '#)' {% ams (sLL $1 $> (ExplicitTuple noExt [cL (gl $2) - (Present noExt $2)] Unboxed)) + | '(#' texp '#)' {% ams (sLL $1 $> (FrameTuple [cL (gl $2) + (TupArgFramePresent $2)] Unboxed)) [mo $1,mc $3] } | '(#' tup_exprs '#)' {% do { e <- mkSumOrTuple Unboxed (comb2 $1 $3) (snd $2) ; ams (sLL $1 $> e) ((mo $1:fst $2) ++ [mc $3]) } } | '[' list ']' {% ams (sLL $1 $> (snd $2)) (mos $1:mcs $3:(fst $2)) } - | '_' { sL1 $1 $ EWildPat noExt } + | '_' { sL1 $1 FrameWild } -- Template Haskell Extension | splice_exp { $1 } - | SIMPLEQUOTE qvar {% ams (sLL $1 $> $ HsBracket noExt (VarBr noExt True (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] } - | SIMPLEQUOTE qcon {% ams (sLL $1 $> $ HsBracket noExt (VarBr noExt True (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] } - | TH_TY_QUOTE tyvar {% ams (sLL $1 $> $ HsBracket noExt (VarBr noExt False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] } - | TH_TY_QUOTE gtycon {% ams (sLL $1 $> $ HsBracket noExt (VarBr noExt False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] } + | SIMPLEQUOTE qvar {% ams (sLL $1 $> $ FrameBracket (VarBr noExt True (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] } + | SIMPLEQUOTE qcon {% ams (sLL $1 $> $ FrameBracket (VarBr noExt True (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] } + | TH_TY_QUOTE tyvar {% ams (sLL $1 $> $ FrameBracket (VarBr noExt False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] } + | TH_TY_QUOTE gtycon {% ams (sLL $1 $> $ FrameBracket (VarBr noExt False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] } | TH_TY_QUOTE {- nothing -} {% reportEmptyDoubleQuotes (getLoc $1) } - | '[|' exp '|]' {% ams (sLL $1 $> $ HsBracket noExt (ExpBr noExt $2)) + | '[|' exp '|]' {% ams (sLL $1 $> $ FrameBracket (ExpBr noExt (checkExpr $2))) (if (hasE $1) then [mj AnnOpenE $1, mu AnnCloseQ $3] else [mu AnnOpenEQ $1,mu AnnCloseQ $3]) } - | '[||' exp '||]' {% ams (sLL $1 $> $ HsBracket noExt (TExpBr noExt $2)) + | '[||' exp '||]' {% ams (sLL $1 $> $ FrameBracket (TExpBr noExt (checkExpr $2))) (if (hasE $1) then [mj AnnOpenE $1,mc $3] else [mo $1,mc $3]) } - | '[t|' ktype '|]' {% ams (sLL $1 $> $ HsBracket noExt (TypBr noExt $2)) [mo $1,mu AnnCloseQ $3] } + | '[t|' ktype '|]' {% ams (sLL $1 $> $ FrameBracket (TypBr noExt $2)) [mo $1,mu AnnCloseQ $3] } | '[p|' infixexp '|]' {% checkPattern empty $2 >>= \p -> - ams (sLL $1 $> $ HsBracket noExt (PatBr noExt p)) + ams (sLL $1 $> $ FrameBracket (PatBr noExt p)) [mo $1,mu AnnCloseQ $3] } - | '[d|' cvtopbody '|]' {% ams (sLL $1 $> $ HsBracket noExt (DecBrL noExt (snd $2))) + | '[d|' cvtopbody '|]' {% ams (sLL $1 $> $ FrameBracket (DecBrL noExt (snd $2))) (mo $1:mu AnnCloseQ $3:fst $2) } - | quasiquote { sL1 $1 (HsSpliceE noExt (unLoc $1)) } + | quasiquote { mapLoc FrameSplice $1 } -- arrow notation extension - | '(|' aexp2 cmdargs '|)' {% ams (sLL $1 $> $ HsArrForm noExt $2 - Nothing (reverse $3)) + | '(|' aexp2 cmdargs '|)' {% ams (sLL $1 $> $ FrameArrForm $2 (reverse $3)) [mu AnnOpenB $1,mu AnnCloseB $4] } -splice_exp :: { LHsExpr GhcPs } - : splice_untyped { mapLoc (HsSpliceE noExt) $1 } - | splice_typed { mapLoc (HsSpliceE noExt) $1 } +splice_exp :: { LExpPatFrame } + : splice_untyped { mapLoc FrameSplice $1 } + | splice_typed { mapLoc FrameSplice $1 } splice_untyped :: { Located (HsSplice GhcPs) } : TH_ID_SPLICE {% ams (sL1 $1 $ mkUntypedSplice HasDollar (sL1 $1 $ HsVar noExt (sL1 $1 (mkUnqual varName (getTH_ID_SPLICE $1))))) [mj AnnThIdSplice $1] } - | '$(' exp ')' {% ams (sLL $1 $> $ mkUntypedSplice HasParens $2) + | '$(' exp ')' {% ams (sLL $1 $> $ mkUntypedSplice HasParens (checkExpr $2)) [mj AnnOpenPE $1,mj AnnCloseP $3] } splice_typed :: { Located (HsSplice GhcPs) } @@ -2761,7 +2754,7 @@ splice_typed :: { Located (HsSplice GhcPs) } (sL1 $1 $ HsVar noExt (sL1 $1 (mkUnqual varName (getTH_ID_TY_SPLICE $1))))) [mj AnnThIdTySplice $1] } - | '$$(' exp ')' {% ams (sLL $1 $> $ mkTypedSplice HasParens $2) + | '$$(' exp ')' {% ams (sLL $1 $> $ mkTypedSplice HasParens (checkExpr $2)) [mj AnnOpenPTE $1,mj AnnCloseP $3] } cmdargs :: { [LHsCmdTop GhcPs] } @@ -2787,7 +2780,7 @@ cvtopdecls0 :: { [LHsDecl GhcPs] } -- "texp" is short for tuple expressions: -- things that can appear unparenthesized as long as they're -- inside parens or delimitted by commas -texp :: { LHsExpr GhcPs } +texp :: { LExpPatFrame } : exp { $1 } -- Note [Parsing sections] @@ -2801,68 +2794,65 @@ texp :: { LHsExpr GhcPs } -- Then when converting expr to pattern we unravel it again -- Meanwhile, the renamer checks that real sections appear -- inside parens. - | infixexp qop { sLL $1 $> $ SectionL noExt $1 $2 } - | qopm infixexp { sLL $1 $> $ SectionR noExt $1 $2 } + | infixexp qop { sLL $1 $> $ FrameSectionL $1 $2 } + | qopm infixexp { sLL $1 $> $ FrameSectionR $1 $2 } -- View patterns get parenthesized above - | exp '->' texp {% ams (sLL $1 $> $ EViewPat noExt $1 $3) [mu AnnRarrow $2] } + | exp '->' texp {% ams (sLL $1 $> $ FrameViewPat $1 $3) [mu AnnRarrow $2] } -- Always at least one comma or bar. tup_exprs :: { ([AddAnn],SumOrTuple) } : texp commas_tup_tail {% do { addAnnotation (gl $1) AnnComma (fst $2) - ; return ([],Tuple ((sL1 $1 (Present noExt $1)) : snd $2)) } } + ; return ([],Tuple ((sL1 $1 (TupArgFramePresent $1)) : snd $2)) } } | texp bars { (mvbars (fst $2), Sum 1 (snd $2 + 1) $1) } | commas tup_tail {% do { mapM_ (\ll -> addAnnotation ll AnnComma ll) (fst $1) ; return - ([],Tuple (map (\l -> cL l missingTupArg) (fst $1) ++ $2)) } } + ([],Tuple (map (\l -> cL l TupArgFrameMissing) (fst $1) ++ $2)) } } | bars texp bars0 { (mvbars (fst $1) ++ mvbars (fst $3), Sum (snd $1 + 1) (snd $1 + snd $3 + 1) $2) } -- Always starts with commas; always follows an expr -commas_tup_tail :: { (SrcSpan,[LHsTupArg GhcPs]) } +commas_tup_tail :: { (SrcSpan,[LTupArgFrame]) } commas_tup_tail : commas tup_tail {% do { mapM_ (\ll -> addAnnotation ll AnnComma ll) (tail $ fst $1) ; return ( (head $ fst $1 - ,(map (\l -> cL l missingTupArg) (tail $ fst $1)) ++ $2)) } } + ,(map (\l -> cL l TupArgFrameMissing) (tail $ fst $1)) ++ $2)) } } -- Always follows a comma -tup_tail :: { [LHsTupArg GhcPs] } +tup_tail :: { [LTupArgFrame] } : texp commas_tup_tail {% addAnnotation (gl $1) AnnComma (fst $2) >> - return ((cL (gl $1) (Present noExt $1)) : snd $2) } - | texp { [cL (gl $1) (Present noExt $1)] } - | {- empty -} { [noLoc missingTupArg] } + return ((cL (gl $1) (TupArgFramePresent $1)) : snd $2) } + | texp { [cL (gl $1) (TupArgFramePresent $1)] } + | {- empty -} { [noLoc TupArgFrameMissing] } ----------------------------------------------------------------------------- -- List expressions -- The rules below are little bit contorted to keep lexps left-recursive while -- avoiding another shift/reduce-conflict. -list :: { ([AddAnn],HsExpr GhcPs) } - : texp { ([],ExplicitList noExt Nothing [$1]) } - | lexps { ([],ExplicitList noExt Nothing (reverse (unLoc $1))) } +list :: { ([AddAnn],ExpPatFrame) } + : texp { ([],FrameList [$1]) } + | lexps { ([],FrameList (reverse (unLoc $1))) } | texp '..' { ([mj AnnDotdot $2], - ArithSeq noExt Nothing (From $1)) } + FrameArithSeq (From (checkExpr $1))) } | texp ',' exp '..' { ([mj AnnComma $2,mj AnnDotdot $4], - ArithSeq noExt Nothing - (FromThen $1 $3)) } + FrameArithSeq (FromThen (checkExpr $1) (checkExpr $3))) } | texp '..' exp { ([mj AnnDotdot $2], - ArithSeq noExt Nothing - (FromTo $1 $3)) } + FrameArithSeq (FromTo (checkExpr $1) (checkExpr $3))) } | texp ',' exp '..' exp { ([mj AnnComma $2,mj AnnDotdot $4], - ArithSeq noExt Nothing - (FromThenTo $1 $3 $5)) } + FrameArithSeq (FromThenTo (checkExpr $1) (checkExpr $3) (checkExpr $5))) } | texp '|' flattenedpquals {% checkMonadComp >>= \ ctxt -> return ([mj AnnVbar $2], - mkHsComp ctxt (unLoc $3) $1) } + FrameComp ctxt (unLoc $3) $1) } -lexps :: { Located [LHsExpr GhcPs] } +lexps :: { Located [LExpPatFrame] } : lexps ',' texp {% addAnnotation (gl $ head $ unLoc $1) AnnComma (gl $2) >> return (sLL $1 $> (((:) $! $3) $! unLoc $1)) } @@ -2872,26 +2862,24 @@ lexps :: { Located [LHsExpr GhcPs] } ----------------------------------------------------------------------------- -- List Comprehensions -flattenedpquals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } +flattenedpquals :: { Located [LFrameStmt] } : pquals { case (unLoc $1) of [qs] -> sL1 $1 qs -- We just had one thing in our "parallel" list so -- we simply return that thing directly - qss -> sL1 $1 [sL1 $1 $ ParStmt noExt [ParStmtBlock noExt qs [] noSyntaxExpr | - qs <- qss] - noExpr noSyntaxExpr] + qss -> sL1 $1 [sL1 $1 $ FrameParStmt qss] -- We actually found some actual parallel lists so -- we wrap them into as a ParStmt } -pquals :: { Located [[LStmt GhcPs (LHsExpr GhcPs)]] } +pquals :: { Located [[LFrameStmt]] } : squals '|' pquals {% addAnnotation (gl $ head $ unLoc $1) AnnVbar (gl $2) >> return (sLL $1 $> (reverse (unLoc $1) : unLoc $3)) } | squals { cL (getLoc $1) [reverse (unLoc $1)] } -squals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } -- In reverse order, because the last +squals :: { Located [LFrameStmt] } -- In reverse order, because the last -- one can "grab" the earlier ones : squals ',' transformqual {% addAnnotation (gl $ head $ unLoc $1) AnnComma (gl $2) >> @@ -2911,15 +2899,15 @@ squals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } -- In reverse order, becau -- consensus on the syntax, this feature is not being used until we -- get user demand. -transformqual :: { Located ([AddAnn],[LStmt GhcPs (LHsExpr GhcPs)] -> Stmt GhcPs (LHsExpr GhcPs)) } +transformqual :: { Located ([AddAnn],[LFrameStmt] -> FrameStmt) } -- Function is applied to a list of stmts *in order* - : 'then' exp { sLL $1 $> ([mj AnnThen $1], \ss -> (mkTransformStmt ss $2)) } - | 'then' exp 'by' exp { sLL $1 $> ([mj AnnThen $1,mj AnnBy $3],\ss -> (mkTransformByStmt ss $2 $4)) } + : 'then' exp { sLL $1 $> ([mj AnnThen $1], \ss -> FrameTransformStmt ss $2) } + | 'then' exp 'by' exp { sLL $1 $> ([mj AnnThen $1,mj AnnBy $3],\ss -> FrameTransformByStmt ss $2 $4) } | 'then' 'group' 'using' exp - { sLL $1 $> ([mj AnnThen $1,mj AnnGroup $2,mj AnnUsing $3], \ss -> (mkGroupUsingStmt ss $4)) } + { sLL $1 $> ([mj AnnThen $1,mj AnnGroup $2,mj AnnUsing $3], \ss -> FrameGroupUsingStmt ss $4) } | 'then' 'group' 'by' exp 'using' exp - { sLL $1 $> ([mj AnnThen $1,mj AnnGroup $2,mj AnnBy $3,mj AnnUsing $5], \ss -> (mkGroupByUsingStmt ss $4 $6)) } + { sLL $1 $> ([mj AnnThen $1,mj AnnGroup $2,mj AnnBy $3,mj AnnUsing $5], \ss -> FrameGroupByUsingStmt ss $4 $6) } -- Note that 'group' is a special_id, which means that you can enable -- TransformListComp while still using Data.List.group. However, this @@ -2935,13 +2923,13 @@ guardquals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } guardquals1 :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } : guardquals1 ',' qual {% addAnnotation (gl $ head $ unLoc $1) AnnComma (gl $2) >> - return (sLL $1 $> ($3 : unLoc $1)) } - | qual { sL1 $1 [$1] } + return (sLL $1 $> (checkExprStmt $3 : unLoc $1)) } + | qual { sL1 $1 [checkExprStmt $1] } ----------------------------------------------------------------------------- -- Case alternatives -altslist :: { Located ([AddAnn],[LMatch GhcPs (LHsExpr GhcPs)]) } +altslist :: { Located ([AddAnn],[LFrameMatch]) } : '{' alts '}' { sLL $1 $> ((moc $1:mcc $3:(fst $ unLoc $2)) ,(reverse (snd $ unLoc $2))) } | vocurly alts close { cL (getLoc $2) (fst $ unLoc $2 @@ -2949,12 +2937,12 @@ altslist :: { Located ([AddAnn],[LMatch GhcPs (LHsExpr GhcPs)]) } | '{' '}' { sLL $1 $> ([moc $1,mcc $2],[]) } | vocurly close { noLoc ([],[]) } -alts :: { Located ([AddAnn],[LMatch GhcPs (LHsExpr GhcPs)]) } +alts :: { Located ([AddAnn],[LFrameMatch]) } : alts1 { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } | ';' alts { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)) ,snd $ unLoc $2) } -alts1 :: { Located ([AddAnn],[LMatch GhcPs (LHsExpr GhcPs)]) } +alts1 :: { Located ([AddAnn],[LFrameMatch]) } : alts1 ';' alt {% if null (snd $ unLoc $1) then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1) ,[$3])) @@ -2969,36 +2957,33 @@ alts1 :: { Located ([AddAnn],[LMatch GhcPs (LHsExpr GhcPs)]) } >> return (sLL $1 $> ([],snd $ unLoc $1))) } | alt { sL1 $1 ([],[$1]) } -alt :: { LMatch GhcPs (LHsExpr GhcPs) } - : pat alt_rhs {%ams (sLL $1 $> (Match { m_ext = noExt - , m_ctxt = CaseAlt - , m_pats = [$1] - , m_grhss = snd $ unLoc $2 })) +alt :: { LFrameMatch } + : pat alt_rhs {%ams (sLL $1 $> (FrameMatch CaseAlt [$1] (snd $ unLoc $2))) (fst $ unLoc $2)} -alt_rhs :: { Located ([AddAnn],GRHSs GhcPs (LHsExpr GhcPs)) } +alt_rhs :: { Located ([AddAnn],FrameGRHSs) } : ralt wherebinds { sLL $1 $> (fst $ unLoc $2, - GRHSs noExt (unLoc $1) (snd $ unLoc $2)) } + FrameGRHSs (unLoc $1) (snd $ unLoc $2)) } -ralt :: { Located [LGRHS GhcPs (LHsExpr GhcPs)] } - : '->' exp {% ams (sLL $1 $> (unguardedRHS (comb2 $1 $2) $2)) +ralt :: { Located [LFrameGRHS] } + : '->' exp {% ams (sLL $1 $> (unguardedFrameRHS (comb2 $1 $2) $2)) [mu AnnRarrow $1] } | gdpats { sL1 $1 (reverse (unLoc $1)) } -gdpats :: { Located [LGRHS GhcPs (LHsExpr GhcPs)] } +gdpats :: { Located [LFrameGRHS] } : gdpats gdpat { sLL $1 $> ($2 : unLoc $1) } | gdpat { sL1 $1 [$1] } -- layout for MultiWayIf doesn't begin with an open brace, because it's hard to -- generate the open brace in addition to the vertical bar in the lexer, and -- we don't need it. -ifgdpats :: { Located ([AddAnn],[LGRHS GhcPs (LHsExpr GhcPs)]) } +ifgdpats :: { Located ([AddAnn],[LFrameGRHS]) } : '{' gdpats '}' { sLL $1 $> ([moc $1,mcc $3],unLoc $2) } | gdpats close { sL1 $1 ([],unLoc $1) } -gdpat :: { LGRHS GhcPs (LHsExpr GhcPs) } +gdpat :: { LFrameGRHS } : '|' guardquals '->' exp - {% ams (sL (comb2 $1 $>) $ GRHS noExt (unLoc $2) $4) + {% ams (sL (comb2 $1 $>) $ FrameGRHS (unLoc $2) $4) [mj AnnVbar $1,mu AnnRarrow $3] } -- 'pat' recognises a pattern, including one with a bang at the top @@ -3007,8 +2992,8 @@ gdpat :: { LGRHS GhcPs (LHsExpr GhcPs) } -- we parse them right when bang-patterns are off pat :: { LPat GhcPs } pat : exp {% checkPattern empty $1 } - | '!' aexp {% amms (checkPattern empty (sLL $1 $> (SectionR noExt - (sL1 $1 (HsVar noExt (sL1 $1 bang_RDR))) $2))) + | '!' aexp {% amms (checkPattern empty (sLL $1 $> (FrameSectionR + (sL1 $1 (FrameVar bang_RDR)) $2))) [mj AnnBang $1] } bindpat :: { LPat GhcPs } @@ -3016,14 +3001,14 @@ bindpat : exp {% checkPattern (text "Possibly caused by a missing 'do'?") $1 } | '!' aexp {% amms (checkPattern (text "Possibly caused by a missing 'do'?") - (sLL $1 $> (SectionR noExt (sL1 $1 (HsVar noExt (sL1 $1 bang_RDR))) $2))) + (sLL $1 $> (FrameSectionR (sL1 $1 (FrameVar bang_RDR)) $2))) [mj AnnBang $1] } apat :: { LPat GhcPs } apat : aexp {% checkPattern empty $1 } | '!' aexp {% amms (checkPattern empty - (sLL $1 $> (SectionR noExt - (sL1 $1 (HsVar noExt (sL1 $1 bang_RDR))) $2))) + (sLL $1 $> (FrameSectionR + (sL1 $1 (FrameVar bang_RDR)) $2))) [mj AnnBang $1] } apats :: { [LPat GhcPs] } @@ -3033,7 +3018,7 @@ apats :: { [LPat GhcPs] } ----------------------------------------------------------------------------- -- Statement sequences -stmtlist :: { Located ([AddAnn],[LStmt GhcPs (LHsExpr GhcPs)]) } +stmtlist :: { Located ([AddAnn],[LFrameStmt]) } : '{' stmts '}' { sLL $1 $> ((moc $1:mcc $3:(fst $ unLoc $2)) ,(reverse $ snd $ unLoc $2)) } -- AZ:performance of reverse? | vocurly stmts close { cL (gl $2) (fst $ unLoc $2 @@ -3045,7 +3030,7 @@ stmtlist :: { Located ([AddAnn],[LStmt GhcPs (LHsExpr GhcPs)]) } -- So we use BodyStmts throughout, and switch the last one over -- in ParseUtils.checkDo instead -stmts :: { Located ([AddAnn],[LStmt GhcPs (LHsExpr GhcPs)]) } +stmts :: { Located ([AddAnn],[LFrameStmt]) } : stmts ';' stmt {% if null (snd $ unLoc $1) then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1) ,$3 : (snd $ unLoc $1))) @@ -3066,36 +3051,36 @@ stmts :: { Located ([AddAnn],[LStmt GhcPs (LHsExpr GhcPs)]) } -- For typing stmts at the GHCi prompt, where -- the input may consist of just comments. maybe_stmt :: { Maybe (LStmt GhcPs (LHsExpr GhcPs)) } - : stmt { Just $1 } + : stmt { Just (checkExprStmt $1) } | {- nothing -} { Nothing } -stmt :: { LStmt GhcPs (LHsExpr GhcPs) } +stmt :: { LFrameStmt } : qual { $1 } - | 'rec' stmtlist {% ams (sLL $1 $> $ mkRecStmt (snd $ unLoc $2)) + | 'rec' stmtlist {% ams (sLL $1 $> $ FrameRecStmt (snd $ unLoc $2)) (mj AnnRec $1:(fst $ unLoc $2)) } -qual :: { LStmt GhcPs (LHsExpr GhcPs) } - : bindpat '<-' exp {% ams (sLL $1 $> $ mkBindStmt $1 $3) +qual :: { LFrameStmt } + : bindpat '<-' exp {% ams (sLL $1 $> $ FrameBindStmt $1 $3) [mu AnnLarrow $2] } - | exp { sL1 $1 $ mkBodyStmt $1 } - | 'let' binds {% ams (sLL $1 $>$ LetStmt noExt (snd $ unLoc $2)) + | exp { sL1 $1 $ FrameBodyStmt $1 } + | 'let' binds {% ams (sLL $1 $>$ FrameLetStmt (snd $ unLoc $2)) (mj AnnLet $1:(fst $ unLoc $2)) } ----------------------------------------------------------------------------- -- Record Field Update/Construction -fbinds :: { ([AddAnn],([LHsRecField GhcPs (LHsExpr GhcPs)], Bool)) } +fbinds :: { ([AddAnn],([LHsRecField GhcPs LExpPatFrame], Bool)) } : fbinds1 { $1 } | {- empty -} { ([],([], False)) } -fbinds1 :: { ([AddAnn],([LHsRecField GhcPs (LHsExpr GhcPs)], Bool)) } +fbinds1 :: { ([AddAnn],([LHsRecField GhcPs LExpPatFrame], Bool)) } : fbind ',' fbinds1 {% addAnnotation (gl $1) AnnComma (gl $2) >> return (case $3 of (ma,(flds, dd)) -> (ma,($1 : flds, dd))) } | fbind { ([],([$1], False)) } | '..' { ([mj AnnDotdot $1],([], True)) } -fbind :: { LHsRecField GhcPs (LHsExpr GhcPs) } +fbind :: { LHsRecField GhcPs LExpPatFrame } : qvar '=' texp {% ams (sLL $1 $> $ HsRecField (sL1 $1 $ mkFieldOcc $1) $3 False) [mj AnnEqual $2] } -- RHS is a 'texp', allowing view patterns (Trac #6038) @@ -3120,7 +3105,7 @@ dbinds :: { Located [LIPBind GhcPs] } -- | {- empty -} { [] } dbind :: { LIPBind GhcPs } -dbind : ipvar '=' exp {% ams (sLL $1 $> (IPBind noExt (Left $1) $3)) +dbind : ipvar '=' exp {% ams (sLL $1 $> (IPBind noExt (Left $1) (checkExpr $3))) [mj AnnEqual $2] } ipvar :: { Located HsIPName } @@ -3334,18 +3319,18 @@ varop :: { Located RdrName } [mj AnnBackquote $1,mj AnnVal $2 ,mj AnnBackquote $3] } -qop :: { LHsExpr GhcPs } -- used in sections - : qvarop { sL1 $1 $ HsVar noExt $1 } - | qconop { sL1 $1 $ HsVar noExt $1 } +qop :: { LExpPatFrame } -- used in sections + : qvarop { mapLoc FrameVar $1 } + | qconop { mapLoc FrameVar $1 } | hole_op { $1 } -qopm :: { LHsExpr GhcPs } -- used in sections - : qvaropm { sL1 $1 $ HsVar noExt $1 } - | qconop { sL1 $1 $ HsVar noExt $1 } +qopm :: { LExpPatFrame } -- used in sections + : qvaropm { mapLoc FrameVar $1 } + | qconop { mapLoc FrameVar $1 } | hole_op { $1 } -hole_op :: { LHsExpr GhcPs } -- used in sections -hole_op : '`' '_' '`' {% ams (sLL $1 $> $ EWildPat noExt) +hole_op :: { LExpPatFrame } -- used in sections +hole_op : '`' '_' '`' {% ams (sLL $1 $> FrameWild) [mj AnnBackquote $1,mj AnnVal $2 ,mj AnnBackquote $3] } @@ -3794,8 +3779,8 @@ hintExplicitForall' span = do , text "extension to enable explicit-forall syntax: forall . " ] -checkIfBang :: LHsExpr GhcPs -> Bool -checkIfBang (dL->L _ (HsVar _ (dL->L _ op))) = op == bang_RDR +checkIfBang :: LExpPatFrame -> Bool +checkIfBang (dL->L _ (FrameVar op)) = op == bang_RDR checkIfBang _ = False -- | Warn about missing space after bang diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs index 88217c27a2..95c01ed092 100644 --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -75,7 +75,10 @@ module RdrHsSyn ( warnStarIsType, failOpFewArgs, - SumOrTuple (..), mkSumOrTuple + SumOrTuple (..), mkSumOrTuple, + + -- ExpPatFrame + module ExpPatFrame ) where @@ -109,6 +112,7 @@ import Util import ApiAnnotation import Data.List import DynFlags ( WarningFlag(..) ) +import ExpPatFrame import Control.Monad import Text.ParserCombinators.ReadP as ReadP @@ -982,16 +986,16 @@ checkTyClHdr is_cls ty -- | Yield a parse error if we have a function applied directly to a do block -- etc. and BlockArguments is not enabled. -checkBlockArguments :: LHsExpr GhcPs -> P () +checkBlockArguments :: LExpPatFrame -> P () checkBlockArguments expr = case unLoc expr of - HsDo _ DoExpr _ -> check "do block" - HsDo _ MDoExpr _ -> check "mdo block" - HsLam {} -> check "lambda expression" - HsCase {} -> check "case expression" - HsLamCase {} -> check "lambda-case expression" - HsLet {} -> check "let expression" - HsIf {} -> check "if expression" - HsProc {} -> check "proc expression" + FrameDo DoExpr _ -> check "do block" + FrameDo MDoExpr _ -> check "mdo block" + FrameLam {} -> check "lambda expression" + FrameCase {} -> check "case expression" + FrameLamCase {} -> check "lambda-case expression" + FrameLet {} -> check "let expression" + FrameIf {} -> check "if expression" + FrameProc {} -> check "proc expression" _ -> return () where check element = do @@ -1050,18 +1054,18 @@ checkNoDocs msg ty = go ty -- We parse patterns as expressions and check for valid patterns below, -- converting the expression into a pattern at the same time. -checkPattern :: SDoc -> LHsExpr GhcPs -> P (LPat GhcPs) +checkPattern :: SDoc -> LExpPatFrame -> P (LPat GhcPs) checkPattern msg e = checkLPat msg e -checkPatterns :: SDoc -> [LHsExpr GhcPs] -> P [LPat GhcPs] +checkPatterns :: SDoc -> [LExpPatFrame] -> P [LPat GhcPs] checkPatterns msg es = mapM (checkPattern msg) es -checkLPat :: SDoc -> LHsExpr GhcPs -> P (LPat GhcPs) +checkLPat :: SDoc -> LExpPatFrame -> P (LPat GhcPs) checkLPat msg e@(dL->L l _) = checkPat msg l e [] -checkPat :: SDoc -> SrcSpan -> LHsExpr GhcPs -> [LPat GhcPs] +checkPat :: SDoc -> SrcSpan -> LExpPatFrame -> [LPat GhcPs] -> P (LPat GhcPs) -checkPat _ loc (dL->L l e@(HsVar _ (dL->L _ c))) args +checkPat _ loc (dL->L l e@(FrameVar c)) args | isRdrDataCon c = return (cL loc (ConPatIn (cL l c) (PrefixCon args))) | not (null args) && patIsRec c = patFail (text "Perhaps you intended to use RecursiveDo") l e @@ -1071,103 +1075,104 @@ checkPat msg loc e args -- OK to let this happen even if bang-patterns | Just (e', args') <- splitBang e = do { args'' <- checkPatterns msg args' ; checkPat msg loc e' (args'' ++ args) } -checkPat msg loc (dL->L _ (HsApp _ f e)) args +checkPat msg loc (dL->L _ (FrameApp f e)) args = do p <- checkLPat msg e checkPat msg loc f (p : args) -checkPat msg loc (dL->L _ e) [] +checkPat msg loc e [] = do p <- checkAPat msg loc e return (cL loc p) checkPat msg loc e _ = patFail msg loc (unLoc e) -checkAPat :: SDoc -> SrcSpan -> HsExpr GhcPs -> P (Pat GhcPs) -checkAPat msg loc e0 = do +checkAPat :: SDoc -> SrcSpan -> LExpPatFrame -> P (Pat GhcPs) +checkAPat msg loc (dL->L el e0) = do nPlusKPatterns <- getBit NPlusKPatternsBit case e0 of - EWildPat _ -> return (WildPat noExt) - HsVar _ x -> return (VarPat noExt x) - HsLit _ (HsStringPrim _ _) -- (#13260) + FrameWild -> return (WildPat noExt) + FrameVar x -> return (VarPat noExt (cL el x)) + FrameLit (HsStringPrim _ _) -- (#13260) -> parseErrorSDoc loc (text "Illegal unboxed string literal in pattern:" $$ ppr e0) - HsLit _ l -> return (LitPat noExt l) + FrameLit l -> return (LitPat noExt l) -- 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 - HsOverLit _ pos_lit -> return (mkNPat (cL loc pos_lit) Nothing) - NegApp _ (dL->L l (HsOverLit _ pos_lit)) _ + FrameOverLit pos_lit -> return (mkNPat (cL loc pos_lit) Nothing) + FrameNegApp (dL->L l (FrameOverLit pos_lit)) -> return (mkNPat (cL l pos_lit) (Just noSyntaxExpr)) - SectionR _ (dL->L lb (HsVar _ (dL->L _ bang))) e -- (! x) + FrameSectionR (dL->L lb (FrameVar bang)) e -- (! x) | bang == bang_RDR -> do { hintBangPat loc e0 ; e' <- checkLPat msg e ; addAnnotation loc AnnBang lb ; return (BangPat noExt e') } - ELazyPat _ e -> checkLPat msg e >>= (return . (LazyPat noExt)) - EAsPat _ n e -> checkLPat msg e >>= (return . (AsPat noExt) n) + FrameLazyPat e -> checkLPat msg e >>= (return . (LazyPat noExt)) + FrameAsPat n e -> checkLPat msg e >>= (return . (AsPat noExt) n) -- view pattern is well-formed if the pattern is - EViewPat _ expr patE -> checkLPat msg patE >>= - (return . (\p -> ViewPat noExt expr p)) - ExprWithTySig _ e t -> do e <- checkLPat msg e - return (SigPat noExt e t) + FrameViewPat expr patE -> checkLPat msg patE >>= + (return . (\p -> ViewPat noExt (checkExpr expr) p)) + FrameTySig e t -> do e <- checkLPat msg e + return (SigPat noExt e t) -- n+k patterns - OpApp _ (dL->L nloc (HsVar _ (dL->L _ n))) - (dL->L _ (HsVar _ (dL->L _ plus))) - (dL->L lloc (HsOverLit _ lit@(OverLit {ol_val = HsIntegral {}}))) + FrameOpApp + (dL->L nloc (FrameVar n)) + (dL->L _ (FrameVar plus)) + (dL->L lloc (FrameOverLit lit@(OverLit {ol_val = HsIntegral {}}))) | nPlusKPatterns && (plus == plus_RDR) -> return (mkNPlusKPat (cL nloc n) (cL lloc lit)) - OpApp _ l (dL->L cl (HsVar _ (dL->L _ c))) r + FrameOpApp l (dL->L cl (FrameVar c)) r | isDataOcc (rdrNameOcc c) -> do l <- checkLPat msg l r <- checkLPat msg r return (ConPatIn (cL cl c) (InfixCon l r)) - OpApp {} -> patFail msg loc e0 + FrameOpApp {} -> patFail msg loc e0 - ExplicitList _ _ es -> do ps <- mapM (checkLPat msg) es - return (ListPat noExt ps) + FrameList es -> do ps <- mapM (checkLPat msg) es + return (ListPat noExt ps) - HsPar _ e -> checkLPat msg e >>= (return . (ParPat noExt)) + FramePar e -> checkLPat msg e >>= (return . (ParPat noExt)) - ExplicitTuple _ es b - | all tupArgPresent es -> do ps <- mapM (checkLPat msg) - [e | (dL->L _ (Present _ e)) <- es] - return (TuplePat noExt ps b) + FrameTuple es b + | Just es' <- traverse (fromTupArgPresent . unLoc) es -> + do ps <- mapM (checkLPat msg) es' + return (TuplePat noExt ps b) | otherwise -> parseErrorSDoc loc (text "Illegal tuple section in pattern:" $$ ppr e0) - ExplicitSum _ alt arity expr -> do + FrameSum alt arity expr -> do p <- checkLPat msg expr return (SumPat noExt p alt arity) - RecordCon { rcon_con_name = c, rcon_flds = HsRecFields fs dd } + FrameRecordCon c (HsRecFields fs dd) -> do fs <- mapM (checkPatField msg) fs return (ConPatIn c (RecCon (HsRecFields fs dd))) - HsSpliceE _ s | not (isTypedSplice s) + FrameSplice s | not (isTypedSplice s) -> return (SplicePat noExt s) _ -> patFail msg loc e0 -placeHolderPunRhs :: LHsExpr GhcPs +placeHolderPunRhs :: LExpPatFrame -- 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 noExt (noLoc pun_RDR)) +placeHolderPunRhs = noLoc (FrameVar pun_RDR) plus_RDR, bang_RDR, pun_RDR :: RdrName plus_RDR = mkUnqual varName (fsLit "+") -- Hack bang_RDR = mkUnqual varName (fsLit "!") -- Hack pun_RDR = mkUnqual varName (fsLit "pun-right-hand-side") -checkPatField :: SDoc -> LHsRecField GhcPs (LHsExpr GhcPs) +checkPatField :: SDoc -> LHsRecField GhcPs LExpPatFrame -> P (LHsRecField GhcPs (LPat GhcPs)) checkPatField msg (dL->L l fld) = do p <- checkLPat msg (hsRecFieldArg fld) return (cL l (fld { hsRecFieldArg = p })) -patFail :: SDoc -> SrcSpan -> HsExpr GhcPs -> P a +patFail :: SDoc -> SrcSpan -> ExpPatFrame -> P a patFail msg loc e = parseErrorSDoc loc err where err = text "Parse error in pattern:" <+> ppr e $$ msg @@ -1181,15 +1186,15 @@ patIsRec e = e == mkUnqual varName (fsLit "rec") checkValDef :: SDoc -> SrcStrictness - -> LHsExpr GhcPs + -> LExpPatFrame -> Maybe (LHsType GhcPs) - -> Located (a,GRHSs GhcPs (LHsExpr GhcPs)) + -> Located (a,FrameGRHSs) -> P ([AddAnn],HsBind GhcPs) checkValDef msg _strictness lhs (Just sig) grhss -- x :: ty = rhs parses as a *pattern* binding = checkPatBind msg (cL (combineLocs lhs sig) - (ExprWithTySig noExt lhs (mkLHsSigWcType sig))) grhss + (FrameTySig lhs (mkLHsSigWcType sig))) grhss checkValDef msg strictness lhs Nothing g@(dL->L l (_,grhss)) = do { mb_fun <- isFunLhs lhs @@ -1205,8 +1210,8 @@ checkFunBind :: SDoc -> SrcSpan -> Located RdrName -> LexicalFixity - -> [LHsExpr GhcPs] - -> Located (GRHSs GhcPs (LHsExpr GhcPs)) + -> [LExpPatFrame] + -> Located FrameGRHSs -> P ([AddAnn],HsBind GhcPs) checkFunBind msg strictness ann lhs_loc fun is_infix pats (dL->L rhs_span grhss) = do ps <- checkPatterns msg pats @@ -1220,7 +1225,7 @@ checkFunBind msg strictness ann lhs_loc fun is_infix pats (dL->L rhs_span grhss) , mc_fixity = is_infix , mc_strictness = strictness } , m_pats = ps - , m_grhss = grhss })]) + , m_grhss = checkExprGRHSs grhss })]) -- The span of the match covers the entire equation. -- That isn't quite right, but it'll do for now. @@ -1235,19 +1240,19 @@ makeFunBind fn ms fun_tick = [] } checkPatBind :: SDoc - -> LHsExpr GhcPs - -> Located (a,GRHSs GhcPs (LHsExpr GhcPs)) + -> LExpPatFrame + -> Located (a,FrameGRHSs) -> P ([AddAnn],HsBind GhcPs) checkPatBind msg lhs (dL->L _ (_,grhss)) = do { lhs <- checkPattern msg lhs - ; return ([],PatBind noExt lhs grhss + ; return ([],PatBind noExt lhs (checkExprGRHSs grhss) ([],[])) } -checkValSigLhs :: LHsExpr GhcPs -> P (Located RdrName) -checkValSigLhs (dL->L _ (HsVar _ lrdr@(dL->L _ v))) +checkValSigLhs :: LExpPatFrame -> P (Located RdrName) +checkValSigLhs (dL->L l (FrameVar v)) | isUnqual v , not (isDataOcc (rdrNameOcc v)) - = return lrdr + = return (cL l v) checkValSigLhs lhs@(dL->L l _) = parseErrorSDoc l ((text "Invalid type signature:" <+> @@ -1267,8 +1272,8 @@ checkValSigLhs lhs@(dL->L l _) -- so check for that, and suggest. cf Trac #3805 -- Sadly 'foreign import' still barfs 'parse error' because -- 'import' is a keyword - looks_like s (dL->L _ (HsVar _ (dL->L _ v))) = v == s - looks_like s (dL->L _ (HsApp _ lhs _)) = looks_like s lhs + looks_like s (dL->L _ (FrameVar v)) = v == s + looks_like s (dL->L _ (FrameApp lhs _)) = looks_like s lhs looks_like _ _ = False foreign_RDR = mkUnqual varName (fsLit "foreign") @@ -1276,11 +1281,11 @@ checkValSigLhs lhs@(dL->L l _) pattern_RDR = mkUnqual varName (fsLit "pattern") -checkDoAndIfThenElse :: LHsExpr GhcPs +checkDoAndIfThenElse :: LExpPatFrame -> Bool - -> LHsExpr GhcPs + -> LExpPatFrame -> Bool - -> LHsExpr GhcPs + -> LExpPatFrame -> P () checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr | semiThen || semiElse @@ -1300,20 +1305,20 @@ checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr -- The parser left-associates, so there should -- not be any OpApps inside the e's -splitBang :: LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, [LHsExpr GhcPs]) +splitBang :: LExpPatFrame -> Maybe (LExpPatFrame, [LExpPatFrame]) -- Splits (f ! g a b) into (f, [(! g), a, b]) -splitBang (dL->L _ (OpApp _ l_arg bang@(dL->L _ (HsVar _ (dL->L _ op))) r_arg)) - | op == bang_RDR = Just (l_arg, cL l' (SectionR noExt bang arg1) : argns) +splitBang (dL->L _ (FrameOpApp l_arg bang@(dL->L _ (FrameVar op)) r_arg)) + | op == bang_RDR = Just (l_arg, cL l' (FrameSectionR bang arg1) : argns) where l' = combineLocs bang arg1 (arg1,argns) = split_bang r_arg [] - split_bang (dL->L _ (HsApp _ f e)) es = split_bang f (e:es) + split_bang (dL->L _ (FrameApp f e)) es = split_bang f (e:es) split_bang e es = (e,es) splitBang _ = Nothing -- See Note [isFunLhs vs mergeDataCon] -isFunLhs :: LHsExpr GhcPs - -> P (Maybe (Located RdrName, LexicalFixity, [LHsExpr GhcPs],[AddAnn])) +isFunLhs :: LExpPatFrame + -> P (Maybe (Located RdrName, LexicalFixity, [LExpPatFrame],[AddAnn])) -- A variable binding is parsed as a FunBind. -- Just (fun, is_infix, arg_pats) if e is a function LHS -- @@ -1328,15 +1333,15 @@ isFunLhs :: LHsExpr GhcPs isFunLhs e = go e [] [] where - go (dL->L loc (HsVar _ (dL->L _ f))) es ann + go (dL->L loc (FrameVar f)) es ann | not (isRdrDataCon f) = return (Just (cL loc f, Prefix, es, ann)) - go (dL->L _ (HsApp _ f e)) es ann = go f (e:es) ann - go (dL->L l (HsPar _ e)) es@(_:_) ann = go e es (ann ++ mkParensApiAnn l) + go (dL->L _ (FrameApp f e)) es ann = go f (e:es) ann + go (dL->L l (FramePar e)) es@(_:_) ann = go e es (ann ++ mkParensApiAnn l) -- Things of the form `!x` are also FunBinds -- See Note [FunBind vs PatBind] - go (dL->L _ (SectionR _ (dL->L _ (HsVar _ (dL->L _ bang))) - (dL->L l (HsVar _ (L _ var))))) [] ann + go (dL->L _ (FrameSectionR (dL->L _ (FrameVar bang)) + (dL->L l (FrameVar var)))) [] ann | bang == bang_RDR , not (isRdrDataCon var) = return (Just (cL l var, Prefix, [], ann)) @@ -1353,7 +1358,7 @@ isFunLhs e = go e [] [] -- ToDo: what about this? -- x + 1 `op` y = ... - go e@(L loc (OpApp _ l (dL->L loc' (HsVar _ (dL->L _ op))) r)) es ann + go e@(L loc (FrameOpApp l (dL->L loc' (FrameVar op)) r)) es ann | Just (e',es') <- splitBang e = do { bang_on <- getBit BangPatBit ; if bang_on then go e' (es' ++ es) ann @@ -1367,8 +1372,8 @@ isFunLhs e = go e [] [] Just (op', Infix, j : k : es', ann') -> return (Just (op', Infix, j : op_app : es', ann')) where - op_app = cL loc (OpApp noExt k - (cL loc' (HsVar noExt (cL loc' op))) r) + op_app = cL loc (FrameOpApp k + (cL loc' (FrameVar op)) r) _ -> return Nothing } go _ _ _ = return Nothing @@ -1866,93 +1871,93 @@ 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 GhcPs -> P (LHsCmd GhcPs) +checkCommand :: LExpPatFrame -> P (LHsCmd GhcPs) checkCommand lc = locMap checkCmd lc locMap :: (SrcSpan -> a -> P b) -> Located a -> P (Located b) locMap f (dL->L l a) = f l a >>= (\b -> return $ cL l b) -checkCmd :: SrcSpan -> HsExpr GhcPs -> P (HsCmd GhcPs) -checkCmd _ (HsArrApp _ e1 e2 haat b) = - return $ HsCmdArrApp noExt e1 e2 haat b -checkCmd _ (HsArrForm _ e mf args) = - return $ HsCmdArrForm noExt e Prefix mf args -checkCmd _ (HsApp _ e1 e2) = - checkCommand e1 >>= (\c -> return $ HsCmdApp noExt c e2) -checkCmd _ (HsLam _ mg) = - checkCmdMatchGroup mg >>= (\mg' -> return $ HsCmdLam noExt mg') -checkCmd _ (HsPar _ e) = +checkCmd :: SrcSpan -> ExpPatFrame -> P (HsCmd GhcPs) +checkCmd _ (FrameArrApp e1 e2 haat b) = + return $ HsCmdArrApp noExt (checkExpr e1) (checkExpr e2) haat b +checkCmd _ (FrameArrForm e args) = + return $ HsCmdArrForm noExt (checkExpr e) Prefix Nothing args +checkCmd _ (FrameApp e1 e2) = + checkCommand e1 >>= (\c -> return $ HsCmdApp noExt c (checkExpr e2)) +checkCmd l (FrameLam ps e) = do + c <- checkCommand e + return $ HsCmdLam noExt $ + mkMatchGroup FromSource + [cL l $ Match { m_ext = noExt + , m_ctxt = LambdaExpr + , m_pats = ps + , m_grhss = unguardedGRHSs c }] +checkCmd _ (FramePar e) = checkCommand e >>= (\c -> return $ HsCmdPar noExt c) -checkCmd _ (HsCase _ e mg) = - checkCmdMatchGroup mg >>= (\mg' -> return $ HsCmdCase noExt e mg') -checkCmd _ (HsIf _ cf ep et ee) = do +checkCmd _ (FrameCase e matches) = do + ms' <- mapM checkCmdMatch matches + return $ + HsCmdCase noExt (checkExpr e) $ + mkMatchGroup FromSource ms' +checkCmd _ (FrameIf ep et ee) = do pt <- checkCommand et pe <- checkCommand ee - return $ HsCmdIf noExt cf ep pt pe -checkCmd _ (HsLet _ lb e) = + return $ HsCmdIf noExt (Just noSyntaxExpr) (checkExpr ep) pt pe +checkCmd _ (FrameLet lb e) = checkCommand e >>= (\c -> return $ HsCmdLet noExt lb c) -checkCmd _ (HsDo _ DoExpr (dL->L l stmts)) = +checkCmd l (FrameDo DoExpr stmts) = mapM checkCmdLStmt stmts >>= (\ss -> return $ HsCmdDo noExt (cL l ss) ) -checkCmd _ (OpApp _ eLeft op eRight) = do +checkCmd _ (FrameOpApp eLeft op eRight) = do -- OpApp becomes a HsCmdArrForm with a (Just fixity) in it c1 <- checkCommand eLeft c2 <- checkCommand eRight let arg1 = cL (getLoc c1) $ HsCmdTop noExt c1 arg2 = cL (getLoc c2) $ HsCmdTop noExt c2 - return $ HsCmdArrForm noExt op Infix Nothing [arg1, arg2] + return $ HsCmdArrForm noExt (checkExpr op) Infix Nothing [arg1, arg2] checkCmd l e = cmdFail l e -checkCmdLStmt :: ExprLStmt GhcPs -> P (CmdLStmt GhcPs) +checkCmdLStmt :: LFrameStmt -> P (CmdLStmt GhcPs) checkCmdLStmt = locMap checkCmdStmt -checkCmdStmt :: SrcSpan -> ExprStmt GhcPs -> P (CmdStmt GhcPs) -checkCmdStmt _ (LastStmt x e s r) = - checkCommand e >>= (\c -> return $ LastStmt x c s r) -checkCmdStmt _ (BindStmt x pat e b f) = - checkCommand e >>= (\c -> return $ BindStmt x pat c b f) -checkCmdStmt _ (BodyStmt x e t g) = - checkCommand e >>= (\c -> return $ BodyStmt x c t g) -checkCmdStmt _ (LetStmt x bnds) = return $ LetStmt x bnds -checkCmdStmt _ stmt@(RecStmt { recS_stmts = stmts }) = do +checkCmdStmt :: SrcSpan -> FrameStmt -> P (CmdStmt GhcPs) +checkCmdStmt _ (FrameBindStmt pat e) = + checkCommand e >>= (\c -> return $ mkBindStmt pat c) +checkCmdStmt _ (FrameBodyStmt e) = + checkCommand e >>= (\c -> return $ mkBodyStmt c) +checkCmdStmt _ (FrameLetStmt bnds) = return $ LetStmt noExt bnds +checkCmdStmt _ (FrameRecStmt stmts) = do ss <- mapM checkCmdLStmt stmts - return $ stmt { recS_ext = noExt, recS_stmts = ss } -checkCmdStmt _ (XStmtLR _) = panic "checkCmdStmt" + return $ mkRecStmt ss checkCmdStmt l stmt = cmdStmtFail l stmt -checkCmdMatchGroup :: MatchGroup GhcPs (LHsExpr GhcPs) - -> P (MatchGroup GhcPs (LHsCmd GhcPs)) -checkCmdMatchGroup mg@(MG { mg_alts = (dL->L l ms) }) = do - ms' <- mapM (locMap $ const convert) ms - return $ mg { mg_ext = noExt - , mg_alts = cL l ms' } - where convert match@(Match { m_grhss = grhss }) = do - grhss' <- checkCmdGRHSs grhss - return $ match { m_ext = noExt, m_grhss = grhss'} - convert (XMatch _) = panic "checkCmdMatchGroup.XMatch" -checkCmdMatchGroup (XMatchGroup {}) = panic "checkCmdMatchGroup" - -checkCmdGRHSs :: GRHSs GhcPs (LHsExpr GhcPs) -> P (GRHSs GhcPs (LHsCmd GhcPs)) -checkCmdGRHSs (GRHSs x grhss binds) = do +checkCmdMatch :: LFrameMatch -> P (LMatch GhcPs (LHsCmd GhcPs)) +checkCmdMatch (dL->L l match) = + let FrameMatch ctxt pats grhss = match in + checkCmdGRHSs grhss >>= \grhss' -> + return $ cL l $ + Match { m_ext = NoExt, + m_ctxt = ctxt, + m_pats = pats, + m_grhss = grhss' } + +checkCmdGRHSs :: FrameGRHSs -> P (GRHSs GhcPs (LHsCmd GhcPs)) +checkCmdGRHSs (FrameGRHSs grhss binds) = do grhss' <- mapM checkCmdGRHS grhss - return $ GRHSs x grhss' binds -checkCmdGRHSs (XGRHSs _) = panic "checkCmdGRHSs" + return $ GRHSs noExt grhss' binds -checkCmdGRHS :: LGRHS GhcPs (LHsExpr GhcPs) -> P (LGRHS GhcPs (LHsCmd GhcPs)) +checkCmdGRHS :: LFrameGRHS -> P (LGRHS GhcPs (LHsCmd GhcPs)) checkCmdGRHS = locMap $ const convert where - convert (GRHS x stmts e) = do + convert (FrameGRHS stmts e) = do c <- checkCommand e --- cmdStmts <- mapM checkCmdLStmt stmts - return $ GRHS x {- cmdStmts -} stmts c - convert (XGRHS _) = panic "checkCmdGRHS" - + return $ GRHS noExt stmts c -cmdFail :: SrcSpan -> HsExpr GhcPs -> P a +cmdFail :: SrcSpan -> ExpPatFrame -> P a cmdFail loc e = parseErrorSDoc loc (text "Parse error in command:" <+> ppr e) -cmdStmtFail :: SrcSpan -> Stmt GhcPs (LHsExpr GhcPs) -> P a +cmdStmtFail :: SrcSpan -> FrameStmt -> P a cmdStmtFail loc e = parseErrorSDoc loc (text "Parse error in command statement:" <+> ppr e) @@ -1974,17 +1979,17 @@ checkPrecP (dL->L l (_,i)) (dL->L _ ol) , getRdrName funTyCon ] mkRecConstrOrUpdate - :: LHsExpr GhcPs + :: LExpPatFrame -> SrcSpan - -> ([LHsRecField GhcPs (LHsExpr GhcPs)], Bool) - -> P (HsExpr GhcPs) + -> ([LHsRecField GhcPs LExpPatFrame], Bool) + -> P ExpPatFrame -mkRecConstrOrUpdate (dL->L l (HsVar _ (dL->L _ c))) _ (fs,dd) +mkRecConstrOrUpdate (dL->L l (FrameVar c)) _ (fs,dd) | isRdrDataCon c - = return (mkRdrRecordCon (cL l c) (mk_rec_fields fs dd)) + = return (FrameRecordCon (cL l c) (mk_rec_fields fs dd)) mkRecConstrOrUpdate exp@(dL->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)) + | otherwise = return (FrameRecordUpd exp (map (fmap mk_rec_upd_field) fs)) mkRdrRecordUpd :: LHsExpr GhcPs -> [LHsRecUpdField GhcPs] -> HsExpr GhcPs mkRdrRecordUpd exp flds @@ -2001,7 +2006,7 @@ 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 GhcPs (LHsExpr GhcPs) -> HsRecUpdField GhcPs +mk_rec_upd_field :: HsRecField GhcPs LExpPatFrame -> FrameRecUpdField mk_rec_upd_field (HsRecField (dL->L loc (FieldOcc _ rdr)) arg pun) = HsRecField (L loc (Unambiguous noExt rdr)) arg pun mk_rec_upd_field (HsRecField (dL->L _ (XFieldOcc _)) _ _) @@ -2303,7 +2308,7 @@ parseErrorSDoc :: SrcSpan -> SDoc -> P a parseErrorSDoc span s = failSpanMsgP span s -- | Hint about bang patterns, assuming @BangPatterns@ is off. -hintBangPat :: SrcSpan -> HsExpr GhcPs -> P () +hintBangPat :: SrcSpan -> ExpPatFrame -> P () hintBangPat span e = do bang_on <- getBit BangPatBit unless bang_on $ @@ -2311,22 +2316,22 @@ hintBangPat span e = do (text "Illegal bang-pattern (use BangPatterns):" $$ ppr e) data SumOrTuple - = Sum ConTag Arity (LHsExpr GhcPs) - | Tuple [LHsTupArg GhcPs] + = Sum ConTag Arity LExpPatFrame + | Tuple [LTupArgFrame] -mkSumOrTuple :: Boxity -> SrcSpan -> SumOrTuple -> P (HsExpr GhcPs) +mkSumOrTuple :: Boxity -> SrcSpan -> SumOrTuple -> P ExpPatFrame -- Tuple -mkSumOrTuple boxity _ (Tuple es) = return (ExplicitTuple noExt es boxity) +mkSumOrTuple boxity _ (Tuple es) = return (FrameTuple es boxity) -- Sum mkSumOrTuple Unboxed _ (Sum alt arity e) = - return (ExplicitSum noExt alt arity e) + return (FrameSum alt arity e) mkSumOrTuple Boxed l (Sum alt arity (dL->L _ e)) = parseErrorSDoc l (hang (text "Boxed sums not supported:") 2 (ppr_boxed_sum alt arity e)) where - ppr_boxed_sum :: ConTag -> Arity -> HsExpr GhcPs -> SDoc + ppr_boxed_sum :: ConTag -> Arity -> ExpPatFrame -> SDoc ppr_boxed_sum alt arity e = text "(" <+> ppr_bars (alt - 1) <+> ppr e <+> ppr_bars (arity - alt) <+> text ")" -- cgit v1.2.1