emptyNameSet, unitNameSet, mkNameSet, unionNameSets, unionManyNameSets,
minusNameSet, elemNameSet, nameSetToList, addOneToNameSet, addListToNameSet,
delFromNameSet, delListFromNameSet, isEmptyNameSet, foldNameSet, filterNameSet,
+ intersectsNameSet, intersectNameSet,
-- Free variables
FreeVars, isEmptyFVs, emptyFVs, plusFVs, plusFV,
delListFromNameSet :: NameSet -> [Name] -> NameSet
foldNameSet :: (Name -> b -> b) -> b -> NameSet -> b
filterNameSet :: (Name -> Bool) -> NameSet -> NameSet
+intersectNameSet :: NameSet -> NameSet -> NameSet
+intersectsNameSet :: NameSet -> NameSet -> Bool -- True if non-empty intersection
+ -- (s1 `intersectsVarSet` s2) doesn't compute s2 if s1 is empty
isEmptyNameSet = isEmptyUniqSet
emptyNameSet = emptyUniqSet
delFromNameSet = delOneFromUniqSet
foldNameSet = foldUniqSet
filterNameSet = filterUniqSet
+intersectNameSet = intersectUniqSets
delListFromNameSet set ns = foldl delFromNameSet set ns
+
+intersectsNameSet s1 s2 = not (isEmptyNameSet (s1 `intersectNameSet` s2))
\end{code}
import DsMonad
import CoreUtils ( exprType, mkCoerce2 )
-import Id ( Id, mkWildId, idType )
+import Id ( Id, mkWildId )
import MkId ( mkFCallId, realWorldPrimId, mkPrimOpId )
import Maybes ( maybeToBool )
import ForeignCall ( ForeignCall(..), CCallSpec(..), CCallTarget(..), Safety, CCallConv(..) )
import TcType ( tcSplitTyConApp_maybe )
import Type ( Type, isUnLiftedType, mkFunTys, mkFunTy,
tyVarsOfType, mkForAllTys, mkTyConApp,
- isPrimitiveType, eqType,
- splitTyConApp_maybe, splitNewType_maybe
+ isPrimitiveType, splitTyConApp_maybe, splitNewType_maybe
)
import PrimOp ( PrimOp(..) )
-import TysPrim ( realWorldStatePrimTy,
- byteArrayPrimTyCon, mutableByteArrayPrimTyCon,
- intPrimTy, foreignObjPrimTy
+import TysPrim ( realWorldStatePrimTy, intPrimTy,
+ byteArrayPrimTyCon, mutableByteArrayPrimTyCon
)
import TyCon ( TyCon, tyConDataCons )
import TysWiredIn ( unitDataConId,
import HsSyn ( failureFreePat,
HsExpr(..), Pat(..), HsLit(..), ArithSeqInfo(..),
- Stmt(..), HsMatchContext(..), HsDoContext(..),
+ Stmt(..), HsMatchContext(..), HsStmtContext(..),
Match(..), HsBinds(..), MonoBinds(..), HsConDetails(..),
- mkSimpleMatch
+ mkSimpleMatch, isDoExpr
)
import TcHsSyn ( TypecheckedHsExpr, TypecheckedHsBinds, TypecheckedStmt, hsPatType )
-- Sigh. This is a pain.
import TcType ( tcSplitAppTy, tcSplitFunTys, tcTyConAppArgs,
- tcSplitTyConApp, isUnLiftedType, Type )
+ tcSplitTyConApp, isUnLiftedType, Type,
+ mkAppTy )
import Type ( splitFunTys )
import CoreSyn
import CoreUtils ( exprType, mkIfThenElse, bindNonRec )
import DataCon ( DataCon, dataConWrapId, dataConFieldLabels, dataConInstOrigArgTys )
import DataCon ( isExistentialDataCon )
import TyCon ( tyConDataCons )
-import TysWiredIn ( tupleCon )
+import TysWiredIn ( tupleCon, mkTupleTy )
import BasicTypes ( RecFlag(..), Boxity(..), ipNameName )
import PrelNames ( toPName )
+import SrcLoc ( noSrcLoc )
import Util ( zipEqual, zipWithEqual )
import Outputable
import FastString
where
(_, [elt_ty]) = tcSplitTyConApp result_ty
-dsExpr (HsDo DoExpr stmts ids result_ty src_loc)
+dsExpr (HsDo do_or_lc stmts ids result_ty src_loc)
+ | isDoExpr do_or_lc
= putSrcLocDs src_loc $
- dsDo DoExpr stmts ids result_ty
+ dsDo do_or_lc stmts ids result_ty
dsExpr (HsDo PArrComp stmts _ result_ty src_loc)
= -- Special case for array comprehensions
Basically does the translation given in the Haskell~1.3 report:
\begin{code}
-dsDo :: HsDoContext
+dsDo :: HsStmtContext
-> [TypecheckedStmt]
- -> [Id] -- id for: [return,fail,>>=,>>]
+ -> [Id] -- id for: [return,fail,>>=,>>] and possibly mfixName
-> Type -- Element type; the whole expression has type (m t)
-> DsM CoreExpr
-dsDo do_or_lc stmts ids@[return_id, fail_id, bind_id, then_id] result_ty
+dsDo do_or_lc stmts ids result_ty
= let
- (_, b_ty) = tcSplitAppTy result_ty -- result_ty must be of the form (m b)
- is_do = case do_or_lc of
- DoExpr -> True
- _ -> False
+ (return_id : fail_id : bind_id : then_id : _) = ids
+ (m_ty, b_ty) = tcSplitAppTy result_ty -- result_ty must be of the form (m b)
+ is_do = isDoExpr do_or_lc -- True for both MDo and Do
-- For ExprStmt, see the comments near HsExpr.Stmt about
-- exactly what ExprStmts mean!
, mkSimpleMatch [WildPat a_ty] fail_expr result_ty locn
]
in
- matchWrapper (DoCtxt do_or_lc) the_matches `thenDs` \ (binders, matching_code) ->
+ matchWrapper (StmtCtxt do_or_lc) the_matches `thenDs` \ (binders, matching_code) ->
returnDs (mkApps (Var bind_id) [Type a_ty, Type b_ty, expr2,
mkLams binders matching_code])
+
+ go (RecStmt rec_vars rec_stmts : stmts)
+ = go (bind_stmt : stmts)
+ where
+ bind_stmt = dsRecStmt m_ty ids rec_vars rec_stmts
+
in
go stmts
where
do_expr expr locn = putSrcLocDs locn (dsExpr expr)
\end{code}
+
+Translation for RecStmt's:
+-----------------------------
+We turn (RecStmt [v1,..vn] stmts) into:
+
+ (v1,..,vn) <- mfix (\~(v1,..vn). do stmts
+ return (v1,..vn))
+
+\begin{code}
+dsRecStmt :: Type -- Monad type constructor :: * -> *
+ -> [Id] -- Ids for: [return,fail,>>=,>>,mfix]
+ -> [Id] -> [TypecheckedStmt] -- Guts of the RecStmt
+ -> TypecheckedStmt
+dsRecStmt m_ty ids@[return_id, _, _, _, mfix_id] vars stmts
+ = BindStmt tup_pat mfix_app noSrcLoc
+ where
+ (var1:rest) = vars -- Always at least one
+ one_var = null rest
+
+ mfix_app = HsApp (TyApp (HsVar mfix_id) [tup_ty]) mfix_arg
+ mfix_arg = HsLam (mkSimpleMatch [tup_pat] body tup_ty noSrcLoc)
+
+ tup_expr | one_var = HsVar var1
+ | otherwise = ExplicitTuple (map HsVar vars) Boxed
+ tup_ty | one_var = idType var1
+ | otherwise = mkTupleTy Boxed (length vars) (map idType vars)
+ tup_pat | one_var = VarPat var1
+ | otherwise = LazyPat (TuplePat (map VarPat vars) Boxed)
+
+ body = HsDo DoExpr (stmts ++ [return_stmt])
+ ids -- Don't need the mfix, but it does no harm
+ (mkAppTy m_ty tup_ty)
+ noSrcLoc
+
+ return_stmt = ResultStmt return_app noSrcLoc
+ return_app = HsApp (TyApp (HsVar return_id) [tup_ty]) tup_expr
+\end{code}
import BasicTypes ( Boxity(..) )
import TyCon ( tyConName )
import HsSyn ( Pat(..), HsExpr(..), Stmt(..),
- HsMatchContext(..), HsDoContext(..),
+ HsMatchContext(..), HsStmtContext(..),
collectHsBinders )
import TcHsSyn ( TypecheckedStmt, TypecheckedPat, TypecheckedHsExpr,
hsPatType )
letrec_body = App (Var h) core_list1
in
deListComp quals core_fail `thenDs` \ rest_expr ->
- matchSimply (Var u2) (DoCtxt ListComp) pat
+ matchSimply (Var u2) (StmtCtxt ListComp) pat
rest_expr core_fail `thenDs` \ core_match ->
let
rhs = Lam u1 $
dfListComp c_id b quals `thenDs` \ core_rest ->
-- build the pattern match
- matchSimply (Var x) (DoCtxt ListComp)
+ matchSimply (Var x) (StmtCtxt ListComp)
pat core_rest (Var b) `thenDs` \ core_expr ->
-- now build the outermost foldr, and return
true = Var trueId
in
newSysLocalDs ty'ce `thenDs` \v ->
- matchSimply (Var v) (DoCtxt PArrComp) p true false `thenDs` \pred ->
+ matchSimply (Var v) (StmtCtxt PArrComp) p true false `thenDs` \pred ->
let cef = mkApps (Var filterP) [Type ty'ce, mkLams [v] pred, ce]
ty'cef = ty'ce -- filterP preserves the type
pa' = TuplePat [pa, p] Boxed
errMsg = "DsListComp.dePArrComp: internal error!"
in
mkErrorAppDs pAT_ERROR_ID errTy errMsg `thenDs` \cerr ->
- matchSimply (Var v) (DoCtxt PArrComp) pa projBody cerr `thenDs` \ccase ->
+ matchSimply (Var v) (StmtCtxt PArrComp) pa projBody cerr `thenDs` \ccase ->
let pa' = TuplePat [pa, TuplePat (map VarPat xs) Boxed] Boxed
proj = mkLams [v] ccase
in
errMsg = "DsListComp.deLambda: internal error!"
in
mkErrorAppDs pAT_ERROR_ID errTy errMsg `thenDs` \cerr ->
- matchSimply (Var v) (DoCtxt PArrComp) p ce cerr `thenDs` \res ->
+ matchSimply (Var v) (StmtCtxt PArrComp) p ce cerr `thenDs` \res ->
returnDs (mkLams [v] res, errTy)
-- obtain the element type of the parallel array produced by the given Core
import HsSyn ( Pat(..), HsExpr(..), Stmt(..), HsLit(..), HsOverLit(..),
Match(..), GRHSs(..), GRHS(..), HsBracket(..),
- HsDoContext(ListComp,DoExpr), ArithSeqInfo(..),
+ HsStmtContext(ListComp,DoExpr), ArithSeqInfo(..),
HsBinds(..), MonoBinds(..), HsConDetails(..),
HsDecl(..), TyClDecl(..), ForeignDecl(..),
PendingSplice,
placeHolderType, tyClDeclNames,
- collectHsBinders, collectMonoBinders,
+ collectHsBinders,
collectPatBinders, collectPatsBinders
)
import HsSyn as Hs
( HsExpr(..), HsLit(..), ArithSeqInfo(..),
- HsDoContext(..),
+ HsStmtContext(..),
Match(..), GRHSs(..), GRHS(..), HsPred(..),
HsDecl(..), TyClDecl(..), InstDecl(..), ConDecl(..),
Stmt(..), HsBinds(..), MonoBinds(..), Sig(..),
\begin{code}
okBindSig :: NameSet -> Sig Name -> Bool
-okBindSig ns (ClassOpSig _ _ _ _) = False
-okBindSig ns sig = sigForThisGroup ns sig
+okBindSig ns (ClassOpSig _ _ _ _) = False
+okBindSig ns sig = sigForThisGroup ns sig
okClsDclSig :: NameSet -> Sig Name -> Bool
-okClsDclSig ns (Sig _ _ _) = False
-okClsDclSig ns sig = sigForThisGroup ns sig
+okClsDclSig ns (Sig _ _ _) = False
+okClsDclSig ns sig = sigForThisGroup ns sig
okInstDclSig :: NameSet -> Sig Name -> Bool
-okInstDclSig ns (Sig _ _ _) = False
-okInstDclSig ns (FixSig _) = False
-okInstDclSig ns (SpecInstSig _ _) = True
-okInstDclSig ns sig = sigForThisGroup ns sig
+okInstDclSig ns (Sig _ _ _) = False
+okInstDclSig ns (FixSig _) = False
+okInstDclSig ns (SpecInstSig _ _) = True
+okInstDclSig ns sig = sigForThisGroup ns sig
sigForThisGroup ns sig
= case sigName sig of
Bool -- True <=> this was a 'with' binding
-- (tmp, until 'with' is removed)
- | HsDo HsDoContext
+ | HsDo HsStmtContext
[Stmt id] -- "do":one or more stmts
[id] -- Ids for [return,fail,>>=,>>]
-- Brutal but simple
| ResultStmt (HsExpr id) SrcLoc -- See notes that follow
| ExprStmt (HsExpr id) PostTcType SrcLoc -- See notes that follow
-- The type is the *element type* of the expression
- | ParStmt [[Stmt id]] -- List comp only: parallel set of quals
- | ParStmtOut [([id], [Stmt id])] -- PLC after renaming; the ids are the binders
- -- bound by the stmts
+
+ -- ParStmts only occur in a list comprehension
+ | ParStmt [[Stmt id]] -- List comp only: parallel set of quals
+ | ParStmtOut [([id], [Stmt id])] -- PLC after renaming; the ids are the binders
+ -- bound by the stmts
+
+ -- mdo-notation (only exists after renamer)
+ -- The ids are a subset of the variables bound by the stmts that
+ -- either (a) are used before they are bound in the stmts
+ -- or (b) are used in stmts that follow the RecStmt
+ | RecStmt [id]
+ [Stmt id]
\end{code}
ExprStmts and ResultStmts are a bit tricky, because what they mean
= hsep (map (\stmts -> ptext SLIT("| ") <> ppr stmts) stmtss)
pprStmt (ParStmtOut stmtss)
= hsep (map (\stmts -> ptext SLIT("| ") <> ppr stmts) stmtss)
+pprStmt (RecStmt _ segment) = vcat (map ppr segment)
-pprDo :: OutputableBndr id => HsDoContext -> [Stmt id] -> SDoc
+pprDo :: OutputableBndr id => HsStmtContext -> [Stmt id] -> SDoc
pprDo DoExpr stmts = hang (ptext SLIT("do")) 2 (vcat (map ppr stmts))
+pprDo MDoExpr stmts = hang (ptext SLIT("mdo")) 3 (vcat (map ppr stmts))
pprDo ListComp stmts = pprComp brackets stmts
pprDo PArrComp stmts = pprComp pa_brackets stmts
\begin{code}
data HsMatchContext id -- Context of a Match or Stmt
- = DoCtxt HsDoContext -- Do-stmt or list comprehension
+ = StmtCtxt HsStmtContext -- Do-stmt or list comprehension
| FunRhs id -- Function binding for f
| CaseAlt -- Guard on a case alternative
| LambdaExpr -- Lambda
| RecUpd -- Record update
deriving ()
-data HsDoContext = ListComp
- | DoExpr
- | PArrComp -- parallel array comprehension
+data HsStmtContext
+ = ListComp
+ | DoExpr
+ | MDoExpr -- recursive do-expression
+ | PArrComp -- parallel array comprehension
+ | PatGuard -- Never occurs in an HsDo expression, of course
\end{code}
\begin{code}
-isDoExpr (DoCtxt DoExpr) = True
-isDoExpr other = False
+isDoExpr DoExpr = True
+isDoExpr MDoExpr = True
+isDoExpr other = False
\end{code}
\begin{code}
matchSeparator CaseAlt = ptext SLIT("->")
matchSeparator LambdaExpr = ptext SLIT("->")
matchSeparator PatBindRhs = ptext SLIT("=")
-matchSeparator (DoCtxt _) = ptext SLIT("<-")
+matchSeparator (StmtCtxt _) = ptext SLIT("<-")
matchSeparator RecUpd = panic "When is this used?"
\end{code}
pprMatchContext RecUpd = ptext SLIT("In a record-update construct")
pprMatchContext PatBindRhs = ptext SLIT("In a pattern binding")
pprMatchContext LambdaExpr = ptext SLIT("In a lambda abstraction")
-pprMatchContext (DoCtxt DoExpr) = ptext SLIT("In a 'do' expression pattern binding")
-pprMatchContext (DoCtxt ListComp) =
- ptext SLIT("In a 'list comprehension' pattern binding")
-pprMatchContext (DoCtxt PArrComp) =
- ptext SLIT("In an 'array comprehension' pattern binding")
+pprMatchContext (StmtCtxt ctxt) = pprStmtCtxt ctxt
+
+pprStmtCtxt PatGuard = ptext SLIT("In a pattern guard")
+pprStmtCtxt DoExpr = ptext SLIT("In a 'do' expression pattern binding")
+pprStmtCtxt MDoExpr = ptext SLIT("In an 'mdo' expression pattern binding")
+pprStmtCtxt ListComp = ptext SLIT("In a 'list comprehension' pattern binding")
+pprStmtCtxt PArrComp = ptext SLIT("In an 'array comprehension' pattern binding")
-- Used to generate the string for a *runtime* error message
matchContextErrString (FunRhs fun) = "function " ++ showSDoc (ppr fun)
matchContextErrString CaseAlt = "case"
matchContextErrString PatBindRhs = "pattern binding"
matchContextErrString RecUpd = "record update"
-matchContextErrString LambdaExpr = "lambda"
-matchContextErrString (DoCtxt DoExpr) = "'do' expression"
-matchContextErrString (DoCtxt ListComp) = "list comprehension"
-matchContextErrString (DoCtxt PArrComp) = "array comprehension"
+matchContextErrString LambdaExpr = "lambda"
+matchContextErrString (StmtCtxt PatGuard) = "pattern gaurd"
+matchContextErrString (StmtCtxt DoExpr) = "'do' expression"
+matchContextErrString (StmtCtxt MDoExpr) = "'mdo' expression"
+matchContextErrString (StmtCtxt ListComp) = "list comprehension"
+matchContextErrString (StmtCtxt PArrComp) = "array comprehension"
\end{code}
collectHsBinders, collectLocatedHsBinders,
collectMonoBinders, collectLocatedMonoBinders,
- collectSigTysFromMonoBinds,
+ collectSigTysFromHsBinds, collectSigTysFromMonoBinds,
hsModule, hsImports
) where
go (AndMonoBinds bs1 bs2) acc = go bs1 (go bs2 acc)
\end{code}
-%************************************************************************
-%* *
-\subsection{Getting patterns out of bindings}
-%* *
-%************************************************************************
-
Get all the pattern type signatures out of a bunch of bindings
\begin{code}
+collectSigTysFromHsBinds :: HsBinds name -> [HsType name]
+collectSigTysFromHsBinds EmptyBinds = []
+collectSigTysFromHsBinds (MonoBind b _ _) = collectSigTysFromMonoBinds b
+collectSigTysFromHsBinds (ThenBinds b1 b2) = collectSigTysFromHsBinds b1 ++
+ collectSigTysFromHsBinds b2
+
+
collectSigTysFromMonoBinds :: MonoBinds name -> [HsType name]
collectSigTysFromMonoBinds bind
= go bind []
go_matches (match : matches) acc = go_matches matches acc
\end{code}
+\begin{code}
+collectStmtsBinders :: [Stmt id] -> [id]
+collectStmtsBinders = concatMap collectStmtBinders
+
+collectStmtBinders :: Stmt id -> [id]
+ -- Id Binders for a Stmt... [but what about pattern-sig type vars]?
+collectStmtBinders (BindStmt pat _ _) = collectPatBinders pat
+collectStmtBinders (LetStmt binds) = collectHsBinders binds
+collectStmtBinders (ExprStmt _ _ _) = []
+collectStmtBinders (ResultStmt _ _) = []
+collectStmtBinders other = panic "collectStmtBinders"
+\end{code}
+
import CmdLineOpts
import Id ( idType, idInfo, isImplicitId, idCgInfo )
-import DataCon ( dataConWorkId, dataConSig, dataConFieldLabels, dataConStrictMarks )
+import DataCon ( dataConSig, dataConFieldLabels, dataConStrictMarks )
import IdInfo -- Lots
import CoreSyn ( CoreRule(..), IdCoreRule )
import CoreFVs ( ruleLhsFreeNames )
| ITccallconv
| ITdotnet
| ITccall (Bool,Bool,Safety) -- (is_dyn, is_casm, may_gc)
+ | ITmdo
| ITspecialise_prag -- Pragmas
| ITsource_prag
isSpecial ITwith = True
isSpecial ITccallconv = True
isSpecial ITstdcallconv = True
+isSpecial ITmdo = True
isSpecial _ = False
-- the bitmap provided as the third component indicates whether the
( "threadsafe", ITthreadsafe, bit ffiBit),
( "unsafe", ITunsafe, bit ffiBit),
( "with", ITwith, bit withBit),
+ ( "mdo", ITmdo, bit glaExtsBit),
( "stdcall", ITstdcallconv, bit ffiBit),
( "ccall", ITccallconv, bit ffiBit),
( "dotnet", ITdotnet, bit ffiBit),
, checkPattern -- HsExp -> P HsPat
, checkPatterns -- SrcLoc -> [HsExp] -> P [HsPat]
, checkDo -- [Stmt] -> P [Stmt]
+ , checkMDo -- [Stmt] -> P [Stmt]
, checkValDef -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
, checkValSig -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
) where
-- as [ExprStmt e1, ExprStmt e2]
-- checkDo (a) checks that the last thing is an ExprStmt
-- (b) transforms it to a ResultStmt
+-- same comments apply for mdo as well
-checkDo [] = parseError "Empty 'do' construct"
-checkDo [ExprStmt e _ l] = returnP [ResultStmt e l]
-checkDo [s] = parseError "The last statement in a 'do' construct must be an expression"
-checkDo (s:ss) = checkDo ss `thenP` \ ss' ->
- returnP (s:ss')
+checkDo = checkDoMDo "a " "'do'"
+checkMDo = checkDoMDo "an " "'mdo'"
+
+checkDoMDo _ nm [] = parseError $ "Empty " ++ nm ++ " construct"
+checkDoMDo _ _ [ExprStmt e _ l] = returnP [ResultStmt e l]
+checkDoMDo pre nm [s] = parseError $ "The last statement in " ++ pre ++ nm ++ " construct must be an expression"
+checkDoMDo pre nm (s:ss) = checkDoMDo pre nm ss `thenP` \ ss' ->
+ returnP (s:ss')
---------------------------------------------------------------------------
-- Checking Patterns.
{- -*-haskell-*-
-----------------------------------------------------------------------------
-$Id: Parser.y,v 1.104 2002/09/25 12:47:42 simonmar Exp $
+$Id: Parser.y,v 1.105 2002/09/27 08:20:45 simonpj Exp $
Haskell grammar.
'threadsafe' { ITthreadsafe }
'unsafe' { ITunsafe }
'with' { ITwith }
+ 'mdo' { ITmdo }
'stdcall' { ITstdcallconv }
'ccall' { ITccallconv }
'dotnet' { ITdotnet }
| '-' fexp { mkHsNegApp $2 }
| srcloc 'do' stmtlist {% checkDo $3 `thenP` \ stmts ->
returnP (mkHsDo DoExpr stmts $1) }
+ | srcloc 'mdo' stmtlist {% checkMDo $3 `thenP` \ stmts ->
+ returnP (mkHsDo MDoExpr stmts $1) }
| '_ccall_' ccallid aexps0 { HsCCall $2 $3 PlayRisky False placeHolderType }
| '_ccall_GC_' ccallid aexps0 { HsCCall $2 $3 (PlaySafe False) False placeHolderType }
import MkId -- All of it, for re-export
import Name ( nameOccName )
import RdrName ( mkRdrUnqual, getRdrName )
-import HsSyn ( HsTyVarBndr(..), TyClDecl(..), HsType(..) )
+import HsSyn ( HsTyVarBndr(..) )
import OccName ( mkVarOcc )
import TysPrim ( primTyCons )
import TysWiredIn ( wiredInTyCons )
thenMName, bindMName, returnMName, failMName,
thenIOName, bindIOName, returnIOName, failIOName,
+ -- MonadRec stuff
+ mfixName,
+
-- Ix stuff
ixClassName,
mAIN_Name = mkModuleName "Main"
pREL_INT_Name = mkModuleName "GHC.Int"
pREL_WORD_Name = mkModuleName "GHC.Word"
-
+mONAD_FIX_Name = mkModuleName "Control.Monad.Fix"
aDDR_Name = mkModuleName "Addr"
gLA_EXTS_Name = mkModuleName "GHC.Exts"
pREL_FLOAT = mkPrelModule pREL_FLOAT_Name
pRELUDE = mkPrelModule pRELUDE_Name
+
iNTERACTIVE = mkHomeModule (mkModuleName "$Interactive")
-- MetaHaskell Extension text2 from Meta/work/gen.hs
-- The "split" Id for splittable implicit parameters
splitName = varQual gLA_EXTS_Name FSLIT("split") splitIdKey
+
+-- Recursive-do notation
+mfixName = varQual mONAD_FIX_Name FSLIT("mfix") mfixIdKey
\end{code}
%************************************************************************
protoIdKey = mkPreludeMiscIdUnique 160
matchIdKey = mkPreludeMiscIdUnique 161
clauseIdKey = mkPreludeMiscIdUnique 162
+
+-- Recursive do notation
+mfixIdKey = mkPreludeMiscIdUnique 163
\end{code}
\begin{code}
module RnBinds (
- rnTopMonoBinds, rnMonoBinds, rnMethodBinds,
- renameSigs, renameSigsFVs, unknownSigErr
+ rnTopMonoBinds, rnMonoBinds, rnMonoBindsAndThen,
+ rnMethodBinds, renameSigs, checkSigs, unknownSigErr
) where
#include "HsVersions.h"
import HsSyn
-import HsBinds ( eqHsSig, sigName, hsSigDoc )
+import HsBinds ( eqHsSig, hsSigDoc )
import RdrHsSyn
import RnHsSyn
import TcRnMonad
-import RnTypes ( rnHsSigType, rnHsType )
-import RnExpr ( rnMatch, rnGRHSs, rnPat, checkPrecMatch )
+import RnTypes ( rnHsSigType, rnHsType, rnPat )
+import RnExpr ( rnMatch, rnGRHSs, checkPrecMatch )
import RnEnv ( bindLocatedLocalsRn, lookupBndrRn, lookupInstDeclBndr,
lookupSigOccRn, bindPatSigTyVars, bindLocalFixities,
warnUnusedLocalBinds, mapFvRn, extendTyVarEnvFVRn,
)
import CmdLineOpts ( DynFlag(..) )
-import Digraph ( stronglyConnComp, SCC(..) )
+import Digraph ( SCC(..), stronglyConnComp )
import Name ( Name, nameOccName, nameSrcLoc )
import NameSet
import RdrName ( RdrName, rdrNameOcc )
-import BasicTypes ( RecFlag(..), FixitySig(..) )
-import List ( partition )
+import BasicTypes ( RecFlag(..) )
import Outputable
-import PrelNames ( isUnboundName )
\end{code}
-- ToDo: Put the annotations into the monad, so that they arrive in the proper
within one @MonoBinds@, so that unique-Int plumbing is done explicitly
(heavy monad machinery not needed).
-\begin{code}
-type VertexTag = Int
-\end{code}
%************************************************************************
%* *
\Haskell{} programs, and this code should not be executed.
Monomorphic bindings contain information that is returned in a tuple
-(a @FlatMonoBindsInfo@) containing:
+(a @FlatMonoBinds@) containing:
\begin{enumerate}
\item
contains bindings for the binders of this particular binding.
\begin{code}
-rnTopMonoBinds mbinds sigs
- = mappM lookupBndrRn binder_rdr_names `thenM` \ binder_names ->
- -- No need to extend the environment; that has been done already
+rnTopMonoBinds :: RdrNameMonoBinds
+ -> [RdrNameSig]
+ -> RnM (RenamedHsBinds, FreeVars)
- bindPatSigTyVars (collectSigTysFromMonoBinds mbinds) $
+-- Assumes the binders of the binding are in scope already
+-- Very like rnMonoBinds, bu checks for missing signatures too
+
+rnTopMonoBinds mbinds sigs
+ = bindPatSigTyVars (collectSigTysFromMonoBinds mbinds) $
-- Hmm; by analogy with Ids, this doesn't look right
- let
- bndr_name_set = mkNameSet binder_names
- in
- renameSigsFVs (okBindSig bndr_name_set) sigs `thenM` \ (siglist, sig_fvs) ->
+
+ renameSigs sigs `thenM` \ siglist ->
+ rn_mono_binds siglist mbinds `thenM` \ (binders, final_binds, bind_fvs) ->
+ checkSigs okBindSig binders siglist `thenM_`
-- Warn about missing signatures, but not in interface mode
-- (This is important when renaming bindings from 'deriving' clauses.)
(if warn_missing_sigs && not (isInterfaceMode mode) then
let
type_sig_vars = [n | Sig n _ _ <- siglist]
- un_sigd_binders = nameSetToList (delListFromNameSet bndr_name_set type_sig_vars)
+ un_sigd_binders = filter (not . (`elem` type_sig_vars))
+ (nameSetToList binders)
in
mappM_ missingSigWarn un_sigd_binders
else
returnM ()
) `thenM_`
- rn_mono_binds siglist mbinds `thenM` \ (final_binds, bind_fvs) ->
- returnM (final_binds, bind_fvs `plusFV` sig_fvs)
- where
- binder_rdr_names = collectMonoBinders mbinds
+ returnM (final_binds, bind_fvs `plusFV` hsSigsFVs siglist)
\end{code}
+
%************************************************************************
%* *
%* Nested binds
%* *
%************************************************************************
-\subsubsection{Nested binds}
-
-@rnMonoBinds@
-\begin{itemize}
-\item collects up the binders for this declaration group,
-\item checks that they form a set
-\item extends the environment to bind them to new local names
-\item calls @rnMonoBinds@ to do the real work
-\end{itemize}
-%
\begin{code}
-rnMonoBinds :: RdrNameMonoBinds
- -> [RdrNameSig]
- -> (RenamedHsBinds -> RnM (result, FreeVars))
- -> RnM (result, FreeVars)
-
-rnMonoBinds mbinds sigs thing_inside -- Non-empty monobinds
- = -- Extract all the binders in this group,
- -- and extend current scope, inventing new names for the new binders
+rnMonoBindsAndThen :: RdrNameMonoBinds
+ -> [RdrNameSig]
+ -> (RenamedHsBinds -> RnM (result, FreeVars))
+ -> RnM (result, FreeVars)
+
+rnMonoBindsAndThen mbinds sigs thing_inside -- Non-empty monobinds
+ = -- Extract all the binders in this group, and extend the
+ -- current scope, inventing new names for the new binders
-- This also checks that the names form a set
bindLocatedLocalsRn doc mbinders_w_srclocs $ \ new_mbinders ->
bindPatSigTyVars (collectSigTysFromMonoBinds mbinds) $
- let
- binder_set = mkNameSet new_mbinders
- in
- -- Rename the signatures
- renameSigsFVs (okBindSig binder_set) sigs `thenM` \ (siglist, sig_fvs) ->
- -- Report the fixity declarations in this group that
- -- don't refer to any of the group's binders.
- -- Then install the fixity declarations that do apply here
+ -- Then install local fixity declarations
-- Notice that they scope over thing_inside too
- bindLocalFixities [sig | FixSig sig <- siglist ] $
+ bindLocalFixities [sig | FixSig sig <- sigs ] $
- rn_mono_binds siglist mbinds `thenM` \ (binds, bind_fvs) ->
+ -- Do the business
+ rnMonoBinds mbinds sigs `thenM` \ (binds, bind_fvs) ->
- -- Now do the "thing inside", and deal with the free-variable calculations
+ -- Now do the "thing inside"
thing_inside binds `thenM` \ (result,result_fvs) ->
+
+ -- Final error checking
let
- all_fvs = result_fvs `plusFV` bind_fvs `plusFV` sig_fvs
- unused_binders = nameSetToList (binder_set `minusNameSet` all_fvs)
+ all_fvs = result_fvs `plusFV` bind_fvs
+ unused_binders = filter (not . (`elemNameSet` all_fvs)) new_mbinders
in
- warnUnusedLocalBinds unused_binders `thenM_`
+ warnUnusedLocalBinds unused_binders `thenM_`
+
returnM (result, delListFromNameSet all_fvs new_mbinders)
where
mbinders_w_srclocs = collectLocatedMonoBinders mbinds
- doc = text "In the binding group for" <+> pp_bndrs mbinders_w_srclocs
- pp_bndrs [(b,_)] = quotes (ppr b)
- pp_bndrs bs = fsep (punctuate comma [ppr b | (b,_) <- bs])
+ doc = text "In the binding group for:"
+ <+> pprWithCommas ppr (map fst mbinders_w_srclocs)
\end{code}
+\begin{code}
+rnMonoBinds :: RdrNameMonoBinds
+ -> [RdrNameSig]
+ -> RnM (RenamedHsBinds, FreeVars)
+
+-- Assumes the binders of the binding are in scope already
+
+rnMonoBinds mbinds sigs
+ = renameSigs sigs `thenM` \ siglist ->
+ rn_mono_binds siglist mbinds `thenM` \ (binders, final_binds, bind_fvs) ->
+ checkSigs okBindSig binders siglist `thenM_`
+ returnM (final_binds, bind_fvs `plusFV` hsSigsFVs siglist)
+\end{code}
+
%************************************************************************
%* *
\subsubsection{ MonoBinds -- the main work is done here}
\begin{code}
rn_mono_binds :: [RenamedSig] -- Signatures attached to this group
-> RdrNameMonoBinds
- -> RnM (RenamedHsBinds, -- Dependency analysed
- FreeVars) -- Free variables
+ -> RnM (NameSet, -- Binders
+ RenamedHsBinds, -- Dependency analysed
+ FreeVars) -- Free variables
rn_mono_binds siglist mbinds
- =
- -- Rename the bindings, returning a MonoBindsInfo
+ = -- Rename the bindings, returning a MonoBindsInfo
-- which is a list of indivisible vertices so far as
-- the strongly-connected-components (SCC) analysis is concerned
flattenMonoBinds siglist mbinds `thenM` \ mbinds_info ->
-- Do the SCC analysis
let
- edges = mkEdges (mbinds_info `zip` [(0::Int)..])
- scc_result = stronglyConnComp edges
+ scc_result = rnSCC mbinds_info
final_binds = foldr (ThenBinds . reconstructCycle) EmptyBinds scc_result
- -- Deal with bound and free-var calculation
- rhs_fvs = plusFVs [fvs | (_,fvs,_,_) <- mbinds_info]
+ -- Deal with bound and free-var calculation
+ -- Caller removes binders from free-var set
+ rhs_fvs = plusFVs [fvs | (_,fvs,_) <- mbinds_info]
+ bndrs = plusFVs [defs | (defs,_,_) <- mbinds_info]
in
- returnM (final_binds, rhs_fvs)
+ returnM (bndrs, final_binds, rhs_fvs)
\end{code}
@flattenMonoBinds@ is ever-so-slightly magical in that it sticks
\begin{code}
flattenMonoBinds :: [RenamedSig] -- Signatures
-> RdrNameMonoBinds
- -> RnM [FlatMonoBindsInfo]
+ -> RnM [FlatMonoBinds]
flattenMonoBinds sigs EmptyMonoBinds = returnM []
returnM
[(names_bound_here,
fvs `plusFV` pat_fvs,
- PatMonoBind pat' grhss' locn,
- sigs_for_me
- )]
+ (PatMonoBind pat' grhss' locn, sigs_for_me)
+ )]
flattenMonoBinds sigs (FunMonoBind name inf matches locn)
= addSrcLoc locn $
returnM
[(unitNameSet new_name,
fvs,
- FunMonoBind new_name inf new_matches locn,
- sigs_for_me
- )]
+ (FunMonoBind new_name inf new_matches locn, sigs_for_me)
+ )]
sigsForMe names_bound_here sigs
%************************************************************************
%* *
-\subsection[reconstruct-deps]{Reconstructing dependencies}
-%* *
-%************************************************************************
+ Strongly connected components
-This @MonoBinds@- and @ClassDecls@-specific code is segregated here,
-as the two cases are similar.
-
-\begin{code}
-reconstructCycle :: SCC FlatMonoBindsInfo
- -> RenamedHsBinds
-
-reconstructCycle (AcyclicSCC (_, _, binds, sigs))
- = MonoBind binds sigs NonRecursive
-
-reconstructCycle (CyclicSCC cycle)
- = MonoBind this_gp_binds this_gp_sigs Recursive
- where
- this_gp_binds = foldr1 AndMonoBinds [binds | (_, _, binds, _) <- cycle]
- this_gp_sigs = foldr1 (++) [sigs | (_, _, _, sigs) <- cycle]
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection{ Manipulating FlatMonoBindInfo}
%* *
%************************************************************************
-During analysis a @MonoBinds@ is flattened to a @FlatMonoBindsInfo@.
+During analysis a @MonoBinds@ is flattened to a @FlatMonoBinds@.
The @RenamedMonoBinds@ is always an empty bind, a pattern binding or
a function binding, and has itself been dependency-analysed and
renamed.
\begin{code}
-type FlatMonoBindsInfo
- = (NameSet, -- Set of names defined in this vertex
- NameSet, -- Set of names used in this vertex
- RenamedMonoBinds,
- [RenamedSig]) -- Signatures, if any, for this vertex
+type BindWithSigs = (RenamedMonoBinds, [RenamedSig])
+ -- Signatures, if any, for this vertex
-mkEdges :: [(FlatMonoBindsInfo, VertexTag)] -> [(FlatMonoBindsInfo, VertexTag, [VertexTag])]
+type FlatMonoBinds = (NameSet, -- Defs
+ NameSet, -- Uses
+ BindWithSigs)
-mkEdges flat_info
- = [ (info, tag, dest_vertices (nameSetToList names_used))
- | (info@(names_defined, names_used, mbind, sigs), tag) <- flat_info
+rnSCC :: [FlatMonoBinds] -> [SCC BindWithSigs]
+rnSCC nodes = stronglyConnComp (mkEdges nodes)
+
+type VertexTag = Int
+
+mkEdges :: [FlatMonoBinds] -> [(BindWithSigs, VertexTag, [VertexTag])]
+mkEdges nodes
+ = [ (thing, tag, dest_vertices uses)
+ | ((defs, uses, thing), tag) <- tagged_nodes
]
where
+ tagged_nodes = nodes `zip` [0::VertexTag ..]
+
-- An edge (v,v') indicates that v depends on v'
- dest_vertices src_mentions = [ target_vertex
- | ((names_defined, _, _, _), target_vertex) <- flat_info,
- mentioned_name <- src_mentions,
- mentioned_name `elemNameSet` names_defined
- ]
+ dest_vertices uses = [ target_vertex
+ | ((defs, _, _), target_vertex) <- tagged_nodes,
+ mentioned_name <- nameSetToList uses,
+ mentioned_name `elemNameSet` defs
+ ]
+
+reconstructCycle :: SCC BindWithSigs -> RenamedHsBinds
+reconstructCycle (AcyclicSCC (binds, sigs))
+ = MonoBind binds sigs NonRecursive
+reconstructCycle (CyclicSCC cycle)
+ = MonoBind this_gp_binds this_gp_sigs Recursive
+ where
+ (binds,sigs) = unzip cycle
+ this_gp_binds = foldr1 AndMonoBinds binds
+ this_gp_sigs = foldr1 (++) sigs
\end{code}
signatures. We'd only need this if we wanted to report unused tyvars.
\begin{code}
-renameSigsFVs ok_sig sigs
- = renameSigs ok_sig sigs `thenM` \ sigs' ->
- returnM (sigs', hsSigsFVs sigs')
-
-renameSigs :: (RenamedSig -> Bool) -- OK-sig predicate
- -> [RdrNameSig]
- -> RnM [RenamedSig]
-
-renameSigs ok_sig [] = returnM []
-
-renameSigs ok_sig sigs
- = -- Rename the signatures
- mappM renameSig sigs `thenM` \ sigs' ->
-
+checkSigs :: (NameSet -> RenamedSig -> Bool) -- OK-sig predicbate
+ -> NameSet -- Binders of this group
+ -> [RenamedSig]
+ -> RnM ()
+checkSigs ok_sig bndrs sigs
-- Check for (a) duplicate signatures
-- (b) signatures for things not in this group
- let
- in_scope = filter is_in_scope sigs'
- is_in_scope sig = case sigName sig of
- Just n -> not (isUnboundName n)
- Nothing -> True
- (goods, bads) = partition ok_sig in_scope
- in
- mappM_ unknownSigErr bads `thenM_`
- returnM goods
+ -- Well, I can't see the check for (b)... ToDo!
+ = mappM_ unknownSigErr bad_sigs
+ where
+ bad_sigs = filter (not . ok_sig bndrs) sigs
-- We use lookupSigOccRn in the signatures, which is a little bit unsatisfactory
-- because this won't work for:
-- is in scope. (I'm assuming that Baz.op isn't in scope unqualified.)
-- Doesn't seem worth much trouble to sort this.
+renameSigs :: [Sig RdrName] -> RnM [Sig Name]
+renameSigs sigs = mappM renameSig (filter (not . isFixitySig) sigs)
+ -- Remove fixity sigs which have been dealt with already
+
renameSig :: Sig RdrName -> RnM (Sig Name)
--- ClassOpSig is renamed elsewhere.
+-- ClassOpSig, FixitSig is renamed elsewhere.
renameSig (Sig v ty src_loc)
= addSrcLoc src_loc $
lookupSigOccRn v `thenM` \ new_v ->
rnHsSigType (quotes (ppr v)) ty `thenM` \ new_ty ->
returnM (SpecSig new_v new_ty src_loc)
-renameSig (FixSig (FixitySig v fix src_loc))
- = addSrcLoc src_loc $
- lookupSigOccRn v `thenM` \ new_v ->
- returnM (FixSig (FixitySig new_v fix src_loc))
-
renameSig (InlineSig b v p src_loc)
= addSrcLoc src_loc $
lookupSigOccRn v `thenM` \ new_v ->
import FlattenInfo ( namesNeededForFlattening )
import HsSyn
-import RnHsSyn ( RenamedFixitySig )
-import RdrHsSyn ( RdrNameHsType, extractHsTyRdrTyVars )
+import RdrHsSyn ( RdrNameHsType, RdrNameFixitySig, extractHsTyRdrTyVars )
import RdrName ( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual, isOrig,
mkRdrUnqual, mkRdrQual, setRdrNameSpace, rdrNameOcc,
lookupRdrEnv, rdrEnvToList, elemRdrEnv,
import NameSet
import OccName ( OccName, tcName, isDataOcc, occNameUserString, occNameFlavour )
import Module ( Module, ModuleName, moduleName, mkVanillaModule )
-import PrelNames ( mkUnboundName, intTyConName, qTyConName,
+import PrelNames ( mkUnboundName, intTyConName,
boolTyConName, funTyConName,
unpackCStringName, unpackCStringFoldrName, unpackCStringUtf8Name,
eqStringName, printName,
- bindIOName, returnIOName, failIOName, thenIOName,
- templateHaskellNames
+ bindIOName, returnIOName, failIOName, thenIOName
+#ifdef GHCI
+ , templateHaskellNames, qTyConName
+#endif
)
import TysWiredIn ( unitTyCon ) -- A little odd
import FiniteMap
\begin{code}
--------------------------------
-bindLocalFixities :: [RenamedFixitySig] -> RnM a -> RnM a
+bindLocalFixities :: [RdrNameFixitySig] -> RnM a -> RnM a
-- Used for nested fixity decls
-- No need to worry about type constructors here,
-- Should check for duplicates but we don't
bindLocalFixities fixes thing_inside
| null fixes = thing_inside
- | otherwise = extendFixityEnv new_bit thing_inside
+ | otherwise = mappM rn_sig fixes `thenM` \ new_bit ->
+ extendFixityEnv new_bit thing_inside
where
- new_bit = [(n,s) | s@(FixitySig n _ _) <- fixes]
+ rn_sig (FixitySig v fix src_loc)
+ = addSrcLoc src_loc $
+ lookupSigOccRn v `thenM` \ new_v ->
+ returnM (new_v, FixitySig new_v fix src_loc)
\end{code}
--------------------------------
-- they are needed in virtually every program
ubiquitousNames
= mkFVs [unpackCStringName, unpackCStringFoldrName,
- unpackCStringUtf8Name, eqStringName]
+ unpackCStringUtf8Name, eqStringName,
-- Virtually every program has error messages in it somewhere
- `plusFV`
- mkFVs [getName unitTyCon, funTyConName, boolTyConName, intTyConName]
+ getName unitTyCon, funTyConName, boolTyConName, intTyConName]
-- Add occurrences for very frequently used types.
-- (e.g. we don't want to be bothered with making
-- funTyCon a free var at every function application!)
\begin{code}
module RnExpr (
- rnMatch, rnGRHSs, rnPat, rnExpr, rnExprs,
- rnStmt, rnStmts, checkPrecMatch
+ rnMatch, rnGRHSs, rnExpr, rnExprs, rnStmts,
+ checkPrecMatch
) where
#include "HsVersions.h"
-import {-# SOURCE #-} RnSource ( rnSrcDecls, rnBinds )
+import {-# SOURCE #-} RnSource ( rnSrcDecls, rnBindsAndThen, rnBinds )
+
+-- RnSource imports RnBinds.rnTopMonoBinds, RnExpr.rnExpr
+-- RnBinds imports RnExpr.rnMatch, etc
+-- RnExpr imports [boot] RnSource.rnSrcDecls, RnSource.rnBinds
import HsSyn
import RdrHsSyn
import RnHsSyn
import TcRnMonad
import RnEnv
-import RnTypes ( rnHsTypeFVs, precParseErr, sectionPrecErr )
+import RnTypes ( rnHsTypeFVs, rnPat, litFVs, rnOverLit, rnPatsAndThen,
+ dupFieldErr, precParseErr, sectionPrecErr, patSigErr )
import CmdLineOpts ( DynFlag(..), opt_IgnoreAsserts )
-import Literal ( inIntRange, inCharRange )
import BasicTypes ( Fixity(..), FixityDirection(..), IPName(..),
defaultFixity, negateFixity, compareFixity )
import PrelNames ( hasKey, assertIdKey,
- eqClassName, foldrName, buildName, eqStringName,
+ foldrName, buildName,
cCallableClassName, cReturnableClassName,
- enumClassName, ordClassName,
- ratioDataConName, splitName, fstName, sndName,
- ioDataConName, plusIntegerName, timesIntegerName,
+ enumClassName,
+ splitName, fstName, sndName, ioDataConName,
replicatePName, mapPName, filterPName,
- crossPName, zipPName, lengthPName, indexPName, toPName,
+ crossPName, zipPName, toPName,
enumFromToPName, enumFromThenToPName, assertErrorName,
- fromIntegerName, fromRationalName, minusName, negateName,
- qTyConName, monadNames )
-import TysPrim ( charPrimTyCon, addrPrimTyCon, intPrimTyCon,
- floatPrimTyCon, doublePrimTyCon )
-import TysWiredIn ( intTyCon )
+ negateName, qTyConName, monadNames, mfixName )
import RdrName ( RdrName )
-import Name ( Name, NamedThing(..), mkSystemName, nameSrcLoc, nameOccName )
+import Name ( Name, nameOccName )
import NameSet
import UnicodeUtil ( stringToUtf8 )
import UniqFM ( isNullUFM )
import UniqSet ( emptyUniqSet )
-import List ( intersectBy )
+import Util ( isSingleton )
+import List ( intersectBy, unzip4 )
import ListSetOps ( removeDups )
import Outputable
import FastString
\end{code}
-*********************************************************
-* *
-\subsection{Patterns}
-* *
-*********************************************************
-
-\begin{code}
-rnPat :: RdrNamePat -> RnM (RenamedPat, FreeVars)
-
-rnPat (WildPat _) = returnM (WildPat placeHolderType, emptyFVs)
-
-rnPat (VarPat name)
- = lookupBndrRn name `thenM` \ vname ->
- returnM (VarPat vname, emptyFVs)
-
-rnPat (SigPatIn pat ty)
- = doptM Opt_GlasgowExts `thenM` \ glaExts ->
-
- if glaExts
- then rnPat pat `thenM` \ (pat', fvs1) ->
- rnHsTypeFVs doc ty `thenM` \ (ty', fvs2) ->
- returnM (SigPatIn pat' ty', fvs1 `plusFV` fvs2)
-
- else addErr (patSigErr ty) `thenM_`
- rnPat pat
- where
- doc = text "In a pattern type-signature"
-
-rnPat (LitPat s@(HsString _))
- = returnM (LitPat s, unitFV eqStringName)
-
-rnPat (LitPat lit)
- = litFVs lit `thenM` \ fvs ->
- returnM (LitPat lit, fvs)
-
-rnPat (NPatIn lit mb_neg)
- = rnOverLit lit `thenM` \ (lit', fvs1) ->
- (case mb_neg of
- Nothing -> returnM (Nothing, emptyFVs)
- Just _ -> lookupSyntaxName negateName `thenM` \ (neg, fvs) ->
- returnM (Just neg, fvs)
- ) `thenM` \ (mb_neg', fvs2) ->
- returnM (NPatIn lit' mb_neg',
- fvs1 `plusFV` fvs2 `addOneFV` eqClassName)
- -- Needed to find equality on pattern
-
-rnPat (NPlusKPatIn name lit _)
- = rnOverLit lit `thenM` \ (lit', fvs1) ->
- lookupBndrRn name `thenM` \ name' ->
- lookupSyntaxName minusName `thenM` \ (minus, fvs2) ->
- returnM (NPlusKPatIn name' lit' minus,
- fvs1 `plusFV` fvs2 `addOneFV` ordClassName)
-
-rnPat (LazyPat pat)
- = rnPat pat `thenM` \ (pat', fvs) ->
- returnM (LazyPat pat', fvs)
-
-rnPat (AsPat name pat)
- = rnPat pat `thenM` \ (pat', fvs) ->
- lookupBndrRn name `thenM` \ vname ->
- returnM (AsPat vname pat', fvs)
-
-rnPat (ConPatIn con stuff) = rnConPat con stuff
-
-
-rnPat (ParPat pat)
- = rnPat pat `thenM` \ (pat', fvs) ->
- returnM (ParPat pat', fvs)
-
-rnPat (ListPat pats _)
- = mapFvRn rnPat pats `thenM` \ (patslist, fvs) ->
- returnM (ListPat patslist placeHolderType, fvs `addOneFV` listTyCon_name)
-
-rnPat (PArrPat pats _)
- = mapFvRn rnPat pats `thenM` \ (patslist, fvs) ->
- returnM (PArrPat patslist placeHolderType,
- fvs `plusFV` implicit_fvs `addOneFV` parrTyCon_name)
- where
- implicit_fvs = mkFVs [lengthPName, indexPName]
-
-rnPat (TuplePat pats boxed)
- = mapFvRn rnPat pats `thenM` \ (patslist, fvs) ->
- returnM (TuplePat patslist boxed, fvs `addOneFV` tycon_name)
- where
- tycon_name = tupleTyCon_name boxed (length pats)
-
-rnPat (TypePat name) =
- rnHsTypeFVs (text "In a type pattern") name `thenM` \ (name', fvs) ->
- returnM (TypePat name', fvs)
-
-------------------------------
-rnConPat con (PrefixCon pats)
- = lookupOccRn con `thenM` \ con' ->
- mapFvRn rnPat pats `thenM` \ (pats', fvs) ->
- returnM (ConPatIn con' (PrefixCon pats'), fvs `addOneFV` con')
-
-rnConPat con (RecCon rpats)
- = lookupOccRn con `thenM` \ con' ->
- rnRpats rpats `thenM` \ (rpats', fvs) ->
- returnM (ConPatIn con' (RecCon rpats'), fvs `addOneFV` con')
-
-rnConPat con (InfixCon pat1 pat2)
- = lookupOccRn con `thenM` \ con' ->
- rnPat pat1 `thenM` \ (pat1', fvs1) ->
- rnPat pat2 `thenM` \ (pat2', fvs2) ->
-
- getModeRn `thenM` \ mode ->
- -- See comments with rnExpr (OpApp ...)
- (if isInterfaceMode mode
- then returnM (ConPatIn con' (InfixCon pat1' pat2'))
- else lookupFixityRn con' `thenM` \ fixity ->
- mkConOpPatRn con' fixity pat1' pat2'
- ) `thenM` \ pat' ->
- returnM (pat', fvs1 `plusFV` fvs2 `addOneFV` con')
-\end{code}
-
-
************************************************************************
* *
\subsection{Match}
rnMatch ctxt match@(Match pats maybe_rhs_sig grhss)
= addSrcLoc (getMatchLoc match) $
- -- Bind pattern-bound type variables
- let
- rhs_sig_tys = case maybe_rhs_sig of
- Nothing -> []
- Just ty -> [ty]
- pat_sig_tys = collectSigTysFromPats pats
- doc_sig = text "In a result type-signature"
- doc_pat = pprMatchContext ctxt
- in
- bindPatSigTyVars (rhs_sig_tys ++ pat_sig_tys) $
-
- -- Note that we do a single bindLocalsRn for all the
- -- matches together, so that we spot the repeated variable in
- -- f x x = 1
- bindLocalsFVRn doc_pat (collectPatsBinders pats) $ \ new_binders ->
-
- mapFvRn rnPat pats `thenM` \ (pats', pat_fvs) ->
- rnGRHSs grhss `thenM` \ (grhss', grhss_fvs) ->
+ -- Deal with the rhs type signature
+ bindPatSigTyVars rhs_sig_tys $
doptM Opt_GlasgowExts `thenM` \ opt_GlasgowExts ->
(case maybe_rhs_sig of
Nothing -> returnM (Nothing, emptyFVs)
returnM (Nothing, emptyFVs)
) `thenM` \ (maybe_rhs_sig', ty_fvs) ->
- let
- binder_set = mkNameSet new_binders
- unused_binders = nameSetToList (binder_set `minusNameSet` grhss_fvs)
- all_fvs = grhss_fvs `plusFV` pat_fvs `plusFV` ty_fvs
- in
- warnUnusedMatches unused_binders `thenM_`
-
- returnM (Match pats' maybe_rhs_sig' grhss', all_fvs)
- -- The bindLocals and bindTyVars will remove the bound FVs
+ -- Now the main event
+ rnPatsAndThen ctxt pats $ \ pats' ->
+ rnGRHSs 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
+ where
+ rhs_sig_tys = case maybe_rhs_sig of
+ Nothing -> []
+ Just ty -> [ty]
+ doc_sig = text "In a result type-signature"
\end{code}
rnGRHSs :: RdrNameGRHSs -> RnM (RenamedGRHSs, FreeVars)
rnGRHSs (GRHSs grhss binds _)
- = rnBinds binds $ \ binds' ->
+ = rnBindsAndThen binds $ \ binds' ->
mapFvRn rnGRHS grhss `thenM` \ (grhss', fvGRHSs) ->
returnM (GRHSs grhss' binds' placeHolderType, fvGRHSs)
rnGRHS (GRHS guarded locn)
- = doptM Opt_GlasgowExts `thenM` \ opt_GlasgowExts ->
- addSrcLoc locn $
- (if not (opt_GlasgowExts || is_standard_guard guarded) then
- addWarn (nonStdGuardErr guarded)
- else
- returnM ()
- ) `thenM_`
-
- rnStmts guarded `thenM` \ ((_, guarded'), fvs) ->
+ = 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) ->
returnM (GRHS guarded' locn, fvs)
where
-- Standard Haskell 1.4 guards are just a single boolean
returnM (HsCase new_expr new_ms src_loc, e_fvs `plusFV` ms_fvs)
rnExpr (HsLet binds expr)
- = rnBinds binds $ \ binds' ->
+ = rnBindsAndThen binds $ \ binds' ->
rnExpr expr `thenM` \ (expr',fvExpr) ->
returnM (HsLet binds' expr', fvExpr)
rnIPBinds binds `thenM` \ (binds',fvBinds) ->
returnM (HsWith expr' binds' is_with, fvExpr `plusFV` fvBinds)
-rnExpr e@(HsDo do_or_lc stmts _ ty src_loc)
+rnExpr e@(HsDo do_or_lc stmts _ _ src_loc)
= addSrcLoc src_loc $
- rnStmts stmts `thenM` \ ((_, stmts'), fvs) ->
+ rnStmts do_or_lc stmts `thenM` \ (stmts', fvs) ->
-- Check the statement list ends in an expression
case last stmts' of {
ResultStmt _ _ -> returnM () ;
- _ -> addErr (doStmtListErr e)
+ _ -> addErr (doStmtListErr "do" e)
} `thenM_`
-- Generate the rebindable syntax for the monad
- (case do_or_lc of
- DoExpr -> mapAndUnzipM lookupSyntaxName monadNames
- other -> returnM ([], [])
- ) `thenM` \ (monad_names', monad_fvs) ->
+ mapAndUnzipM lookupSyntaxName
+ (syntax_names do_or_lc) `thenM` \ (monad_names', monad_fvs) ->
returnM (HsDo do_or_lc stmts' monad_names' placeHolderType src_loc,
- fvs `plusFV` implicit_fvs `plusFV` plusFVs monad_fvs)
+ fvs `plusFV` implicit_fvs do_or_lc `plusFV` plusFVs monad_fvs)
where
- implicit_fvs = case do_or_lc of
- PArrComp -> mkFVs [replicatePName, mapPName, filterPName,
- crossPName, zipPName]
- ListComp -> mkFVs [foldrName, buildName]
- DoExpr -> emptyFVs
+ implicit_fvs PArrComp = mkFVs [replicatePName, mapPName, filterPName, crossPName, zipPName]
+ implicit_fvs ListComp = mkFVs [foldrName, buildName]
+ implicit_fvs DoExpr = emptyFVs
+ implicit_fvs MDoExpr = emptyFVs
+
+ syntax_names DoExpr = monadNames
+ syntax_names MDoExpr = monadNames ++ [mfixName]
+ syntax_names other = []
rnExpr (ExplicitList _ exps)
= rnExprs exps `thenM` \ (exps', fvs) ->
doc = text "In a type argument"
rnExpr (ArithSeqIn seq)
- = rn_seq seq `thenM` \ (new_seq, fvs) ->
+ = rnArithSeq seq `thenM` \ (new_seq, fvs) ->
returnM (ArithSeqIn new_seq, fvs `addOneFV` enumClassName)
- where
- rn_seq (From expr)
- = rnExpr expr `thenM` \ (expr', fvExpr) ->
- returnM (From expr', fvExpr)
-
- rn_seq (FromThen expr1 expr2)
- = rnExpr expr1 `thenM` \ (expr1', fvExpr1) ->
- rnExpr expr2 `thenM` \ (expr2', fvExpr2) ->
- returnM (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2)
-
- rn_seq (FromTo expr1 expr2)
- = rnExpr expr1 `thenM` \ (expr1', fvExpr1) ->
- rnExpr expr2 `thenM` \ (expr2', fvExpr2) ->
- returnM (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2)
-
- rn_seq (FromThenTo expr1 expr2 expr3)
- = rnExpr expr1 `thenM` \ (expr1', fvExpr1) ->
- rnExpr expr2 `thenM` \ (expr2', fvExpr2) ->
- rnExpr expr3 `thenM` \ (expr3', fvExpr3) ->
- returnM (FromThenTo expr1' expr2' expr3',
- plusFVs [fvExpr1, fvExpr2, fvExpr3])
rnExpr (PArrSeqIn seq)
- = rn_seq seq `thenM` \ (new_seq, fvs) ->
+ = rnArithSeq seq `thenM` \ (new_seq, fvs) ->
returnM (PArrSeqIn new_seq,
- fvs `plusFV` mkFVs [enumFromToPName, enumFromThenToPName])
- where
-
- -- the parser shouldn't generate these two
- --
- rn_seq (From _ ) = panic "RnExpr.rnExpr: Infinite parallel array!"
- rn_seq (FromThen _ _) = panic "RnExpr.rnExpr: Infinite parallel array!"
-
- rn_seq (FromTo expr1 expr2)
- = rnExpr expr1 `thenM` \ (expr1', fvExpr1) ->
- rnExpr expr2 `thenM` \ (expr2', fvExpr2) ->
- returnM (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2)
- rn_seq (FromThenTo expr1 expr2 expr3)
- = rnExpr expr1 `thenM` \ (expr1', fvExpr1) ->
- rnExpr expr2 `thenM` \ (expr2', fvExpr2) ->
- rnExpr expr3 `thenM` \ (expr3', fvExpr3) ->
- returnM (FromThenTo expr1' expr2' expr3',
- plusFVs [fvExpr1, fvExpr2, fvExpr3])
+ fvs `plusFV` mkFVs [enumFromToPName, enumFromThenToPName])
\end{code}
These three are pattern syntax appearing in expressions.
returnM (EWildPat, emptyFVs)
\end{code}
+%************************************************************************
+%* *
+ Arithmetic sequences
+%* *
+%************************************************************************
+
+\begin{code}
+rnArithSeq (From expr)
+ = rnExpr expr `thenM` \ (expr', fvExpr) ->
+ returnM (From expr', fvExpr)
+
+rnArithSeq (FromThen expr1 expr2)
+ = rnExpr expr1 `thenM` \ (expr1', fvExpr1) ->
+ rnExpr expr2 `thenM` \ (expr2', fvExpr2) ->
+ returnM (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2)
+
+rnArithSeq (FromTo expr1 expr2)
+ = rnExpr expr1 `thenM` \ (expr1', fvExpr1) ->
+ rnExpr expr2 `thenM` \ (expr2', fvExpr2) ->
+ returnM (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2)
+
+rnArithSeq (FromThenTo expr1 expr2 expr3)
+ = rnExpr expr1 `thenM` \ (expr1', fvExpr1) ->
+ rnExpr expr2 `thenM` \ (expr2', fvExpr2) ->
+ rnExpr expr3 `thenM` \ (expr3', fvExpr3) ->
+ returnM (FromThenTo expr1' expr2' expr3',
+ plusFVs [fvExpr1, fvExpr2, fvExpr3])
+\end{code}
%************************************************************************
= lookupGlobalOccRn field `thenM` \ fieldname ->
rnExpr expr `thenM` \ (expr', fvExpr) ->
returnM ((fieldname, expr'), fvExpr `addOneFV` fieldname)
-
-rnRpats rpats
- = mappM_ field_dup_err dup_fields `thenM_`
- mapFvRn rn_rpat rpats `thenM` \ (rpats', fvs) ->
- returnM (rpats', fvs)
- where
- (_, dup_fields) = removeDups compare [ f | (f,_) <- rpats ]
-
- field_dup_err dups = addErr (dupFieldErr "pattern" dups)
-
- rn_rpat (field, pat)
- = lookupGlobalOccRn field `thenM` \ fieldname ->
- rnPat pat `thenM` \ (pat', fvs) ->
- returnM ((fieldname, pat'), fvs `addOneFV` fieldname)
\end{code}
%************************************************************************
%* *
%************************************************************************
-Note that although some bound vars may appear in the free var set for
-the first qual, these will eventually be removed by the caller. For
-example, if we have @[p | r <- s, q <- r, p <- q]@, when doing
-@[q <- r, p <- q]@, the free var set for @q <- r@ will
-be @{r}@, and the free var set for the entire Quals will be @{r}@. This
-@r@ will be removed only when we finally return from examining all the
-Quals.
-
\begin{code}
-rnStmts :: [RdrNameStmt]
- -> RnM (([Name], [RenamedStmt]), FreeVars)
-
-rnStmts []
- = returnM (([], []), emptyFVs)
-
-rnStmts (stmt:stmts)
- = getLocalRdrEnv `thenM` \ name_env ->
- rnStmt stmt $ \ stmt' ->
- rnStmts stmts `thenM` \ ((binders, stmts'), fvs) ->
- returnM ((binders, stmt' : stmts'), fvs)
-
-rnStmt :: RdrNameStmt
- -> (RenamedStmt -> RnM (([Name], a), FreeVars))
- -> RnM (([Name], a), FreeVars)
--- The thing list of names returned is the list returned by the
--- thing_inside, plus the binders of the arguments stmt
-
-rnStmt (ParStmt stmtss) thing_inside
- = mapFvRn rnStmts stmtss `thenM` \ (bndrstmtss, fv_stmtss) ->
- let binderss = map fst bndrstmtss
- checkBndrs all_bndrs bndrs
- = checkErr (null (intersectBy eqOcc all_bndrs bndrs)) err `thenM_`
- returnM (bndrs ++ all_bndrs)
- eqOcc n1 n2 = nameOccName n1 == nameOccName n2
- err = text "duplicate binding in parallel list comprehension"
+rnStmts :: HsStmtContext
+ -> [RdrNameStmt]
+ -> RnM ([RenamedStmt], FreeVars)
+
+rnStmts MDoExpr stmts = rnMDoStmts stmts
+rnStmts ctxt stmts = rnNormalStmts ctxt stmts
+
+rnNormalStmts :: HsStmtContext -> [RdrNameStmt] -> RnM ([RenamedStmt], FreeVars)
+-- Used for cases *other* than recursive mdo
+-- Implements nested scopes
+
+rnNormalStmts ctxt (ExprStmt expr _ src_loc : stmts)
+ = addSrcLoc src_loc $
+ rnExpr expr `thenM` \ (expr', fv_expr) ->
+ rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) ->
+ returnM (ExprStmt expr' placeHolderType src_loc : stmts',
+ fv_expr `plusFV` fvs)
+
+rnNormalStmts ctxt [ResultStmt expr src_loc]
+ = addSrcLoc src_loc $
+ rnExpr expr `thenM` \ (expr', fv_expr) ->
+ returnM ([ResultStmt expr' src_loc], fv_expr)
+
+rnNormalStmts ctxt (BindStmt pat expr src_loc : stmts)
+ = addSrcLoc src_loc $
+ rnExpr expr `thenM` \ (expr', fv_expr) ->
+ -- The binders do not scope over the expression
+
+ rnPatsAndThen (StmtCtxt ctxt) [pat] $ \ [pat'] ->
+ rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) ->
+ returnM (BindStmt pat' expr' src_loc : stmts',
+ fv_expr `plusFV` fvs) -- fv_expr shouldn't really be filtered by
+ -- 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)
+
+rnNormalStmts ctxt (ParStmt stmtss : stmts)
+ = mapFvRn (rnNormalStmts ctxt) stmtss `thenM` \ (stmtss', fv_stmtss) ->
+ let
+ bndrss = map collectStmtsBinders stmtss'
in
- foldlM checkBndrs [] binderss `thenM` \ new_binders ->
+ foldlM checkBndrs [] bndrss `thenM` \ new_binders ->
bindLocalNamesFV new_binders $
- thing_inside (ParStmtOut bndrstmtss)`thenM` \ ((rest_bndrs, result), fv_rest) ->
- returnM ((new_binders ++ rest_bndrs, result), fv_stmtss `plusFV` fv_rest)
+ -- Note: binders are returned in scope order, so one may
+ -- shadow the next; e.g. x <- xs; x <- ys
+ rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) ->
+ returnM (ParStmtOut (bndrss `zip` stmtss') : stmts',
+ fv_stmtss `plusFV` fvs)
+
+ where
+ checkBndrs all_bndrs bndrs
+ = checkErr (null common) (err (head common)) `thenM_`
+ returnM (bndrs ++ all_bndrs)
+ where
+ common = intersectBy eqOcc all_bndrs bndrs
-rnStmt (BindStmt pat expr src_loc) thing_inside
- = addSrcLoc src_loc $
- rnExpr expr `thenM` \ (expr', fv_expr) ->
- bindPatSigTyVars (collectSigTysFromPat pat) $
- bindLocalsFVRn doc (collectPatBinders pat) $ \ new_binders ->
- rnPat pat `thenM` \ (pat', fv_pat) ->
- thing_inside (BindStmt pat' expr' src_loc) `thenM` \ ((rest_binders, result), fvs) ->
- returnM ((new_binders ++ rest_binders, result),
- fv_expr `plusFV` fvs `plusFV` fv_pat)
+ eqOcc n1 n2 = nameOccName n1 == nameOccName n2
+ 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 pattern in 'do' binding"
+ doc = text "In a mdo-expression"
+
+type Defs = NameSet
+type Uses = NameSet -- Same as FreeVars really
+type FwdRefs = NameSet
+type Segment = (Defs,
+ Uses, -- May include defs
+ FwdRefs, -- A subset of uses that are
+ -- (a) used before they are bound in this segment, or
+ -- (b) used here, and bound in subsequent segments
+ [RenamedStmt])
+
+----------------------------------------------------
+rn_mdo_stmt :: RdrNameStmt -> RnM Segment
+ -- Assumes all binders are already in scope
+ -- Turns each stmt into a singleton Stmt
+
+rn_mdo_stmt (ExprStmt expr _ src_loc)
+ = addSrcLoc src_loc (rnExpr expr) `thenM` \ (expr', fvs) ->
+ returnM (emptyNameSet, fvs, emptyNameSet,
+ [ExprStmt expr' placeHolderType src_loc])
+
+rn_mdo_stmt (ResultStmt expr src_loc)
+ = addSrcLoc src_loc (rnExpr expr) `thenM` \ (expr', fvs) ->
+ returnM (emptyNameSet, fvs, emptyNameSet,
+ [ResultStmt expr' src_loc])
+
+rn_mdo_stmt (BindStmt pat expr src_loc)
+ = addSrcLoc src_loc $
+ rnExpr expr `thenM` \ (expr', fv_expr) ->
+ rnPat pat `thenM` \ (pat', fv_pat) ->
+ let
+ bndrs = mkNameSet (collectPatBinders pat')
+ fvs = fv_expr `plusFV` fv_pat
+ in
+ returnM (bndrs, fvs, bndrs `intersectNameSet` fvs,
+ [BindStmt pat' expr' src_loc])
-rnStmt (ExprStmt expr _ src_loc) thing_inside
- = addSrcLoc src_loc $
- rnExpr expr `thenM` \ (expr', fv_expr) ->
- thing_inside (ExprStmt expr' placeHolderType src_loc) `thenM` \ (result, fvs) ->
- returnM (result, fv_expr `plusFV` fvs)
+rn_mdo_stmt (LetStmt binds)
+ = rnBinds binds `thenM` \ (binds', fv_binds) ->
+ returnM (mkNameSet (collectHsBinders binds'),
+ fv_binds, emptyNameSet, [LetStmt binds'])
-rnStmt (ResultStmt expr src_loc) thing_inside
- = addSrcLoc src_loc $
- rnExpr expr `thenM` \ (expr', fv_expr) ->
- thing_inside (ResultStmt expr' src_loc) `thenM` \ (result, fvs) ->
- returnM (result, fv_expr `plusFV` fvs)
-
-rnStmt (LetStmt binds) thing_inside
- = rnBinds binds $ \ binds' ->
- let new_binders = collectHsBinders binds' in
- thing_inside (LetStmt binds') `thenM` \ ((rest_binders, result), fvs) ->
- returnM ((new_binders ++ rest_binders, result), fvs )
+rn_mdo_stmt stmt@(ParStmt _) -- Syntactically illegal in mdo
+ = pprPanic "rn_mdo_stmt" (ppr stmt)
+
+
+addFwdRefs :: [Segment] -> [Segment]
+-- So far the segments only have forward refs *within* the Stmt
+-- (which happens for bind: x <- ...x...)
+-- This function adds the cross-seg fwd ref info
+
+addFwdRefs pairs
+ = fst (foldr mk_seg ([], emptyNameSet) pairs)
+ where
+ mk_seg (defs, uses, fwds, stmts) (segs, seg_defs)
+ = (new_seg : segs, all_defs)
+ where
+ new_seg = (defs, uses, new_fwds, stmts)
+ all_defs = seg_defs `unionNameSets` defs
+ new_fwds = fwds `unionNameSets` (uses `intersectNameSet` seg_defs)
+ -- Add the downstream fwd refs here
+
+----------------------------------------------------
+-- Breaking a recursive 'do' into segments
+--
+-- Consider
+-- mdo { x <- ...y...
+-- p <- z
+-- y <- ...x...
+-- q <- x
+-- z <- y
+-- r <- x }
+--
+-- 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 }
+-- Now one more... but this time we have to group a bunch into rec
+-- { rec { y <- ...x... ; q <- x ; z <- y } ; r <- x }
+-- Now one more, which we can add on without a rec
+-- { p <- z ;
+-- rec { y <- ...x... ; q <- x ; z <- y } ;
+-- r <- x }
+-- Finally we add the last one; since it mentions y we have to
+-- glom it togeher with the first two groups
+-- { rec { x <- ...y...; p <- z ; y <- ...x... ;
+-- q <- x ; z <- y } ;
+-- r <- x }
+
+glomSegments :: [Segment] -> [Segment]
+
+glomSegments [seg] = [seg]
+glomSegments ((defs,uses,fwds,stmts) : segs)
+ -- Actually stmts will always be a singleton
+ = (seg_defs, seg_uses, seg_fwds, seg_stmts) : others
+ where
+ segs' = glomSegments segs
+ (extras, others) = grab uses segs'
+ (ds, us, fs, ss) = unzip4 extras
+
+ seg_defs = plusFVs ds `plusFV` defs
+ seg_uses = plusFVs us `plusFV` uses
+ seg_fwds = plusFVs fs `plusFV` fwds
+ seg_stmts = stmts ++ concat ss
+
+ grab :: NameSet -- The client
+ -> [Segment]
+ -> ([Segment], -- Needed by the 'client'
+ [Segment]) -- Not needed by the client
+ -- The result is simply a split of the input
+ grab uses dus
+ = (reverse yeses, reverse noes)
+ where
+ (noes, yeses) = span not_needed (reverse dus)
+ not_needed (defs,_,_,_) = not (intersectsNameSet defs uses)
+
+
+----------------------------------------------------
+segsToStmts :: [Segment] -> ([RenamedStmt], FreeVars)
+
+segsToStmts [] = ([], emptyFVs)
+segsToStmts ((defs, uses, fwds, ss) : segs)
+ = (new_stmt : later_stmts, later_uses `plusFV` uses)
+ where
+ (later_stmts, later_uses) = segsToStmts segs
+ new_stmt | non_rec = head ss
+ | otherwise = RecStmt rec_names ss
+ where
+ non_rec = isSingleton ss && isEmptyNameSet fwds
+ rec_names = nameSetToList (fwds `plusFV` (defs `intersectNameSet` later_uses))
+ -- The names for the fixpoint are
+ -- (a) the ones needed after the RecStmt
+ -- (b) the forward refs within the fixpoint
\end{code}
%************************************************************************
\end{code}
\begin{code}
-mkConOpPatRn :: Name -> Fixity -> RenamedPat -> RenamedPat
- -> RnM RenamedPat
-
-mkConOpPatRn op2 fix2 p1@(ConPatIn op1 (InfixCon p11 p12)) p2
- = lookupFixityRn op1 `thenM` \ fix1 ->
- let
- (nofix_error, associate_right) = compareFixity fix1 fix2
- in
- if nofix_error then
- addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenM_`
- returnM (ConPatIn op2 (InfixCon p1 p2))
- else
- if associate_right then
- mkConOpPatRn op2 fix2 p12 p2 `thenM` \ new_p ->
- returnM (ConPatIn op1 (InfixCon p11 new_p))
- else
- returnM (ConPatIn op2 (InfixCon p1 p2))
-
-mkConOpPatRn op fix p1 p2 -- Default case, no rearrangment
- = ASSERT( not_op_pat p2 )
- returnM (ConPatIn op (InfixCon p1 p2))
-
-not_op_pat (ConPatIn _ (InfixCon _ _)) = False
-not_op_pat other = True
-\end{code}
-
-\begin{code}
checkPrecMatch :: Bool -> Name -> RenamedMatch -> RnM ()
checkPrecMatch False fn match
%************************************************************************
%* *
-\subsubsection{Literals}
-%* *
-%************************************************************************
-
-When literals occur we have to make sure
-that the types and classes they involve
-are made available.
-
-\begin{code}
-litFVs (HsChar c)
- = checkErr (inCharRange c) (bogusCharError c) `thenM_`
- returnM (unitFV charTyCon_name)
-
-litFVs (HsCharPrim c) = returnM (unitFV (getName charPrimTyCon))
-litFVs (HsString s) = returnM (mkFVs [listTyCon_name, charTyCon_name])
-litFVs (HsStringPrim s) = returnM (unitFV (getName addrPrimTyCon))
-litFVs (HsInt i) = returnM (unitFV (getName intTyCon))
-litFVs (HsIntPrim i) = returnM (unitFV (getName intPrimTyCon))
-litFVs (HsFloatPrim f) = returnM (unitFV (getName floatPrimTyCon))
-litFVs (HsDoublePrim d) = returnM (unitFV (getName doublePrimTyCon))
-litFVs (HsLitLit l bogus_ty) = returnM (unitFV cCallableClassName)
-litFVs lit = pprPanic "RnExpr.litFVs" (ppr lit) -- HsInteger and HsRat only appear
- -- in post-typechecker translations
-
-rnOverLit (HsIntegral i _)
- = lookupSyntaxName fromIntegerName `thenM` \ (from_integer_name, fvs) ->
- if inIntRange i then
- returnM (HsIntegral i from_integer_name, fvs)
- else let
- extra_fvs = mkFVs [plusIntegerName, timesIntegerName]
- -- Big integer literals are built, using + and *,
- -- out of small integers (DsUtils.mkIntegerLit)
- -- [NB: plusInteger, timesInteger aren't rebindable...
- -- they are used to construct the argument to fromInteger,
- -- which is the rebindable one.]
- in
- returnM (HsIntegral i from_integer_name, fvs `plusFV` extra_fvs)
-
-rnOverLit (HsFractional i _)
- = lookupSyntaxName fromRationalName `thenM` \ (from_rat_name, fvs) ->
- let
- extra_fvs = mkFVs [ratioDataConName, plusIntegerName, timesIntegerName]
- -- We have to make sure that the Ratio type is imported with
- -- its constructor, because literals of type Ratio t are
- -- built with that constructor.
- -- The Rational type is needed too, but that will come in
- -- as part of the type for fromRational.
- -- The plus/times integer operations may be needed to construct the numerator
- -- and denominator (see DsUtils.mkIntegerLit)
- in
- returnM (HsFractional i from_rat_name, fvs `plusFV` extra_fvs)
-\end{code}
-
-%************************************************************************
-%* *
\subsubsection{Assertion utils}
%* *
%************************************************************************
ppr_op op = quotes (ppr op) -- Here, op can be a Name or a (Var n), where n is a Name
pp_prefix_minus = ptext SLIT("prefix `-'")
-dupFieldErr str (dup:rest)
- = hsep [ptext SLIT("duplicate field name"),
- quotes (ppr dup),
- ptext SLIT("in record"), text str]
-
nonStdGuardErr guard
= hang (ptext
SLIT("accepting non-standard pattern guards (-fglasgow-exts to suppress this message)")
) 4 (ppr guard)
-patSigErr ty
- = (ptext SLIT("Illegal signature in pattern:") <+> ppr ty)
- $$ nest 4 (ptext SLIT("Use -fglasgow-exts to permit it"))
-
patSynErr e
= 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:"),
+ nest 4 (ppr e)]
+
thErr what
= ptext SLIT("Template Haskell") <+> text what <+>
ptext SLIT("illegal in a stage-1 compiler")
-doStmtListErr e
- = sep [ptext SLIT("`do' statements must end in expression:"),
- nest 4 (ppr e)]
-
-bogusCharError c
- = ptext SLIT("character literal out of range: '\\") <> int c <> char '\''
withWarning
= sep [quotes (ptext SLIT("with")),
GlobalRdrElt(..), unQualInScope, isLocalGRE
)
import RdrName ( rdrNameOcc, setRdrNameSpace, emptyRdrEnv, foldRdrEnv, isQual )
-import SrcLoc ( noSrcLoc )
import Outputable
import Maybes ( maybeToBool, catMaybes )
import ListSetOps ( removeDups )
__interface RnSource 1 0 where
-__export RnSource rnBinds rnSrcDecls;
+__export RnSource rnBindsAndThen rnBinds rnSrcDecls;
-1 rnBinds :: __forall [b] => RdrHsSyn.RdrNameHsBinds
+1 rnBindsAndThen :: __forall [b] => RdrHsSyn.RdrNameHsBinds
-> (RnHsSyn.RenamedHsBinds
-> TcRnTypes.RnM (b, NameSet.FreeVars))
-> TcRnTypes.RnM (b, NameSet.FreeVars) ;
+1 rnBinds :: RdrHsSyn.RdrNameHsBinds
+ -> TcRnTypes.RnM (RnHsSyn.RenamedHsBinds, NameSet.FreeVars) ;
+
1 rnSrcDecls :: [RdrHsSyn.RdrNameHsDecl]
-> TcRnTypes.RnM (TcRnTypes.TcGblEnv, [RnHsSyn.RenamedHsDecl], NameSet.FreeVars) ;
module RnSource where
-rnBinds :: forall b . RdrHsSyn.RdrNameHsBinds
+rnBindsAndThen :: forall b . RdrHsSyn.RdrNameHsBinds
-> (RnHsSyn.RenamedHsBinds
-> TcRnTypes.RnM (b, NameSet.FreeVars))
-> TcRnTypes.RnM (b, NameSet.FreeVars) ;
+rnBinds :: RdrHsSyn.RdrNameHsBinds
+ -> TcRnTypes.RnM (RnHsSyn.RenamedHsBinds, NameSet.FreeVars) ;
+
rnSrcDecls :: [RdrHsSyn.RdrNameHsDecl]
-> TcRnTypes.RnM (TcRnTypes.TcGblEnv, [RnHsSyn.RenamedHsDecl], NameSet.FreeVars)
module RnSource (
rnSrcDecls, rnExtCoreDecls, checkModDeprec,
rnTyClDecl, rnIfaceRuleDecl, rnInstDecl,
- rnBinds, rnStats,
+ rnBinds, rnBindsAndThen, rnStats,
) where
#include "HsVersions.h"
-import RnExpr
import HsSyn
import RdrName ( RdrName, isRdrDataCon, elemRdrEnv )
import RdrHsSyn ( RdrNameConDecl, RdrNameTyClDecl, RdrNameHsDecl,
import HsCore
import RnNames ( importsFromLocalDecls )
+import RnExpr ( rnExpr )
import RnTypes ( rnHsType, rnHsSigType, rnHsTypeFVs, rnContext )
import RnBinds ( rnTopMonoBinds, rnMonoBinds, rnMethodBinds,
- renameSigs, renameSigsFVs )
+ rnMonoBindsAndThen, renameSigs, checkSigs )
import RnEnv ( lookupTopBndrRn, lookupOccRn, lookupSysBndr,
newLocalsRn, lookupGlobalOccRn,
bindLocalsFVRn, bindPatSigTyVars,
rnTopBinds (MonoBind bind sigs _) = rnTopMonoBinds bind sigs
-- The parser doesn't produce other forms
-rnBinds :: RdrNameHsBinds
- -> (RenamedHsBinds -> RnM (result, FreeVars))
- -> RnM (result, FreeVars)
-rnBinds EmptyBinds thing_inside = thing_inside EmptyBinds
-rnBinds (MonoBind bind sigs _) thing_inside = rnMonoBinds bind sigs thing_inside
- -- the parser doesn't produce other forms
+rnBinds :: RdrNameHsBinds -> RnM (RenamedHsBinds, FreeVars)
+-- This version assumes that the binders are already in scope
+rnBinds EmptyBinds = returnM (EmptyBinds, emptyFVs)
+rnBinds (MonoBind bind sigs _) = rnMonoBinds bind sigs
+ -- The parser doesn't produce other forms
+
+rnBindsAndThen :: RdrNameHsBinds
+ -> (RenamedHsBinds -> RnM (result, FreeVars))
+ -> RnM (result, FreeVars)
+-- This version (a) assumes that the binding vars are not already in scope
+-- (b) removes the binders from the free vars of the thing inside
+rnBindsAndThen EmptyBinds thing_inside = thing_inside EmptyBinds
+rnBindsAndThen (MonoBind bind sigs _) thing_inside = rnMonoBindsAndThen bind sigs thing_inside
+ -- The parser doesn't produce other forms
\end{code}
rnMethodBinds cls [] mbinds
) `thenM` \ (mbinds', meth_fvs) ->
let
- binders = collectMonoBinders mbinds'
- binder_set = mkNameSet binders
+ binders = collectMonoBinders mbinds'
in
-- Rename the prags and signatures.
-- Note that the type variables are not in scope here,
-- works OK.
--
-- But the (unqualified) method names are in scope
- bindLocalNames binders (
- renameSigsFVs (okInstDclSig binder_set) uprags
- ) `thenM` \ (uprags', prag_fvs) ->
+ bindLocalNames binders (renameSigs uprags) `thenM` \ uprags' ->
+ checkSigs okInstDclSig (mkNameSet binders) uprags' `thenM_`
returnM (InstDecl inst_ty mbinds' uprags' maybe_dfun_name src_loc,
- meth_fvs `plusFV` prag_fvs)
+ meth_fvs `plusFV` hsSigsFVs uprags')
\end{code}
%*********************************************************
let
binders = mkNameSet [ nm | (ClassOpSig nm _ _ _) <- sigs' ]
in
- renameSigs (okClsDclSig binders) non_op_sigs `thenM` \ non_ops' ->
-
+ renameSigs non_op_sigs `thenM` \ non_ops' ->
+ checkSigs okClsDclSig binders non_ops' `thenM_`
-- Typechecker is responsible for checking that we only
-- give default-method bindings for things in this class.
-- The renamer *could* check this for class decls, but can't
\section[RnSource]{Main pass of renamer}
\begin{code}
-module RnTypes ( rnHsType, rnHsSigType, rnHsTypeFVs, rnHsSigTypeFVs,
- rnContext, precParseErr, sectionPrecErr ) where
+module RnTypes ( rnHsType, rnContext,
+ rnHsSigType, rnHsTypeFVs, rnHsSigTypeFVs,
+ rnPat, rnPats, rnPatsAndThen, -- Here because it's not part
+ rnOverLit, litFVs, -- of any mutual recursion
+ precParseErr, sectionPrecErr, dupFieldErr, patSigErr
+ ) where
import CmdLineOpts ( DynFlag(Opt_WarnMisc, Opt_WarnUnusedMatches, Opt_GlasgowExts) )
import HsSyn
-import RdrHsSyn ( RdrNameContext, RdrNameHsType, extractHsTyRdrTyVars, extractHsCtxtRdrTyVars )
-import RnHsSyn ( RenamedContext, RenamedHsType, extractHsTyNames )
-import RnEnv ( lookupOccRn, newIPName, bindTyVarsRn, lookupFixityRn )
+import RdrHsSyn ( RdrNameContext, RdrNameHsType, RdrNamePat,
+ extractHsTyRdrTyVars, extractHsCtxtRdrTyVars )
+import RnHsSyn ( RenamedContext, RenamedHsType, RenamedPat,
+ extractHsTyNames,
+ parrTyCon_name, tupleTyCon_name, listTyCon_name, charTyCon_name )
+import RnEnv ( lookupOccRn, lookupBndrRn, lookupSyntaxName, lookupGlobalOccRn,
+ newIPName, bindTyVarsRn, lookupFixityRn, mapFvRn,
+ bindPatSigTyVars, bindLocalsFVRn, warnUnusedMatches )
import TcRnMonad
-import PrelInfo ( cCallishClassKeys )
-import RdrName ( elemRdrEnv )
-import Name ( Name )
-import NameSet ( FreeVars )
+import PrelInfo ( cCallishClassKeys, eqStringName, eqClassName, ordClassName,
+ negateName, minusName, lengthPName, indexPName, plusIntegerName, fromIntegerName,
+ timesIntegerName, ratioDataConName, fromRationalName, cCallableClassName )
+import TysWiredIn ( intTyCon )
+import TysPrim ( charPrimTyCon, addrPrimTyCon, intPrimTyCon,
+ floatPrimTyCon, doublePrimTyCon )
+import RdrName ( RdrName, elemRdrEnv )
+import Name ( Name, NamedThing(..) )
+import NameSet
import Unique ( Uniquable(..) )
+import Literal ( inIntRange, inCharRange )
import BasicTypes ( compareFixity, arrowFixity )
import List ( nub )
-import ListSetOps ( removeDupsEq )
+import ListSetOps ( removeDupsEq, removeDups )
import Outputable
#include "HsVersions.h"
\end{code}
+*********************************************************
+* *
+\subsection{Patterns}
+* *
+*********************************************************
+
+\begin{code}
+rnPatsAndThen :: HsMatchContext RdrName
+ -> [RdrNamePat]
+ -> ([RenamedPat] -> RnM (a, FreeVars))
+ -> RnM (a, FreeVars)
+-- Bring into scope all the binders and type variables
+-- bound by the patterns; then rename the patterns; then
+-- do the thing inside.
+--
+-- Note that we do a single bindLocalsRn for all the
+-- matches together, so that we spot the repeated variable in
+-- f x x = 1
+
+rnPatsAndThen ctxt pats thing_inside
+ = bindPatSigTyVars pat_sig_tys $
+ bindLocalsFVRn doc_pat bndrs $ \ new_bndrs ->
+ rnPats pats `thenM` \ (pats', pat_fvs) ->
+ thing_inside pats' `thenM` \ (res, res_fvs) ->
+
+ let
+ unused_binders = filter (not . (`elemNameSet` res_fvs)) new_bndrs
+ in
+ warnUnusedMatches unused_binders `thenM_`
+
+ returnM (res, res_fvs `plusFV` pat_fvs)
+ where
+ pat_sig_tys = collectSigTysFromPats pats
+ bndrs = collectPatsBinders pats
+ doc_pat = pprMatchContext ctxt
+
+rnPats :: [RdrNamePat] -> RnM ([RenamedPat], FreeVars)
+rnPats ps = mapFvRn rnPat ps
+
+rnPat :: RdrNamePat -> RnM (RenamedPat, FreeVars)
+
+rnPat (WildPat _) = returnM (WildPat placeHolderType, emptyFVs)
+
+rnPat (VarPat name)
+ = lookupBndrRn name `thenM` \ vname ->
+ returnM (VarPat vname, emptyFVs)
+
+rnPat (SigPatIn pat ty)
+ = doptM Opt_GlasgowExts `thenM` \ glaExts ->
+
+ if glaExts
+ then rnPat pat `thenM` \ (pat', fvs1) ->
+ rnHsTypeFVs doc ty `thenM` \ (ty', fvs2) ->
+ returnM (SigPatIn pat' ty', fvs1 `plusFV` fvs2)
+
+ else addErr (patSigErr ty) `thenM_`
+ rnPat pat
+ where
+ doc = text "In a pattern type-signature"
+
+rnPat (LitPat s@(HsString _))
+ = returnM (LitPat s, unitFV eqStringName)
+
+rnPat (LitPat lit)
+ = litFVs lit `thenM` \ fvs ->
+ returnM (LitPat lit, fvs)
+
+rnPat (NPatIn lit mb_neg)
+ = rnOverLit lit `thenM` \ (lit', fvs1) ->
+ (case mb_neg of
+ Nothing -> returnM (Nothing, emptyFVs)
+ Just _ -> lookupSyntaxName negateName `thenM` \ (neg, fvs) ->
+ returnM (Just neg, fvs)
+ ) `thenM` \ (mb_neg', fvs2) ->
+ returnM (NPatIn lit' mb_neg',
+ fvs1 `plusFV` fvs2 `addOneFV` eqClassName)
+ -- Needed to find equality on pattern
+
+rnPat (NPlusKPatIn name lit _)
+ = rnOverLit lit `thenM` \ (lit', fvs1) ->
+ lookupBndrRn name `thenM` \ name' ->
+ lookupSyntaxName minusName `thenM` \ (minus, fvs2) ->
+ returnM (NPlusKPatIn name' lit' minus,
+ fvs1 `plusFV` fvs2 `addOneFV` ordClassName)
+
+rnPat (LazyPat pat)
+ = rnPat pat `thenM` \ (pat', fvs) ->
+ returnM (LazyPat pat', fvs)
+
+rnPat (AsPat name pat)
+ = rnPat pat `thenM` \ (pat', fvs) ->
+ lookupBndrRn name `thenM` \ vname ->
+ returnM (AsPat vname pat', fvs)
+
+rnPat (ConPatIn con stuff) = rnConPat con stuff
+
+
+rnPat (ParPat pat)
+ = rnPat pat `thenM` \ (pat', fvs) ->
+ returnM (ParPat pat', fvs)
+
+rnPat (ListPat pats _)
+ = rnPats pats `thenM` \ (patslist, fvs) ->
+ returnM (ListPat patslist placeHolderType, fvs `addOneFV` listTyCon_name)
+
+rnPat (PArrPat pats _)
+ = rnPats pats `thenM` \ (patslist, fvs) ->
+ returnM (PArrPat patslist placeHolderType,
+ fvs `plusFV` implicit_fvs `addOneFV` parrTyCon_name)
+ where
+ implicit_fvs = mkFVs [lengthPName, indexPName]
+
+rnPat (TuplePat pats boxed)
+ = rnPats pats `thenM` \ (patslist, fvs) ->
+ returnM (TuplePat patslist boxed, fvs `addOneFV` tycon_name)
+ where
+ tycon_name = tupleTyCon_name boxed (length pats)
+
+rnPat (TypePat name) =
+ rnHsTypeFVs (text "In a type pattern") name `thenM` \ (name', fvs) ->
+ returnM (TypePat name', fvs)
+
+------------------------------
+rnConPat con (PrefixCon pats)
+ = lookupOccRn con `thenM` \ con' ->
+ rnPats pats `thenM` \ (pats', fvs) ->
+ returnM (ConPatIn con' (PrefixCon pats'), fvs `addOneFV` con')
+
+rnConPat con (RecCon rpats)
+ = lookupOccRn con `thenM` \ con' ->
+ rnRpats rpats `thenM` \ (rpats', fvs) ->
+ returnM (ConPatIn con' (RecCon rpats'), fvs `addOneFV` con')
+
+rnConPat con (InfixCon pat1 pat2)
+ = lookupOccRn con `thenM` \ con' ->
+ rnPat pat1 `thenM` \ (pat1', fvs1) ->
+ rnPat pat2 `thenM` \ (pat2', fvs2) ->
+
+ getModeRn `thenM` \ mode ->
+ -- See comments with rnExpr (OpApp ...)
+ (if isInterfaceMode mode
+ then returnM (ConPatIn con' (InfixCon pat1' pat2'))
+ else lookupFixityRn con' `thenM` \ fixity ->
+ mkConOpPatRn con' fixity pat1' pat2'
+ ) `thenM` \ pat' ->
+ returnM (pat', fvs1 `plusFV` fvs2 `addOneFV` con')
+
+------------------------
+rnRpats rpats
+ = mappM_ field_dup_err dup_fields `thenM_`
+ mapFvRn rn_rpat rpats `thenM` \ (rpats', fvs) ->
+ returnM (rpats', fvs)
+ where
+ (_, dup_fields) = removeDups compare [ f | (f,_) <- rpats ]
+
+ field_dup_err dups = addErr (dupFieldErr "pattern" dups)
+
+ rn_rpat (field, pat)
+ = lookupGlobalOccRn field `thenM` \ fieldname ->
+ rnPat pat `thenM` \ (pat', fvs) ->
+ returnM ((fieldname, pat'), fvs `addOneFV` fieldname)
+\end{code}
+
+\begin{code}
+mkConOpPatRn :: Name -> Fixity -> RenamedPat -> RenamedPat
+ -> RnM RenamedPat
+
+mkConOpPatRn op2 fix2 p1@(ConPatIn op1 (InfixCon p11 p12)) p2
+ = lookupFixityRn op1 `thenM` \ fix1 ->
+ let
+ (nofix_error, associate_right) = compareFixity fix1 fix2
+ in
+ if nofix_error then
+ addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenM_`
+ returnM (ConPatIn op2 (InfixCon p1 p2))
+ else
+ if associate_right then
+ mkConOpPatRn op2 fix2 p12 p2 `thenM` \ new_p ->
+ returnM (ConPatIn op1 (InfixCon p11 new_p))
+ else
+ returnM (ConPatIn op2 (InfixCon p1 p2))
+
+mkConOpPatRn op fix p1 p2 -- Default case, no rearrangment
+ = ASSERT( not_op_pat p2 )
+ returnM (ConPatIn op (InfixCon p1 p2))
+
+not_op_pat (ConPatIn _ (InfixCon _ _)) = False
+not_op_pat other = True
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsubsection{Literals}
+%* *
+%************************************************************************
+
+When literals occur we have to make sure
+that the types and classes they involve
+are made available.
+
+\begin{code}
+litFVs (HsChar c)
+ = checkErr (inCharRange c) (bogusCharError c) `thenM_`
+ returnM (unitFV charTyCon_name)
+
+litFVs (HsCharPrim c) = returnM (unitFV (getName charPrimTyCon))
+litFVs (HsString s) = returnM (mkFVs [listTyCon_name, charTyCon_name])
+litFVs (HsStringPrim s) = returnM (unitFV (getName addrPrimTyCon))
+litFVs (HsInt i) = returnM (unitFV (getName intTyCon))
+litFVs (HsIntPrim i) = returnM (unitFV (getName intPrimTyCon))
+litFVs (HsFloatPrim f) = returnM (unitFV (getName floatPrimTyCon))
+litFVs (HsDoublePrim d) = returnM (unitFV (getName doublePrimTyCon))
+litFVs (HsLitLit l bogus_ty) = returnM (unitFV cCallableClassName)
+litFVs lit = pprPanic "RnExpr.litFVs" (ppr lit) -- HsInteger and HsRat only appear
+ -- in post-typechecker translations
+bogusCharError c
+ = ptext SLIT("character literal out of range: '\\") <> int c <> char '\''
+
+rnOverLit (HsIntegral i _)
+ = lookupSyntaxName fromIntegerName `thenM` \ (from_integer_name, fvs) ->
+ if inIntRange i then
+ returnM (HsIntegral i from_integer_name, fvs)
+ else let
+ extra_fvs = mkFVs [plusIntegerName, timesIntegerName]
+ -- Big integer literals are built, using + and *,
+ -- out of small integers (DsUtils.mkIntegerLit)
+ -- [NB: plusInteger, timesInteger aren't rebindable...
+ -- they are used to construct the argument to fromInteger,
+ -- which is the rebindable one.]
+ in
+ returnM (HsIntegral i from_integer_name, fvs `plusFV` extra_fvs)
+
+rnOverLit (HsFractional i _)
+ = lookupSyntaxName fromRationalName `thenM` \ (from_rat_name, fvs) ->
+ let
+ extra_fvs = mkFVs [ratioDataConName, plusIntegerName, timesIntegerName]
+ -- We have to make sure that the Ratio type is imported with
+ -- its constructor, because literals of type Ratio t are
+ -- built with that constructor.
+ -- The Rational type is needed too, but that will come in
+ -- as part of the type for fromRational.
+ -- The plus/times integer operations may be needed to construct the numerator
+ -- and denominator (see DsUtils.mkIntegerLit)
+ in
+ returnM (HsFractional i from_rat_name, fvs `plusFV` extra_fvs)
+\end{code}
+
+
+
%*********************************************************
%* *
\subsection{Errors}
infixTyConWarn op
= ftext FSLIT("Accepting non-standard infix type constructor") <+> quotes (ppr op)
+patSigErr ty
+ = (ptext SLIT("Illegal signature in pattern:") <+> ppr ty)
+ $$ nest 4 (ptext SLIT("Use -fglasgow-exts to permit it"))
+
+dupFieldErr str (dup:rest)
+ = hsep [ptext SLIT("duplicate field name"),
+ quotes (ppr dup),
+ ptext SLIT("in record"), text str]
+
+ppr_op op = quotes (ppr op) -- Here, op can be a Name or a (Var n), where n is a Name
ppr_opfix (pp_op, fixity) = pp_op <+> brackets (ppr fixity)
\end{code}
\ No newline at end of file
import CmdLineOpts
import UnicodeUtil ( stringToUtf8 )
import ErrUtils ( dumpIfSet )
-import Util ( count, lengthIs, equalLength )
+import Util ( count, lengthIs )
import Maybes ( seqMaybe )
import Maybe ( isJust )
import FastString
import HsSyn ( Pat(..), HsConDetails(..), HsExpr(..), MonoBinds(..),
Match(..), GRHSs(..), Stmt(..), HsLit(..),
- HsBinds(..), HsType(..), HsDoContext(..),
+ HsBinds(..), HsType(..), HsStmtContext(..),
unguardedRHS, mkSimpleMatch, mkMonoBind, andMonoBindList, placeHolderType
)
import RdrName ( RdrName, mkUnqual, nameRdrName, getRdrName )
= zonkMonoBinds env mbinds1 `thenM` \ (b1', ids1) ->
zonkMonoBinds env mbinds2 `thenM` \ (b2', ids2) ->
returnM (b1' `AndMonoBinds` b2',
- ids1 `unionBags` ids2)
+ ids1 `unionBags` ids2)
zonkMonoBinds env (PatMonoBind pat grhss locn)
= zonkPat env pat `thenM` \ (new_pat, ids) ->
zonkExpr env e3 `thenM` \ new_e3 ->
returnM (FromThenTo new_e1 new_e2 new_e3)
+
-------------------------------------------------------------------------
zonkStmts :: ZonkEnv -> [TcStmt] -> TcM [TypecheckedStmt]
zonkStmts env [] = returnM []
zonkStmts env (ParStmtOut bndrstmtss : stmts)
- = mappM (mappM zonkId) bndrss `thenM` \ new_bndrss ->
+ = mappM (mappM zonkId) bndrss `thenM` \ new_bndrss ->
mappM (zonkStmts env) stmtss `thenM` \ new_stmtss ->
let
new_binders = concat new_bndrss
where
(bndrss, stmtss) = unzip bndrstmtss
+zonkStmts env (RecStmt vs segStmts : stmts)
+ = mappM zonkId vs `thenM` \ new_vs ->
+ let
+ env1 = extendZonkEnv env new_vs
+ in
+ zonkStmts env1 segStmts `thenM` \ new_segStmts ->
+ zonkStmts env1 stmts `thenM` \ new_stmts ->
+ returnM (RecStmt new_vs new_segStmts : new_stmts)
+
zonkStmts env (ResultStmt expr locn : stmts)
= zonkExpr env expr `thenM` \ new_expr ->
zonkStmts env stmts `thenM` \ new_stmts ->
eqKind, isTypeKind,
isFFIArgumentTy, isFFIImportResultTy
)
-import qualified Type ( splitFunTys )
import Subst ( Subst, mkTopTyVarSubst, substTy )
import Class ( Class, DefMeth(..), classArity, className, classBigSig )
import TyCon ( TyCon, isSynTyCon, isUnboxedTupleTyCon,
- tyConArity, tyConName, tyConKind, tyConTheta,
+ tyConArity, tyConName, tyConTheta,
getSynTyConDefn, tyConDataCons )
import DataCon ( DataCon, dataConWrapId, dataConName, dataConSig, dataConFieldLabels )
import FieldLabel ( fieldLabelName, fieldLabelType )
import ForeignCall ( Safety(..) )
import FunDeps ( grow )
import PprType ( pprPred, pprSourceType, pprTheta, pprClassPred )
-import Name ( Name, NamedThing(..), setNameUnique,
- mkSystemTvNameEncoded,
- )
+import Name ( Name, setNameUnique, mkSystemTvNameEncoded )
import VarSet
-import BasicTypes ( Boxity(Boxed) )
import CmdLineOpts ( dopt, DynFlag(..) )
-import SrcLoc ( noSrcLoc )
import Util ( nOfThem, isSingleton, equalLength, notNull )
import ListSetOps ( equivClasses, removeDups )
import Outputable
import {-# SOURCE #-} TcExpr( tcMonoExpr )
import HsSyn ( HsExpr(..), HsBinds(..), Match(..), GRHSs(..), GRHS(..),
- MonoBinds(..), Stmt(..), HsMatchContext(..), HsDoContext(..),
- pprMatch, getMatchLoc, pprMatchContext, isDoExpr,
+ MonoBinds(..), Stmt(..), HsMatchContext(..), HsStmtContext(..),
+ pprMatch, getMatchLoc, pprMatchContext, pprStmtCtxt, isDoExpr,
mkMonoBind, nullMonoBinds, collectSigTysFromPats, andMonoBindList
)
import RnHsSyn ( RenamedMatch, RenamedGRHSs, RenamedStmt,
import TcRnMonad
import TcMonoType ( tcAddScopedTyVars, tcHsSigType, UserTypeCtxt(..) )
import Inst ( tcSyntaxName )
-import TcEnv ( TcId, tcLookupLocalIds, tcExtendLocalValEnv2 )
+import TcEnv ( TcId, tcLookupLocalIds, tcExtendLocalValEnv, tcExtendLocalValEnv2 )
import TcPat ( tcPat, tcMonoPatBndr )
-import TcMType ( newTyVarTy, zonkTcType, zapToType )
+import TcMType ( newTyVarTy, newTyVarTys, zonkTcType, zapToType )
import TcType ( TcType, TcTyVar, tyVarsOfType, tidyOpenTypes, tidyOpenType,
mkFunTy, isOverloadedTy, liftedTypeKind, openTypeKind,
mkArrowKind, mkAppTy )
import TcBinds ( tcBindsAndThen )
import TcUnify ( unifyPArrTy,subFunTy, unifyListTy, unifyTauTy,
- checkSigTyVarsWrt, tcSubExp, isIdCoercion, (<$>) )
+ checkSigTyVarsWrt, tcSubExp, isIdCoercion, (<$>), unifyTauTyLists )
import TcSimplify ( tcSimplifyCheck, bindInstsOfLocalFuns )
import Name ( Name )
-import PrelNames ( monadNames )
+import PrelNames ( monadNames, mfixName )
import TysWiredIn ( boolTy, mkListTy, mkPArrTy )
-import Id ( idType, mkSysLocal )
+import Id ( idType, mkSysLocal, mkLocalId )
import CoreFVs ( idFreeTyVars )
import BasicTypes ( RecFlag(..) )
import VarSet
returnM (GRHSs grhss' EmptyBinds expected_ty)
tc_grhs (GRHS guarded locn)
- = addSrcLoc locn $
- tcStmts ctxt (\ty -> ty, expected_ty) guarded `thenM` \ guarded' ->
+ = addSrcLoc locn $
+ tcStmts PatGuard (\ty -> ty, expected_ty) guarded `thenM` \ guarded' ->
returnM (GRHS guarded' locn)
\end{code}
%************************************************************************
\begin{code}
-tcDoStmts :: HsDoContext -> [RenamedStmt] -> [Name] -> TcType
+tcDoStmts :: HsStmtContext -> [RenamedStmt] -> [Name] -> TcType
-> TcM (TcMonoBinds, [TcStmt], [Id])
tcDoStmts PArrComp stmts method_names res_ty
- = unifyPArrTy res_ty `thenM` \elt_ty ->
- tcStmts (DoCtxt PArrComp)
- (mkPArrTy, elt_ty) stmts `thenM` \ stmts' ->
+ = unifyPArrTy res_ty `thenM` \elt_ty ->
+ tcStmts PArrComp (mkPArrTy, elt_ty) stmts `thenM` \ stmts' ->
returnM (EmptyMonoBinds, stmts', [{- unused -}])
tcDoStmts ListComp stmts method_names res_ty
- = unifyListTy res_ty `thenM` \ elt_ty ->
- tcStmts (DoCtxt ListComp)
- (mkListTy, elt_ty) stmts `thenM` \ stmts' ->
+ = unifyListTy res_ty `thenM` \ elt_ty ->
+ tcStmts ListComp (mkListTy, elt_ty) stmts `thenM` \ stmts' ->
returnM (EmptyMonoBinds, stmts', [{- unused -}])
-tcDoStmts DoExpr stmts method_names res_ty
+tcDoStmts do_or_mdo_expr stmts method_names res_ty
= newTyVarTy (mkArrowKind liftedTypeKind liftedTypeKind) `thenM` \ m_ty ->
newTyVarTy liftedTypeKind `thenM` \ elt_ty ->
unifyTauTy res_ty (mkAppTy m_ty elt_ty) `thenM_`
- tcStmts (DoCtxt DoExpr) (mkAppTy m_ty, elt_ty) stmts `thenM` \ stmts' ->
+ tcStmts do_or_mdo_expr (mkAppTy m_ty, elt_ty) stmts `thenM` \ stmts' ->
-- Build the then and zero methods in case we need them
-- It's important that "then" and "return" appear just once in the final LIE,
-- where the second "then" sees that it already exists in the "available" stuff.
--
mapAndUnzipM (tc_syn_name m_ty)
- (zipEqual "tcDoStmts" monadNames method_names) `thenM` \ (binds, ids) ->
+ (zipEqual "tcDoStmts" currentMonadNames method_names) `thenM` \ (binds, ids) ->
returnM (andMonoBindList binds, stmts', ids)
where
+ currentMonadNames = case do_or_mdo_expr of
+ DoExpr -> monadNames
+ MDoExpr -> monadNames ++ [mfixName]
tc_syn_name :: TcType -> (Name,Name) -> TcM (TcMonoBinds, Id)
tc_syn_name m_ty (std_nm, usr_nm)
= tcSyntaxName DoOrigin m_ty std_nm usr_nm `thenM` \ (expr, expr_ty) ->
tcStmtsAndThen
:: (TcStmt -> thing -> thing) -- Combiner
- -> RenamedMatchContext
+ -> HsStmtContext
-> (TcType -> TcType, TcType) -- m, the relationship type of pat and rhs in pat <- rhs
-- elt_ty, where type of the comprehension is (m elt_ty)
-> [RenamedStmt]
loop ((bndrs,stmts) : pairs)
= tcStmtsAndThen
- combine_par (DoCtxt ListComp) m_ty stmts
+ combine_par ListComp m_ty stmts
-- Notice we pass on m_ty; the result type is used only
-- to get escaping type variables for checkExistentialPat
(tcLookupLocalIds bndrs `thenM` \ bndrs' ->
combine_par stmt (stmts, thing) = (stmt:stmts, thing)
+ -- RecStmt
+tcStmtAndThen combine do_or_lc m_ty (RecStmt recNames stmts) thing_inside
+ = newTyVarTys (length recNames) liftedTypeKind `thenM` \ recTys ->
+ tcExtendLocalValEnv (zipWith mkLocalId recNames recTys) $
+ tcStmtsAndThen combine_rec do_or_lc m_ty stmts (
+ tcLookupLocalIds recNames `thenM` \ rn ->
+ returnM ([], rn)
+ ) `thenM` \ (stmts', recNames') ->
+
+ -- Unify the types of the "final" Ids with those of "knot-tied" Ids
+ unifyTauTyLists recTys (map idType recNames') `thenM_`
+
+ thing_inside `thenM` \ thing ->
+
+ returnM (combine (RecStmt recNames' stmts') thing)
+ where
+ combine_rec stmt (stmts, thing) = (stmt:stmts, thing)
+
-- ExprStmt
tcStmtAndThen combine do_or_lc m_ty@(m, res_elt_ty) stmt@(ExprStmt exp _ locn) thing_inside
= setErrCtxt (stmtCtxt do_or_lc stmt) (
varyingArgsErr name matches
= sep [ptext SLIT("Varying number of arguments for function"), quotes (ppr name)]
-matchCtxt ctxt match = hang (pprMatchContext ctxt <> colon) 4 (pprMatch ctxt match)
-stmtCtxt do_or_lc stmt = hang (pprMatchContext do_or_lc <> colon) 4 (ppr stmt)
+matchCtxt ctxt match = hang (pprMatchContext ctxt <> colon) 4 (pprMatch ctxt match)
+stmtCtxt do_or_lc stmt = hang (pprStmtCtxt do_or_lc <> colon) 4 (ppr stmt)
sigPatCtxt bound_tvs bound_ids match_ty tidy_env
= zonkTcType match_ty `thenM` \ match_ty' ->
import CmdLineOpts ( DynFlag(..), opt_PprStyle_Debug, dopt )
import HsSyn ( HsModule(..), HsBinds(..), MonoBinds(..), HsDecl(..), HsExpr(..),
- Stmt(..), Pat(VarPat), HsMatchContext(..), HsDoContext(..), RuleDecl(..),
+ Stmt(..), Pat(VarPat), HsStmtContext(..), RuleDecl(..),
mkSimpleMatch, placeHolderType, toHsType, andMonoBinds,
- isSrcRule
+ isSrcRule, collectStmtsBinders
)
import RdrHsSyn ( RdrNameHsModule, RdrNameHsDecl, RdrNameStmt, RdrNameHsExpr )
setInteractiveContext ictxt $ do {
-- Rename; use CmdLineMode because tcRnStmt is only used interactively
- ((bound_names, [rn_stmt]), fvs) <- initRnInteractive ictxt
- (rnStmts [rdr_stmt]) ;
+ ([rn_stmt], fvs) <- initRnInteractive ictxt
+ (rnStmts DoExpr [rdr_stmt]) ;
traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) ;
failIfErrsM ;
setGblEnv tcg_env $ do {
-- The real work is done here
- ((bound_ids, tc_expr), lie) <- getLIE (tcUserStmt bound_names rn_stmt) ;
+ ((bound_ids, tc_expr), lie) <- getLIE (tcUserStmt rn_stmt) ;
traceTc (text "tcs 1") ;
let { -- Make all the bound ids "global" ids, now that
\begin{code}
---------------------------
-tcUserStmt :: [Name] -> RenamedStmt -> TcM ([Id], TypecheckedHsExpr)
-tcUserStmt names (ExprStmt expr _ loc)
- = ASSERT( null names )
- newUnique `thenM` \ uniq ->
+tcUserStmt :: RenamedStmt -> TcM ([Id], TypecheckedHsExpr)
+tcUserStmt (ExprStmt expr _ loc)
+ = newUnique `thenM` \ uniq ->
let
fresh_it = itName uniq
the_bind = FunMonoBind fresh_it False
in
tryTc_ (do { -- Try this if the other fails
traceTc (text "tcs 1b") ;
- tc_stmts [fresh_it] [
+ tc_stmts [
LetStmt (MonoBind the_bind [] NonRecursive),
ExprStmt (HsApp (HsVar printName) (HsVar fresh_it))
placeHolderType loc] })
(do { -- Try this first
traceTc (text "tcs 1a") ;
- tc_stmts [fresh_it] [BindStmt (VarPat fresh_it) expr loc] })
+ tc_stmts [BindStmt (VarPat fresh_it) expr loc] })
-tcUserStmt names stmt
- = tc_stmts names [stmt]
+tcUserStmt stmt = tc_stmts [stmt]
---------------------------
-tc_stmts names stmts
+tc_stmts stmts
= do { io_ids <- mappM tcLookupId
[returnIOName, failIOName, bindIOName, thenIOName] ;
ioTyCon <- tcLookupTyCon ioTyConName ;
res_ty <- newTyVarTy liftedTypeKind ;
let {
+ names = collectStmtsBinders stmts ;
return_id = head io_ids ; -- Rather gruesome
io_ty = (\ ty -> mkTyConApp ioTyCon [ty], res_ty) ;
-- OK, we're ready to typecheck the stmts
traceTc (text "tcs 2") ;
((ids, tc_stmts), lie) <-
- getLIE $ tcStmtsAndThen combine (DoCtxt DoExpr) io_ty stmts $
+ getLIE $ tcStmtsAndThen combine DoExpr io_ty stmts $
do {
-- Look up the names right in the middle,
-- where they will all be in scope
#include "HsVersions.h"
-import HsSyn ( RuleDecl(..), RuleBndr(..), HsExpr(..), collectRuleBndrSigTys )
+import HsSyn ( RuleDecl(..), RuleBndr(..), collectRuleBndrSigTys )
import CoreSyn ( CoreRule(..) )
import RnHsSyn ( RenamedRuleDecl )
-import TcHsSyn ( TypecheckedRuleDecl, TcExpr, mkHsLet )
+import TcHsSyn ( TypecheckedRuleDecl, mkHsLet )
import TcRnMonad
import TcSimplify ( tcSimplifyToDicts, tcSimplifyInferCheck )
import TcMType ( newTyVarTy )
-import TcType ( TcTyVarSet, tyVarsOfTypes, tyVarsOfType, openTypeKind )
+import TcType ( tyVarsOfTypes, openTypeKind )
import TcIfaceSig ( tcCoreExpr, tcCoreLamBndrs, tcVar )
import TcMonoType ( tcHsSigType, UserTypeCtxt(..), tcAddScopedTyVars )
import TcExpr ( tcMonoExpr )
import TcEnv ( tcExtendLocalValEnv )
import Inst ( instToId )
import Id ( idType, mkLocalId )
-import VarSet
import Outputable
\end{code}
isTypeOrClassDecl, isClassDecl, isSynDecl, isClassOpSig
)
import RnHsSyn ( RenamedTyClDecl, tyClDeclFVs )
-import BasicTypes ( RecFlag(..), isNonRec, NewOrData(..) )
+import BasicTypes ( RecFlag(..), NewOrData(..) )
import HscTypes ( implicitTyThingIds )
import TcRnMonad
import Var ( varName )
import FiniteMap
import Digraph ( stronglyConnComp, SCC(..) )
-import Name ( Name, getSrcLoc )
+import Name ( Name )
import NameEnv
import NameSet
import Outputable
import Maybes ( mapMaybe )
-import ErrUtils ( Message )
\end{code}
=> [(node, key, [key])] -- The graph; its ok for the
-- out-list to contain keys which arent
-- a vertex key, they are ignored
- -> [SCC (node, key, [key])]
+ -> [SCC (node, key, [key])] -- Topologically sorted
stronglyConnCompR [] = [] -- added to avoid creating empty array in graphFromEdges -- SOF
stronglyConnCompR edges
\begin{code}
pprWithCommas :: (a -> SDoc) -> [a] -> SDoc
-pprWithCommas pp xs = hsep (punctuate comma (map pp xs))
+pprWithCommas pp xs = fsep (punctuate comma (map pp xs))
interppSP :: Outputable a => [a] -> SDoc
interppSP xs = hsep (map ppr xs)
projects / ghc-hetmet.git / commitdiff