methodNamesStmt (RecStmt { recS_stmts = stmts }) = methodNamesStmts stmts `addOneFV` loopAName
methodNamesStmt (LetStmt _) = emptyFVs
methodNamesStmt (ParStmt _ _ _ _) = emptyFVs
-methodNamesStmt (TransformStmt {}) = emptyFVs
-methodNamesStmt (GroupStmt {}) = emptyFVs
- -- ParStmt, TransformStmt and GroupStmt can't occur in commands, but it's not convenient to error
+methodNamesStmt (TransStmt {}) = emptyFVs
+ -- ParStmt and TransStmt can't occur in commands, but it's not convenient to error
-- here so we just do what's convenient
\end{code}
= -- Behave like do { rec { ...all but last... }; last }
do { ((stmts1, (stmts2, thing)), fvs)
<- rnStmt MDoExpr (noLoc $ mkRecStmt all_but_last) $ \ _ ->
- do { checkStmt MDoExpr True last_stmt
- ; rnStmt MDoExpr last_stmt thing_inside }
+ do { last_stmt' <- checkLastStmt MDoExpr last_stmt
+ ; rnStmt MDoExpr last_stmt' thing_inside }
; return (((stmts1 ++ stmts2), thing), fvs) }
where
Just (all_but_last, last_stmt) = snocView stmts
-rnStmts ctxt (lstmt@(L loc stmt) : lstmts) thing_inside
+rnStmts ctxt (lstmt@(L loc _) : lstmts) thing_inside
| null lstmts
= setSrcSpan loc $
- do { -- Turn a final ExprStmt into a LastStmt
- -- This is the first place it's convenient to do this
- -- (In principle the parser could do it, but it's
- -- just not very convenient to do so.)
- let stmt' | okEmpty ctxt
- = lstmt
- | otherwise
- = case stmt of
- ExprStmt e _ _ _ -> L loc (mkLastStmt e)
- _ -> lstmt
- ; checkStmt ctxt True {- last stmt -} stmt'
- ; rnStmt ctxt stmt' thing_inside }
+ do { lstmt' <- checkLastStmt ctxt lstmt
+ ; rnStmt ctxt lstmt' thing_inside }
| otherwise
= do { ((stmts1, (stmts2, thing)), fvs)
<- setSrcSpan loc $
- do { checkStmt ctxt False {- Not last -} lstmt
+ do { checkStmt ctxt lstmt
; rnStmt ctxt lstmt $ \ bndrs1 ->
rnStmts ctxt lstmts $ \ bndrs2 ->
thing_inside (bndrs1 ++ bndrs2) }
; return ( ([L loc (ParStmt segs' mzip_op bind_op return_op)], thing)
, fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) }
-rnStmt ctxt (L loc (TransformStmt stmts _ using by _ _)) thing_inside
- = do { (using', fvs1) <- rnLExpr using
-
- ; ((stmts', (by', used_bndrs, thing)), fvs2)
- <- rnStmts (TransformStmtCtxt ctxt) stmts $ \ bndrs ->
- do { (by', fvs_by) <- case by of
- Nothing -> return (Nothing, emptyFVs)
- Just e -> do { (e', fvs) <- rnLExpr e; return (Just e', fvs) }
- ; (thing, fvs_thing) <- thing_inside bndrs
- ; let fvs = fvs_by `plusFV` fvs_thing
- used_bndrs = filter (`elemNameSet` fvs) bndrs
- -- The paper (Fig 5) has a bug here; we must treat any free varaible of
- -- the "thing inside", **or of the by-expression**, as used
- ; return ((by', used_bndrs, thing), fvs) }
-
- -- Lookup `(>>=)` and `fail` for monad comprehensions
- ; ((return_op, fvs3), (bind_op, fvs4)) <-
- if isMonadCompExpr ctxt
- then (,) <$> lookupSyntaxName returnMName
- <*> lookupSyntaxName bindMName
- else return ( (noSyntaxExpr, emptyFVs)
- , (noSyntaxExpr, emptyFVs) )
-
- ; return (([L loc (TransformStmt stmts' used_bndrs using' by' return_op bind_op)], thing),
- fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) }
-
-rnStmt ctxt (L loc (GroupStmt { grpS_stmts = stmts, grpS_by = by, grpS_explicit = explicit
- , grpS_using = using })) thing_inside
+rnStmt ctxt (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = form
+ , trS_using = using })) thing_inside
= do { -- Rename the 'using' expression in the context before the transform is begun
let implicit_name | isMonadCompExpr ctxt = groupMName
| otherwise = groupWithName
- ; (using', fvs1) <- if explicit
- then rnLExpr using
- else do { (e,fvs) <- lookupSyntaxName implicit_name
- ; return (noLoc e, fvs) }
+ ; (using', fvs1) <- case form of
+ GroupFormB -> do { (e,fvs) <- lookupSyntaxName implicit_name
+ ; return (noLoc e, fvs) }
+ _ -> rnLExpr using
-- Rename the stmts and the 'by' expression
-- Keep track of the variables mentioned in the 'by' expression
; (thing, fvs_thing) <- thing_inside bndrs
; let fvs = fvs_by `plusFV` fvs_thing
used_bndrs = filter (`elemNameSet` fvs) bndrs
+ -- The paper (Fig 5) has a bug here; we must treat any free varaible of
+ -- the "thing inside", **or of the by-expression**, as used
; return ((by', used_bndrs, thing), fvs) }
-- Lookup `return`, `(>>=)` and `liftM` for monad comprehensions
- ; ((return_op, fvs3), (bind_op, fvs4), (fmap_op, fvs5)) <-
- if isMonadCompExpr ctxt
- then (,,) <$> lookupSyntaxName returnMName
- <*> lookupSyntaxName bindMName
- <*> lookupSyntaxName fmapName
- else return ( (noSyntaxExpr, emptyFVs)
- , (noSyntaxExpr, emptyFVs)
- , (noSyntaxExpr, emptyFVs) )
-
- ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4
- `plusFV` fvs5
+ ; (return_op, fvs3) <- lookupSyntaxName returnMName
+ ; (bind_op, fvs4) <- lookupSyntaxName bindMName
+ ; (fmap_op, fvs5) <- case form of
+ ThenForm -> return (noSyntaxExpr, emptyFVs)
+ _ -> lookupSyntaxName fmapName
+
+ ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3
+ `plusFV` fvs4 `plusFV` fvs5
bndr_map = used_bndrs `zip` used_bndrs
- -- See Note [GroupStmt binder map] in HsExpr
+ -- See Note [TransStmt binder map] in HsExpr
; traceRn (text "rnStmt: implicitly rebound these used binders:" <+> ppr bndr_map)
- ; return (([L loc (GroupStmt { grpS_stmts = stmts', grpS_bndrs = bndr_map
- , grpS_by = by', grpS_using = using', grpS_explicit = explicit
- , grpS_ret = return_op, grpS_bind = bind_op
- , grpS_fmap = fmap_op })], thing), all_fvs) }
+ ; return (([L loc (TransStmt { trS_stmts = stmts', trS_bndrs = bndr_map
+ , trS_by = by', trS_using = using', trS_form = form
+ , trS_ret = return_op, trS_bind = bind_op
+ , trS_fmap = fmap_op })], thing), all_fvs) }
type ParSeg id = ([LStmt id], [id]) -- The Names are bound by the Stmts
rn_rec_stmt_lhs _ stmt@(L _ (ParStmt _ _ _ _)) -- Syntactically illegal in mdo
= pprPanic "rn_rec_stmt" (ppr stmt)
-rn_rec_stmt_lhs _ stmt@(L _ (TransformStmt {})) -- Syntactically illegal in mdo
- = pprPanic "rn_rec_stmt" (ppr stmt)
-
-rn_rec_stmt_lhs _ stmt@(L _ (GroupStmt {})) -- Syntactically illegal in mdo
+rn_rec_stmt_lhs _ stmt@(L _ (TransStmt {})) -- Syntactically illegal in mdo
= pprPanic "rn_rec_stmt" (ppr stmt)
rn_rec_stmt_lhs _ (L _ (LetStmt EmptyLocalBinds))
rn_rec_stmt _ stmt@(L _ (ParStmt {})) _ -- Syntactically illegal in mdo
= pprPanic "rn_rec_stmt: ParStmt" (ppr stmt)
-rn_rec_stmt _ stmt@(L _ (TransformStmt {})) _ -- Syntactically illegal in mdo
- = pprPanic "rn_rec_stmt: TransformStmt" (ppr stmt)
-
-rn_rec_stmt _ stmt@(L _ (GroupStmt {})) _ -- Syntactically illegal in mdo
- = pprPanic "rn_rec_stmt: GroupStmt" (ppr stmt)
+rn_rec_stmt _ stmt@(L _ (TransStmt {})) _ -- Syntactically illegal in mdo
+ = pprPanic "rn_rec_stmt: TransStmt" (ppr stmt)
rn_rec_stmt _ (L _ (LetStmt EmptyLocalBinds)) _
= panic "rn_rec_stmt: LetStmt EmptyLocalBinds"
checkEmptyStmts ctxt
= unless (okEmpty ctxt) (addErr (emptyErr ctxt))
-okEmpty :: HsStmtContext Name -> Bool
+okEmpty :: HsStmtContext a -> Bool
okEmpty (PatGuard {}) = True
okEmpty _ = False
emptyErr ctxt = ptext (sLit "Empty") <+> pprStmtContext ctxt
----------------------
+checkLastStmt :: HsStmtContext Name
+ -> LStmt RdrName
+ -> RnM (LStmt RdrName)
+checkLastStmt ctxt lstmt@(L loc stmt)
+ = case ctxt of
+ ListComp -> check_comp
+ MonadComp -> check_comp
+ PArrComp -> check_comp
+ DoExpr -> check_do
+ MDoExpr -> check_do
+ _ -> check_other
+ where
+ check_do -- Expect ExprStmt, and change it to LastStmt
+ = case stmt of
+ ExprStmt e _ _ _ -> return (L loc (mkLastStmt e))
+ LastStmt {} -> return lstmt -- "Deriving" clauses may generate a
+ -- LastStmt directly (unlike the parser)
+ _ -> do { addErr (hang last_error 2 (ppr stmt)); return lstmt }
+ last_error = (ptext (sLit "The last statement in") <+> pprAStmtContext ctxt
+ <+> ptext (sLit "must be an expression"))
+
+ check_comp -- Expect LastStmt; this should be enforced by the parser!
+ = case stmt of
+ LastStmt {} -> return lstmt
+ _ -> pprPanic "checkLastStmt" (ppr lstmt)
+
+ check_other -- Behave just as if this wasn't the last stmt
+ = do { checkStmt ctxt lstmt; return lstmt }
+
-- Checking when a particular Stmt is ok
checkStmt :: HsStmtContext Name
- -> Bool -- True <=> this is the last Stmt in the sequence
-> LStmt RdrName
-> RnM ()
-checkStmt ctxt is_last (L _ stmt)
+checkStmt ctxt (L _ stmt)
= do { dflags <- getDOpts
- ; case okStmt dflags ctxt is_last stmt of
+ ; case okStmt dflags ctxt stmt of
Nothing -> return ()
Just extra -> addErr (msg $$ extra) }
where
, ptext (sLit "in") <+> pprAStmtContext ctxt ]
pprStmtCat :: Stmt a -> SDoc
-pprStmtCat (TransformStmt {}) = ptext (sLit "transform")
-pprStmtCat (GroupStmt {}) = ptext (sLit "group")
+pprStmtCat (TransStmt {}) = ptext (sLit "transform")
pprStmtCat (LastStmt {}) = ptext (sLit "return expression")
pprStmtCat (ExprStmt {}) = ptext (sLit "exprssion")
pprStmtCat (BindStmt {}) = ptext (sLit "binding")
isOK = Nothing
notOK = Just empty
-okStmt, okDoStmt, okCompStmt :: DynFlags -> HsStmtContext Name -> Bool
+okStmt, okDoStmt, okCompStmt :: DynFlags -> HsStmtContext Name
-> Stmt RdrName -> Maybe SDoc
-- Return Nothing if OK, (Just extra) if not ok
-- The "extra" is an SDoc that is appended to an generic error message
-okStmt _ (PatGuard {}) _ stmt
+okStmt _ (PatGuard {}) stmt
= case stmt of
ExprStmt {} -> isOK
BindStmt {} -> isOK
LetStmt {} -> isOK
_ -> notOK
-okStmt dflags (ParStmtCtxt ctxt) _ stmt
+okStmt dflags (ParStmtCtxt ctxt) stmt
= case stmt of
LetStmt (HsIPBinds {}) -> notOK
- _ -> okStmt dflags ctxt False stmt
- -- NB: is_last=False in recursive
- -- call; the branches of of a Par
- -- not finish with a LastStmt
+ _ -> okStmt dflags ctxt stmt
-okStmt dflags (TransformStmtCtxt ctxt) _ stmt
- = okStmt dflags ctxt False stmt
+okStmt dflags (TransformStmtCtxt ctxt) stmt
+ = okStmt dflags ctxt stmt
-okStmt dflags ctxt is_last stmt
- | isDoExpr ctxt = okDoStmt dflags ctxt is_last stmt
- | isListCompExpr ctxt = okCompStmt dflags ctxt is_last stmt
+okStmt dflags ctxt stmt
+ | isDoExpr ctxt = okDoStmt dflags ctxt stmt
+ | isListCompExpr ctxt = okCompStmt dflags ctxt stmt
| otherwise = pprPanic "okStmt" (pprStmtContext ctxt)
----------------
-okDoStmt dflags ctxt is_last stmt
- | is_last
- = case stmt of
- LastStmt {} -> isOK
- _ -> Just (ptext (sLit "The last statement in") <+> pprAStmtContext ctxt
- <+> ptext (sLit "must be an expression"))
-
- | otherwise
+okDoStmt dflags _ stmt
= case stmt of
RecStmt {}
| Opt_DoRec `xopt` dflags -> isOK
----------------
-okCompStmt dflags _ is_last stmt
- | is_last
- = case stmt of
- LastStmt {} -> Nothing
- _ -> pprPanic "Unexpected stmt" (ppr stmt) -- Not a user error
-
- | otherwise
+okCompStmt dflags _ stmt
= case stmt of
BindStmt {} -> isOK
LetStmt {} -> isOK
ParStmt {}
| Opt_ParallelListComp `xopt` dflags -> isOK
| otherwise -> Just (ptext (sLit "Use -XParallelListComp"))
- TransformStmt {}
- | Opt_TransformListComp `xopt` dflags -> isOK
- | otherwise -> Just (ptext (sLit "Use -XTransformListComp"))
- GroupStmt {}
+ TransStmt {}
| Opt_TransformListComp `xopt` dflags -> isOK
| otherwise -> Just (ptext (sLit "Use -XTransformListComp"))
LastStmt {} -> notOK
projects / ghc-hetmet.git / blobdiff