import RnHsSyn
import TcRnMonad
import RnEnv
+import RnNames ( importsFromLocalDecls )
import RnTypes ( rnHsTypeFVs, rnPat, litFVs, rnOverLit, rnPatsAndThen,
- dupFieldErr, precParseErr, sectionPrecErr, patSigErr )
+ dupFieldErr, precParseErr, sectionPrecErr, patSigErr, checkTupSize )
import CmdLineOpts ( DynFlag(..), opt_IgnoreAsserts )
import BasicTypes ( Fixity(..), FixityDirection(..), IPName(..),
defaultFixity, negateFixity, compareFixity )
replicatePName, mapPName, filterPName,
crossPName, zipPName, toPName,
enumFromToPName, enumFromThenToPName, assertErrorName,
- negateName, qTyConName, monadNames, mfixName )
-import RdrName ( RdrName )
+ negateName, monadNames, mfixName )
import Name ( Name, nameOccName )
import NameSet
import UnicodeUtil ( stringToUtf8 )
************************************************************************
\begin{code}
-rnMatch :: HsMatchContext RdrName -> RdrNameMatch -> RnM (RenamedMatch, FreeVars)
+rnMatch :: HsMatchContext Name -> RdrNameMatch -> RnM (RenamedMatch, FreeVars)
rnMatch ctxt match@(Match pats maybe_rhs_sig grhss)
= addSrcLoc (getMatchLoc match) $
-- Now the main event
rnPatsAndThen ctxt pats $ \ pats' ->
- rnGRHSs grhss `thenM` \ (grhss', grhss_fvs) ->
+ rnGRHSs ctxt grhss `thenM` \ (grhss', grhss_fvs) ->
returnM (Match pats' maybe_rhs_sig' grhss', grhss_fvs `plusFV` ty_fvs)
-- The bindPatSigTyVars and rnPatsAndThen will remove the bound FVs
%************************************************************************
\begin{code}
-rnGRHSs :: RdrNameGRHSs -> RnM (RenamedGRHSs, FreeVars)
+rnGRHSs :: HsMatchContext Name -> RdrNameGRHSs -> RnM (RenamedGRHSs, FreeVars)
-rnGRHSs (GRHSs grhss binds _)
+rnGRHSs ctxt (GRHSs grhss binds _)
= rnBindsAndThen binds $ \ binds' ->
- mapFvRn rnGRHS grhss `thenM` \ (grhss', fvGRHSs) ->
+ mapFvRn (rnGRHS ctxt) grhss `thenM` \ (grhss', fvGRHSs) ->
returnM (GRHSs grhss' binds' placeHolderType, fvGRHSs)
-rnGRHS (GRHS guarded locn)
+rnGRHS ctxt (GRHS guarded locn)
= addSrcLoc locn $
doptM Opt_GlasgowExts `thenM` \ opt_GlasgowExts ->
checkM (opt_GlasgowExts || is_standard_guard guarded)
(addWarn (nonStdGuardErr guarded)) `thenM_`
- rnStmts PatGuard guarded `thenM` \ (guarded', fvs) ->
+ rnStmts (PatGuard ctxt) guarded `thenM` \ (guarded', fvs) ->
returnM (GRHS guarded' locn, fvs)
where
-- Standard Haskell 1.4 guards are just a single boolean
returnM (HsPar e', fvs_e)
-- Template Haskell extensions
-rnExpr (HsBracket br_body)
- = checkGHCI (thErr "bracket") `thenM_`
- rnBracket br_body `thenM` \ (body', fvs_e) ->
- returnM (HsBracket body', fvs_e `addOneFV` qTyConName)
- -- We use the Q tycon as a proxy to haul in all the smart
- -- constructors; see the hack in RnIfaces
-
-rnExpr (HsSplice n e)
- = checkGHCI (thErr "splice") `thenM_`
- getSrcLocM `thenM` \ loc ->
- newLocalsRn [(n,loc)] `thenM` \ [n'] ->
- rnExpr e `thenM` \ (e', fvs_e) ->
- returnM (HsSplice n' e', fvs_e)
+-- Don't ifdef-GHCI them because we want to fail gracefully
+-- (not with an rnExpr crash) in a stage-1 compiler.
+rnExpr e@(HsBracket br_body loc)
+ = addSrcLoc loc $
+ checkTH e "bracket" `thenM_`
+ rnBracket br_body `thenM` \ (body', fvs_e) ->
+ returnM (HsBracket body' loc, fvs_e `plusFV` thProxyName)
+
+rnExpr e@(HsSplice n splice loc)
+ = addSrcLoc loc $
+ checkTH e "splice" `thenM_`
+ newLocalsRn [(n,loc)] `thenM` \ [n'] ->
+ rnExpr splice `thenM` \ (splice', fvs_e) ->
+ returnM (HsSplice n' splice' loc, fvs_e `plusFV` thProxyName)
+
+rnExpr e@(HsReify (Reify flavour name))
+ = checkTH e "reify" `thenM_`
+ lookupGlobalOccRn name `thenM` \ name' ->
+ -- For now, we can only reify top-level things
+ returnM (HsReify (Reify flavour name'), unitFV name' `plusFV` thProxyName)
rnExpr section@(SectionL expr op)
= rnExpr expr `thenM` \ (expr', fvs_expr) ->
rnExpr expr `thenM` \ (expr',fvExpr) ->
returnM (HsLet binds' expr', fvExpr)
-rnExpr (HsWith expr binds is_with)
- = warnIf is_with withWarning `thenM_`
- rnExpr expr `thenM` \ (expr',fvExpr) ->
- rnIPBinds binds `thenM` \ (binds',fvBinds) ->
- returnM (HsWith expr' binds' is_with, fvExpr `plusFV` fvBinds)
-
rnExpr e@(HsDo do_or_lc stmts _ _ src_loc)
= addSrcLoc src_loc $
rnStmts do_or_lc stmts `thenM` \ (stmts', fvs) ->
-- Check the statement list ends in an expression
case last stmts' of {
ResultStmt _ _ -> returnM () ;
- _ -> addErr (doStmtListErr "do" e)
+ _ -> addErr (doStmtListErr do_or_lc e)
} `thenM_`
-- Generate the rebindable syntax for the monad
returnM (ExplicitPArr placeHolderType exps',
fvs `addOneFV` toPName `addOneFV` parrTyCon_name)
-rnExpr (ExplicitTuple exps boxity)
- = rnExprs exps `thenM` \ (exps', fvs) ->
+rnExpr e@(ExplicitTuple exps boxity)
+ = checkTupSize tup_size `thenM_`
+ rnExprs exps `thenM` \ (exps', fvs) ->
returnM (ExplicitTuple exps' boxity, fvs `addOneFV` tycon_name)
where
- tycon_name = tupleTyCon_name boxity (length exps)
+ tup_size = length exps
+ tycon_name = tupleTyCon_name boxity tup_size
rnExpr (RecordCon con_id rbinds)
= lookupOccRn con_id `thenM` \ conname ->
%************************************************************************
%* *
-\subsubsection{@rnIPBinds@s: in implicit parameter bindings} *
-%* *
-%************************************************************************
-
-\begin{code}
-rnIPBinds [] = returnM ([], emptyFVs)
-rnIPBinds ((n, expr) : binds)
- = newIPName n `thenM` \ name ->
- rnExpr expr `thenM` \ (expr',fvExpr) ->
- rnIPBinds binds `thenM` \ (binds',fvBinds) ->
- returnM ((name, expr') : binds', fvExpr `plusFV` fvBinds)
-
-\end{code}
-
-%************************************************************************
-%* *
Template Haskell brackets
%* *
%************************************************************************
returnM (TypBr t', fvs)
where
doc = ptext SLIT("In a Template-Haskell quoted type")
-rnBracket (DecBr ds) = rnSrcDecls ds `thenM` \ (tcg_env, ds', fvs) ->
- -- Discard the tcg_env; it contains the extended global RdrEnv
- -- because there is no scope that these decls cover (yet!)
- returnM (DecBr ds', fvs)
+rnBracket (DecBr group)
+ = importsFromLocalDecls group `thenM` \ (rdr_env, avails) ->
+ -- Discard avails (not useful here)
+
+ updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env gbl }) $
+
+ rnSrcDecls group `thenM` \ (tcg_env, group', fvs) ->
+ -- Discard the tcg_env; it contains only extra info about fixity
+
+ returnM (DecBr group', fvs)
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-rnStmts :: HsStmtContext
- -> [RdrNameStmt]
- -> RnM ([RenamedStmt], FreeVars)
+rnStmts :: HsStmtContext Name -> [RdrNameStmt] -> RnM ([RenamedStmt], FreeVars)
rnStmts MDoExpr stmts = rnMDoStmts stmts
rnStmts ctxt stmts = rnNormalStmts ctxt stmts
-rnNormalStmts :: HsStmtContext -> [RdrNameStmt] -> RnM ([RenamedStmt], FreeVars)
+rnNormalStmts :: HsStmtContext Name -> [RdrNameStmt] -> RnM ([RenamedStmt], FreeVars)
-- Used for cases *other* than recursive mdo
-- Implements nested scopes
+rnNormalStmts ctxt [] = returnM ([], emptyFVs)
+ -- Happens at the end of the sub-lists of a ParStmts
+
rnNormalStmts ctxt (ExprStmt expr _ src_loc : stmts)
= addSrcLoc src_loc $
rnExpr expr `thenM` \ (expr', fv_expr) ->
-- the rnPatsAndThen, but it does not matter
rnNormalStmts ctxt (LetStmt binds : stmts)
- = rnBindsAndThen binds $ \ binds' ->
- rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) ->
- returnM (LetStmt binds' : stmts', fvs)
+ = checkErr (ok ctxt binds) (badIpBinds binds) `thenM_`
+ rnBindsAndThen binds ( \ binds' ->
+ rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) ->
+ returnM (LetStmt binds' : stmts', fvs))
+ where
+ -- We do not allow implicit-parameter bindings in a parallel
+ -- list comprehension. I'm not sure what it might mean.
+ ok (ParStmtCtxt _) (IPBinds _ _) = False
+ ok _ _ = True
rnNormalStmts ctxt (ParStmt stmtss : stmts)
- = mapFvRn (rnNormalStmts ctxt) stmtss `thenM` \ (stmtss', fv_stmtss) ->
+ = mapFvRn (rnNormalStmts (ParStmtCtxt ctxt)) stmtss `thenM` \ (stmtss', fv_stmtss) ->
let
bndrss = map collectStmtsBinders stmtss'
in
err v = ptext SLIT("Duplicate binding in parallel list comprehension for:")
<+> quotes (ppr v)
-rnMDoStmts stmts
- = bindLocalsRn doc (collectStmtsBinders stmts) $ \ _ ->
- mappM rn_mdo_stmt stmts `thenM` \ segs ->
- returnM (segsToStmts (glomSegments (addFwdRefs segs)))
- where
- doc = text "In a mdo-expression"
+rnNormalStmts ctxt stmts = pprPanic "rnNormalStmts" (ppr stmts)
+\end{code}
+
+%************************************************************************
+%* *
+\subsubsection{Precedence Parsing}
+%* *
+%************************************************************************
+
+\begin{code}
type Defs = NameSet
type Uses = NameSet -- Same as FreeVars really
type FwdRefs = NameSet
[RenamedStmt])
----------------------------------------------------
+rnMDoStmts :: [RdrNameStmt] -> RnM ([RenamedStmt], FreeVars)
+rnMDoStmts stmts
+ = -- Step1: bring all the binders of the mdo into scope
+ bindLocalsRn doc (collectStmtsBinders stmts) $ \ _ ->
+
+ -- Step 2: Rename each individual stmt, making a
+ -- singleton segment. At this stage the FwdRefs field
+ -- isn't finished: it's empty for all except a BindStmt
+ -- for which it's the fwd refs within the bind itself
+ mappM rn_mdo_stmt stmts `thenM` \ segs ->
+ let
+ -- Step 3: Fill in the fwd refs.
+ -- The segments are all singletons, but their fwd-ref
+ -- field mentions all the things used by the segment
+ -- that are bound after their use
+ segs_w_fwd_refs = addFwdRefs segs
+
+ -- Step 4: Group together the segments to make bigger segments
+ -- Invariant: in the result, no segment uses a variable
+ -- bound in a later segment
+ grouped_segs = glomSegments segs_w_fwd_refs
+
+ -- Step 5: Turn the segments into Stmts
+ -- Use RecStmt when and only when there are fwd refs
+ -- Also gather up the uses from the end towards the
+ -- start, so we can tell the RecStmt which things are
+ -- used 'after' the RecStmt
+ stmts_w_fvs = segsToStmts grouped_segs
+ in
+ returnM stmts_w_fvs
+ where
+ doc = text "In a mdo-expression"
+
+----------------------------------------------------
rn_mdo_stmt :: RdrNameStmt -> RnM Segment
-- Assumes all binders are already in scope
-- Turns each stmt into a singleton Stmt
-- Add the downstream fwd refs here
----------------------------------------------------
--- Breaking a recursive 'do' into segments
+-- Glomming the singleton segments of an mdo into
+-- minimal recursive groups.
+--
+-- At first I thought this was just strongly connected components, but
+-- there's an important constraint: the order of the stmts must not change.
--
-- Consider
-- mdo { x <- ...y...
-- z <- y
-- r <- x }
--
+-- Here, the first stmt mention 'y', which is bound in the third.
+-- But that means that the innocent second stmt (p <- z) gets caught
+-- up in the recursion. And that in turn means that the binding for
+-- 'z' has to be included... and so on.
+--
-- Start at the tail { r <- x }
-- Now add the next one { z <- y ; r <- x }
-- Now add one more { q <- x ; z <- y ; r <- x }
where
(later_stmts, later_uses) = segsToStmts segs
new_stmt | non_rec = head ss
- | otherwise = RecStmt rec_names ss
+ | otherwise = RecStmt rec_names ss []
where
non_rec = isSingleton ss && isEmptyNameSet fwds
rec_names = nameSetToList (fwds `plusFV` (defs `intersectNameSet` later_uses))
= sep [ptext SLIT("Pattern syntax in expression context:"),
nest 4 (ppr e)]
-doStmtListErr name e
- = sep [quotes (text name) <+> ptext SLIT("statements must end in expression:"),
+doStmtListErr do_or_lc e
+ = sep [quotes (text binder_name) <+> ptext SLIT("statements must end in expression:"),
nest 4 (ppr e)]
-
-thErr what
- = ptext SLIT("Template Haskell") <+> text what <+>
- ptext SLIT("illegal in a stage-1 compiler")
-
-
-withWarning
- = sep [quotes (ptext SLIT("with")),
- ptext SLIT("is deprecated, use"),
- quotes (ptext SLIT("let")),
- ptext SLIT("instead")]
+ where
+ binder_name = case do_or_lc of
+ MDoExpr -> "mdo"
+ other -> "do"
+
+#ifdef GHCI
+checkTH e what = returnM () -- OK
+#else
+checkTH e what -- Raise an error in a stage-1 compiler
+ = addErr (vcat [ptext SLIT("Template Haskell") <+> text what <+>
+ ptext SLIT("illegal in a stage-1 compiler"),
+ nest 2 (ppr e)])
+#endif
+
+badIpBinds binds
+ = hang (ptext SLIT("Implicit-parameter bindings illegal in a parallel list comprehension:")) 4
+ (ppr binds)
\end{code}
projects / ghc-hetmet.git / blobdiff