summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorVladislav Zavialov <vlad.z.4096@gmail.com>2019-02-12 13:22:35 +0300
committerVladislav Zavialov <vlad.z.4096@gmail.com>2019-02-12 19:48:35 +0300
commitb71734ef7a8de2596fddc1efb785e7a42864dfc1 (patch)
treecb384f2b30297ae9149be67245ae2390821f21a2
parent8b476d822e97cfe4cebe6e74924d9a79148d608c (diff)
downloadhaskell-wip/exp-pat-frame.tar.gz
Introduce ExpPatFramewip/exp-pat-frame
Diffstat
-rw-r--r--compiler/ghc.cabal.in1
-rw-r--r--compiler/hsSyn/HsUtils.hs5
-rw-r--r--compiler/parser/ExpPatFrame.hs340
-rw-r--r--compiler/parser/Parser.y311
-rw-r--r--compiler/parser/RdrHsSyn.hs307
5 files changed, 646 insertions, 318 deletions
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 <tvs>. <type>"
]
-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 ")"
View Lorry Controller Status