strictnessInfo :: StrictnessInfo, -- Strictness properties
#endif
workerInfo :: WorkerInfo, -- Pointer to Worker Function
+ -- Within one module this is irrelevant; the
+ -- inlining of a worker is handled via the Unfolding
+ -- WorkerInfo is used *only* to indicate the form of
+ -- the RHS, so that interface files don't actually
+ -- need to contain the RHS; it can be derived from
+ -- the strictness info
+
unfoldingInfo :: Unfolding, -- Its unfolding
cafInfo :: CafInfo, -- CAF info
lbvarInfo :: LBVarInfo, -- Info about a lambda-bound variable
get_used_lits' :: [(EqnNo, EquationInfo)] -> [HsLit]
get_used_lits' [] = []
get_used_lits' (q:qs)
- | LitPat lit <- first_pat = lit : get_used_lits qs
- | NPatOut lit _ _ <- first_pat = lit : get_used_lits qs
- | otherwise = get_used_lits qs
+ | LitPat lit <- first_pat = lit : get_used_lits qs
+ | NPat lit _ _ _ <- first_pat = over_lit_lit lit : get_used_lits qs
+ | otherwise = get_used_lits qs
where
first_pat = firstPatN q
+over_lit_lit :: HsOverLit id -> HsLit
+-- Get a representative HsLit to stand for the OverLit
+-- It doesn't matter which one, because they will only be compared
+-- with other HsLits gotten in the same way
+over_lit_lit (HsIntegral i _) = HsIntPrim i
+over_lit_lit (HsFractional f _) = HsFloatPrim f
+
get_unused_cons :: [Pat Id] -> [DataCon]
get_unused_cons used_cons = unused_cons
where
is_lit :: Pat Id -> Bool
is_lit (LitPat _) = True
-is_lit (NPatOut _ _ _) = True
+is_lit (NPat _ _ _ _) = True
is_lit _ = False
is_var :: Pat Id -> Bool
is_var_con con _ = False
is_var_lit :: HsLit -> Pat Id -> Bool
-is_var_lit lit (WildPat _) = True
-is_var_lit lit (LitPat lit') | lit == lit' = True
-is_var_lit lit (NPatOut lit' _ _) | lit == lit' = True
-is_var_lit lit _ = False
+is_var_lit lit (WildPat _) = True
+is_var_lit lit (LitPat lit') = lit == lit'
+is_var_lit lit (NPat lit' _ _ _) = lit == over_lit_lit lit'
+is_var_lit lit _ = False
\end{code}
The difference beteewn @make_con@ and @make_whole_con@ is that
where
arity = length ps
-simplify_pat pat@(LitPat lit) = unLoc (tidyLitPat lit (noLoc pat))
-
-- unpack string patterns fully, so we can see when they overlap with
-- each other, or even explicit lists of Chars.
-simplify_pat pat@(NPatOut (HsString s) _ _) =
+simplify_pat pat@(LitPat (HsString s)) =
foldr (\c pat -> mk_simple_con_pat consDataCon (PrefixCon [mk_char_lit c,noLoc pat]) stringTy)
(mk_simple_con_pat nilDataCon (PrefixCon []) stringTy) (unpackFS s)
where
mk_char_lit c = noLoc (mk_simple_con_pat charDataCon (PrefixCon [nlLitPat (HsCharPrim c)]) charTy)
-simplify_pat pat@(NPatOut lit lit_ty hsexpr) = unLoc (tidyNPat lit lit_ty (noLoc pat))
+simplify_pat pat@(LitPat lit) = unLoc (tidyLitPat lit (noLoc pat))
+
+simplify_pat pat@(NPat lit mb_neg _ lit_ty) = unLoc (tidyNPat lit mb_neg lit_ty (noLoc pat))
-simplify_pat (NPlusKPatOut id hslit hsexpr1 hsexpr2)
+simplify_pat (NPlusKPat id hslit hsexpr1 hsexpr2)
= WildPat (idType (unLoc id))
simplify_pat (DictPat dicts methods)
mkCoreTupTy, mkCoreTup, selectSimpleMatchVarL,
mkTupleCase, mkBigCoreTup, mkTupleType,
mkTupleExpr, mkTupleSelector,
- dsReboundNames, lookupReboundName )
+ dsSyntaxTable, lookupEvidence )
import DsMonad
import HsSyn
arr_id, compose_id, first_id, app_id, choice_id, loop_id :: CoreExpr
}
-mkCmdEnv :: ReboundNames Id -> DsM DsCmdEnv
+mkCmdEnv :: SyntaxTable Id -> DsM DsCmdEnv
mkCmdEnv ids
- = dsReboundNames ids `thenDs` \ (meth_binds, ds_meths) ->
+ = dsSyntaxTable ids `thenDs` \ (meth_binds, ds_meths) ->
return $ DsCmdEnv {
meth_binds = meth_binds,
- arr_id = lookupReboundName ds_meths arrAName,
- compose_id = lookupReboundName ds_meths composeAName,
- first_id = lookupReboundName ds_meths firstAName,
- app_id = lookupReboundName ds_meths appAName,
- choice_id = lookupReboundName ds_meths choiceAName,
- loop_id = lookupReboundName ds_meths loopAName
+ arr_id = Var (lookupEvidence ds_meths arrAName),
+ compose_id = Var (lookupEvidence ds_meths composeAName),
+ first_id = Var (lookupEvidence ds_meths firstAName),
+ app_id = Var (lookupEvidence ds_meths appAName),
+ choice_id = Var (lookupEvidence ds_meths choiceAName),
+ loop_id = Var (lookupEvidence ds_meths loopAName)
}
bindCmdEnv :: DsCmdEnv -> CoreExpr -> CoreExpr
-- ---> arr (\ ((((xs), p1), ... pk)*ts) -> ((ys)*ts)) >>> c
dsCmd ids local_vars env_ids stack res_ty
- (HsLam (MatchGroup [L _ (Match pats _ (GRHSs [L _ (GRHS [L _ (ResultStmt body)])] _ ))] _))
+ (HsLam (MatchGroup [L _ (Match pats _ (GRHSs [L _ (GRHS [] body)] _ ))] _))
= let
pat_vars = mkVarSet (collectPatsBinders pats)
local_vars' = local_vars `unionVarSet` pat_vars
core_body,
exprFreeVars core_binds `intersectVarSet` local_vars)
-dsCmd ids local_vars env_ids [] res_ty (HsDo _ctxt stmts _ _)
- = dsCmdDo ids local_vars env_ids res_ty stmts
+dsCmd ids local_vars env_ids [] res_ty (HsDo _ctxt stmts body _)
+ = dsCmdDo ids local_vars env_ids res_ty stmts body
-- A |- e :: forall e. a1 (e*ts1) t1 -> ... an (e*tsn) tn -> a (e*ts) t
-- A | xs |- ci :: [tsi] ti
-- This is typically fed back,
-- so don't pull on it too early
-> Type -- return type of the statement
- -> [LStmt Id] -- statements to desugar
+ -> [LStmt Id] -- statements to desugar
+ -> LHsExpr Id -- body
-> DsM (CoreExpr, -- desugared expression
IdSet) -- set of local vars that occur free
-- --------------------------
-- A | xs |- do { c } :: [] t
-dsCmdDo ids local_vars env_ids res_ty [L _ (ResultStmt cmd)]
- = dsLCmd ids local_vars env_ids [] res_ty cmd
+dsCmdDo ids local_vars env_ids res_ty [] body
+ = dsLCmd ids local_vars env_ids [] res_ty body
-dsCmdDo ids local_vars env_ids res_ty (stmt:stmts)
+dsCmdDo ids local_vars env_ids res_ty (stmt:stmts) body
= let
bound_vars = mkVarSet (map unLoc (collectLStmtBinders stmt))
local_vars' = local_vars `unionVarSet` bound_vars
in
fixDs (\ ~(_,_,env_ids') ->
- dsCmdDo ids local_vars' env_ids' res_ty stmts
+ dsCmdDo ids local_vars' env_ids' res_ty stmts body
`thenDs` \ (core_stmts, fv_stmts) ->
returnDs (core_stmts, fv_stmts, varSetElems fv_stmts))
`thenDs` \ (core_stmts, fv_stmts, env_ids') ->
-- ---> arr (\ (xs) -> ((xs1),(xs'))) >>> first c >>>
-- arr snd >>> ss
-dsCmdStmt ids local_vars env_ids out_ids (ExprStmt cmd c_ty)
+dsCmdStmt ids local_vars env_ids out_ids (ExprStmt cmd _ c_ty)
= dsfixCmd ids local_vars [] c_ty cmd
`thenDs` \ (core_cmd, fv_cmd, env_ids1) ->
matchEnvStack env_ids []
-- It would be simpler and more consistent to do this using second,
-- but that's likely to be defined in terms of first.
-dsCmdStmt ids local_vars env_ids out_ids (BindStmt pat cmd)
+dsCmdStmt ids local_vars env_ids out_ids (BindStmt pat cmd _ _)
= dsfixCmd ids local_vars [] (hsPatType pat) cmd
`thenDs` \ (core_cmd, fv_cmd, env_ids1) ->
let
-- first (loop (arr (\((ys1),~(ys2)) -> (ys)) >>> ss)) >>>
-- arr (\((xs1),(xs2)) -> (xs')) >>> ss'
-dsCmdStmt ids local_vars env_ids out_ids (RecStmt stmts later_ids rec_ids rhss)
- = let
+dsCmdStmt ids local_vars env_ids out_ids (RecStmt stmts later_ids rec_ids rhss binds)
+ = let -- ****** binds not desugared; ROSS PLEASE FIX ********
env2_id_set = mkVarSet out_ids `minusVarSet` mkVarSet later_ids
env2_ids = varSetElems env2_id_set
env2_ty = mkTupleType env2_ids
-- mk_pair_fn = \ (out_ids) -> ((later_ids),(rhss))
- mappM dsLExpr rhss `thenDs` \ core_rhss ->
+ mappM dsExpr rhss `thenDs` \ core_rhss ->
let
later_tuple = mkTupleExpr later_ids
later_ty = mkTupleType later_ids
mkVarSet (map unLoc (collectGroupBinders binds))
in
[(expr,
- mkVarSet (map unLoc (collectStmtsBinders stmts))
+ mkVarSet (map unLoc (collectLStmtsBinders stmts))
`unionVarSet` defined_vars)
- | L _ (GRHS stmts) <- grhss,
- let L _ (ResultStmt expr) = last stmts]
+ | L _ (GRHS stmts expr) <- grhss]
\end{code}
Replace the leaf commands in a match
-> LGRHS Id -- rhss of a case command
-> ([LHsExpr Id],-- remaining leaf expressions
LGRHS Id) -- updated GRHS
-replaceLeavesGRHS (leaf:leaves) (L loc (GRHS stmts))
- = (leaves, L loc (GRHS (init stmts ++ [L (getLoc leaf) (ResultStmt leaf)])))
+replaceLeavesGRHS (leaf:leaves) (L loc (GRHS stmts rhs))
+ = (leaves, L loc (GRHS stmts leaf))
\end{code}
Balanced fold of a non-empty list.
#include "HsVersions.h"
-import Match ( matchWrapper, matchSimply )
-import MatchLit ( dsLit )
+import Match ( matchWrapper, matchSimply, matchSinglePat )
+import MatchLit ( dsLit, dsOverLit )
import DsBinds ( dsHsNestedBinds )
import DsGRHSs ( dsGuarded )
import DsListComp ( dsListComp, dsPArrComp )
import DsUtils ( mkErrorAppDs, mkStringExpr, mkConsExpr, mkNilExpr,
- mkCoreTupTy, selectSimpleMatchVarL,
- dsReboundNames, lookupReboundName )
+ extractMatchResult, cantFailMatchResult, matchCanFail,
+ mkCoreTupTy, selectSimpleMatchVarL, lookupEvidence )
import DsArrows ( dsProcExpr )
import DsMonad
-- Sigh. This is a pain.
import TcType ( tcSplitAppTy, tcSplitFunTys, tcTyConAppTyCon, tcTyConAppArgs,
- tcTyConAppArgs, isUnLiftedType, Type, mkAppTy, tcEqType )
+ tcTyConAppArgs, isUnLiftedType, Type, mkAppTy )
import Type ( funArgTy, splitFunTys, isUnboxedTupleType, mkFunTy )
import CoreSyn
import CoreUtils ( exprType, mkIfThenElse, bindNonRec )
import CostCentre ( mkUserCC )
-import Id ( Id, idType, idName )
+import Id ( Id, idType, idName, isDataConWorkId_maybe )
import PrelInfo ( rEC_CON_ERROR_ID, iRREFUT_PAT_ERROR_ID )
import DataCon ( DataCon, dataConWrapId, dataConFieldLabels, dataConInstOrigArgTys )
import DataCon ( isVanillaDataCon )
mfixName )
import SrcLoc ( Located(..), unLoc, getLoc, noLoc )
import Util ( zipEqual, zipWithEqual )
+import Maybe ( fromJust )
import Bag ( bagToList )
import Outputable
import FastString
dsExpr (HsPar e) = dsLExpr e
dsExpr (ExprWithTySigOut e _) = dsLExpr e
-dsExpr (HsVar var) = returnDs (Var var)
-dsExpr (HsIPVar ip) = returnDs (Var (ipNameName ip))
-dsExpr (HsLit lit) = dsLit lit
--- HsOverLit has been gotten rid of by the type checker
+dsExpr (HsVar var) = returnDs (Var var)
+dsExpr (HsIPVar ip) = returnDs (Var (ipNameName ip))
+dsExpr (HsLit lit) = dsLit lit
+dsExpr (HsOverLit lit) = dsOverLit lit
+
+dsExpr (NegApp expr neg_expr)
+ = do { core_expr <- dsLExpr expr
+ ; core_neg <- dsExpr neg_expr
+ ; return (core_neg `App` core_expr) }
dsExpr expr@(HsLam a_Match)
= matchWrapper LambdaExpr a_Match `thenDs` \ (binders, matching_code) ->
-- We need the `ListComp' form to use `deListComp' (rather than the "do" form)
-- because the interpretation of `stmts' depends on what sort of thing it is.
--
-dsExpr (HsDo ListComp stmts _ result_ty)
+dsExpr (HsDo ListComp stmts body result_ty)
= -- Special case for list comprehensions
- dsListComp stmts elt_ty
+ dsListComp stmts body elt_ty
where
[elt_ty] = tcTyConAppArgs result_ty
-dsExpr (HsDo do_or_lc stmts ids result_ty)
- | isDoExpr do_or_lc
- = dsDo do_or_lc stmts ids result_ty
+dsExpr (HsDo DoExpr stmts body result_ty)
+ = dsDo stmts body result_ty
+
+dsExpr (HsDo (MDoExpr tbl) stmts body result_ty)
+ = dsMDo tbl stmts body result_ty
-dsExpr (HsDo PArrComp stmts _ result_ty)
+dsExpr (HsDo PArrComp stmts body result_ty)
= -- Special case for array comprehensions
- dsPArrComp (map unLoc stmts) elt_ty
+ dsPArrComp (map unLoc stmts) body elt_ty
where
[elt_ty] = tcTyConAppArgs result_ty
returnDs (mkConApp (tupleCon boxity (length expr_list))
(map (Type . exprType) core_exprs ++ core_exprs))
-dsExpr (ArithSeqOut expr (From from))
- = dsLExpr expr `thenDs` \ expr2 ->
- dsLExpr from `thenDs` \ from2 ->
+dsExpr (ArithSeq expr (From from))
+ = dsExpr expr `thenDs` \ expr2 ->
+ dsLExpr from `thenDs` \ from2 ->
returnDs (App expr2 from2)
-dsExpr (ArithSeqOut expr (FromTo from two))
- = dsLExpr expr `thenDs` \ expr2 ->
- dsLExpr from `thenDs` \ from2 ->
+dsExpr (ArithSeq expr (FromTo from two))
+ = dsExpr expr `thenDs` \ expr2 ->
+ dsLExpr from `thenDs` \ from2 ->
dsLExpr two `thenDs` \ two2 ->
returnDs (mkApps expr2 [from2, two2])
-dsExpr (ArithSeqOut expr (FromThen from thn))
- = dsLExpr expr `thenDs` \ expr2 ->
- dsLExpr from `thenDs` \ from2 ->
+dsExpr (ArithSeq expr (FromThen from thn))
+ = dsExpr expr `thenDs` \ expr2 ->
+ dsLExpr from `thenDs` \ from2 ->
dsLExpr thn `thenDs` \ thn2 ->
returnDs (mkApps expr2 [from2, thn2])
-dsExpr (ArithSeqOut expr (FromThenTo from thn two))
- = dsLExpr expr `thenDs` \ expr2 ->
- dsLExpr from `thenDs` \ from2 ->
+dsExpr (ArithSeq expr (FromThenTo from thn two))
+ = dsExpr expr `thenDs` \ expr2 ->
+ dsLExpr from `thenDs` \ from2 ->
dsLExpr thn `thenDs` \ thn2 ->
dsLExpr two `thenDs` \ two2 ->
returnDs (mkApps expr2 [from2, thn2, two2])
-dsExpr (PArrSeqOut expr (FromTo from two))
- = dsLExpr expr `thenDs` \ expr2 ->
- dsLExpr from `thenDs` \ from2 ->
+dsExpr (PArrSeq expr (FromTo from two))
+ = dsExpr expr `thenDs` \ expr2 ->
+ dsLExpr from `thenDs` \ from2 ->
dsLExpr two `thenDs` \ two2 ->
returnDs (mkApps expr2 [from2, two2])
-dsExpr (PArrSeqOut expr (FromThenTo from thn two))
- = dsLExpr expr `thenDs` \ expr2 ->
- dsLExpr from `thenDs` \ from2 ->
+dsExpr (PArrSeq expr (FromThenTo from thn two))
+ = dsExpr expr `thenDs` \ expr2 ->
+ dsLExpr from `thenDs` \ from2 ->
dsLExpr thn `thenDs` \ thn2 ->
dsLExpr two `thenDs` \ two2 ->
returnDs (mkApps expr2 [from2, thn2, two2])
-dsExpr (PArrSeqOut expr _)
+dsExpr (PArrSeq expr _)
= panic "DsExpr.dsExpr: Infinite parallel array!"
-- the parser shouldn't have generated it and the renamer and typechecker
-- shouldn't have let it through
constructor @C@, setting all of @C@'s fields to bottom.
\begin{code}
-dsExpr (RecordConOut data_con con_expr rbinds)
- = dsLExpr con_expr `thenDs` \ con_expr' ->
+dsExpr (RecordCon (L _ data_con_id) con_expr rbinds)
+ = dsExpr con_expr `thenDs` \ con_expr' ->
let
(arg_tys, _) = tcSplitFunTys (exprType con_expr')
-- A newtype in the corner should be opaque;
[] -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (showSDoc (ppr lbl))
unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty ""
- labels = dataConFieldLabels data_con
+ labels = dataConFieldLabels (fromJust (isDataConWorkId_maybe data_con_id))
+ -- The data_con_id is guaranteed to be the work id of the constructor
in
(if null labels
dictionaries.
\begin{code}
-dsExpr (RecordUpdOut record_expr record_in_ty record_out_ty [])
+dsExpr (RecordUpd record_expr [] record_in_ty record_out_ty)
= dsLExpr record_expr
-dsExpr expr@(RecordUpdOut record_expr record_in_ty record_out_ty rbinds)
+dsExpr expr@(RecordUpd record_expr rbinds record_in_ty record_out_ty)
= dsLExpr record_expr `thenDs` \ record_expr' ->
-- Desugar the rbinds, and generate let-bindings if
#ifdef DEBUG
-- HsSyn constructs that just shouldn't be here:
dsExpr (ExprWithTySig _ _) = panic "dsExpr:ExprWithTySig"
-dsExpr (ArithSeqIn _) = panic "dsExpr:ArithSeqIn"
-dsExpr (PArrSeqIn _) = panic "dsExpr:PArrSeqIn"
#endif
\end{code}
Haskell 98 report:
\begin{code}
-dsDo :: HsStmtContext Name
- -> [LStmt Id]
- -> ReboundNames Id -- id for: [return,fail,>>=,>>] and possibly mfixName
- -> Type -- Element type; the whole expression has type (m t)
+dsDo :: [LStmt Id]
+ -> LHsExpr Id
+ -> Type -- Type of the whole expression
-> DsM CoreExpr
-dsDo do_or_lc stmts ids result_ty
- = dsReboundNames ids `thenDs` \ (meth_binds, ds_meths) ->
- let
- fail_id = lookupReboundName ds_meths failMName
- bind_id = lookupReboundName ds_meths bindMName
- then_id = lookupReboundName ds_meths thenMName
-
- (m_ty, b_ty) = tcSplitAppTy result_ty -- result_ty must be of the form (m b)
-
- -- For ExprStmt, see the comments near HsExpr.Stmt about
- -- exactly what ExprStmts mean!
- --
- -- In dsDo we can only see DoStmt and ListComp (no guards)
-
- go [ResultStmt expr] = dsLExpr expr
-
-
- go (ExprStmt expr a_ty : stmts)
- = dsLExpr expr `thenDs` \ expr2 ->
- go stmts `thenDs` \ rest ->
- returnDs (mkApps then_id [Type a_ty, Type b_ty, expr2, rest])
-
- go (LetStmt binds : stmts)
- = go stmts `thenDs` \ rest ->
- dsLet binds rest
-
- go (BindStmt pat expr : stmts)
- = go stmts `thenDs` \ body ->
- dsLExpr expr `thenDs` \ rhs ->
- mkStringExpr (mk_msg (getLoc pat)) `thenDs` \ core_msg ->
- let
- -- In a do expression, pattern-match failure just calls
- -- the monadic 'fail' rather than throwing an exception
- fail_expr = mkApps fail_id [Type b_ty, core_msg]
- a_ty = hsPatType pat
- in
- selectSimpleMatchVarL pat `thenDs` \ var ->
- matchSimply (Var var) (StmtCtxt do_or_lc) pat
- body fail_expr `thenDs` \ match_code ->
- returnDs (mkApps bind_id [Type a_ty, Type b_ty, rhs, Lam var match_code])
-
- go (RecStmt rec_stmts later_vars rec_vars rec_rets : stmts)
- = go (bind_stmt : stmts)
- where
- bind_stmt = dsRecStmt m_ty ds_meths rec_stmts later_vars rec_vars rec_rets
-
- in
- go (map unLoc stmts) `thenDs` \ stmts_code ->
- returnDs (foldr Let stmts_code meth_binds)
-
+dsDo stmts body result_ty
+ = go (map unLoc stmts)
where
- mk_msg locn = "Pattern match failure in do expression at " ++ showSDoc (ppr locn)
+ go [] = dsLExpr body
+
+ go (ExprStmt rhs then_expr _ : stmts)
+ = do { rhs2 <- dsLExpr rhs
+ ; then_expr2 <- dsExpr then_expr
+ ; rest <- go stmts
+ ; returnDs (mkApps then_expr2 [rhs2, rest]) }
+
+ go (LetStmt binds : stmts)
+ = do { rest <- go stmts
+ ; dsLet binds rest }
+
+ go (BindStmt pat rhs bind_op fail_op : stmts)
+ = do { body <- go stmts
+ ; var <- selectSimpleMatchVarL pat
+ ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat
+ result_ty (cantFailMatchResult body)
+ ; match_code <- handle_failure pat match fail_op
+ ; rhs' <- dsLExpr rhs
+ ; bind_op' <- dsExpr bind_op
+ ; returnDs (mkApps bind_op' [rhs', Lam var match_code]) }
+
+ -- In a do expression, pattern-match failure just calls
+ -- the monadic 'fail' rather than throwing an exception
+ handle_failure pat match fail_op
+ | matchCanFail match
+ = do { fail_op' <- dsExpr fail_op
+ ; fail_msg <- mkStringExpr (mk_fail_msg pat)
+ ; extractMatchResult match (App fail_op' fail_msg) }
+ | otherwise
+ = extractMatchResult match (error "It can't fail")
+
+mk_fail_msg pat = "Pattern match failure in do expression at " ++
+ showSDoc (ppr (getLoc pat))
\end{code}
Translation for RecStmt's:
return (v1,..vn))
\begin{code}
-dsRecStmt :: Type -- Monad type constructor :: * -> *
- -> [(Name,Id)] -- Rebound Ids
- -> [LStmt Id]
- -> [Id] -> [Id] -> [LHsExpr Id]
- -> Stmt Id
-dsRecStmt m_ty ds_meths stmts later_vars rec_vars rec_rets
- = ASSERT( length rec_vars > 0 )
- ASSERT( length rec_vars == length rec_rets )
- BindStmt (mk_tup_pat later_pats) mfix_app
- where
- -- Remove any vars from later_vars that already in rec_vars
- -- NB that having the same name is not enough; they must have
- -- the same type. See Note [RecStmt] in HsExpr.
- trimmed_laters = filter not_in_rec later_vars
- not_in_rec lv = null [ v | let lv_type = idType lv
- , v <- rec_vars
- , v == lv
- , lv_type `tcEqType` idType v ]
+dsMDo :: PostTcTable
+ -> [LStmt Id]
+ -> LHsExpr Id
+ -> Type -- Type of the whole expression
+ -> DsM CoreExpr
+
+dsMDo tbl stmts body result_ty
+ = go (map unLoc stmts)
+ where
+ (m_ty, b_ty) = tcSplitAppTy result_ty -- result_ty must be of the form (m b)
+ mfix_id = lookupEvidence tbl mfixName
+ return_id = lookupEvidence tbl returnMName
+ bind_id = lookupEvidence tbl bindMName
+ then_id = lookupEvidence tbl thenMName
+ fail_id = lookupEvidence tbl failMName
+ ctxt = MDoExpr tbl
+
+ go [] = dsLExpr body
+
+ go (LetStmt binds : stmts)
+ = do { rest <- go stmts
+ ; dsLet binds rest }
+
+ go (ExprStmt rhs _ rhs_ty : stmts)
+ = do { rhs2 <- dsLExpr rhs
+ ; rest <- go stmts
+ ; returnDs (mkApps (Var then_id) [Type rhs_ty, Type b_ty, rhs2, rest]) }
+
+ go (BindStmt pat rhs _ _ : stmts)
+ = do { body <- go stmts
+ ; var <- selectSimpleMatchVarL pat
+ ; match <- matchSinglePat (Var var) (StmtCtxt ctxt) pat
+ result_ty (cantFailMatchResult body)
+ ; fail_msg <- mkStringExpr (mk_fail_msg pat)
+ ; let fail_expr = mkApps (Var fail_id) [Type b_ty, fail_msg]
+ ; match_code <- extractMatchResult match fail_expr
+
+ ; rhs' <- dsLExpr rhs
+ ; returnDs (mkApps (Var bind_id) [Type (hsPatType pat), Type b_ty,
+ rhs', Lam var match_code]) }
+
+ go (RecStmt rec_stmts later_ids rec_ids rec_rets binds : stmts)
+ = ASSERT( length rec_ids > 0 )
+ ASSERT( length rec_ids == length rec_rets )
+ go (new_bind_stmt : let_stmt : stmts)
+ where
+ new_bind_stmt = mkBindStmt (mk_tup_pat later_pats) mfix_app
+ let_stmt = LetStmt [HsBindGroup binds [] Recursive]
+
+ -- Remove the later_ids that appear (without fancy coercions)
+ -- in rec_rets, because there's no need to knot-tie them separately
+ -- See Note [RecStmt] in HsExpr
+ later_ids' = filter (`notElem` mono_rec_ids) later_ids
+ mono_rec_ids = [ id | HsVar id <- rec_rets ]
+
mfix_app = nlHsApp (noLoc $ TyApp (nlHsVar mfix_id) [tup_ty]) mfix_arg
mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body]
(mkFunTy tup_ty body_ty))
- -- The rec_tup_pat must bind the rec_vars only; remember that the
+ -- The rec_tup_pat must bind the rec_ids only; remember that the
-- trimmed_laters may share the same Names
-- Meanwhile, the later_pats must bind the later_vars
- rec_tup_pats = map mk_wild_pat trimmed_laters ++ map nlVarPat rec_vars
- later_pats = map nlVarPat trimmed_laters ++ map mk_later_pat rec_vars
- rets = map nlHsVar trimmed_laters ++ rec_rets
+ rec_tup_pats = map mk_wild_pat later_ids' ++ map nlVarPat rec_ids
+ later_pats = map nlVarPat later_ids' ++ map mk_later_pat rec_ids
+ rets = map nlHsVar later_ids' ++ map noLoc rec_rets
mfix_pat = noLoc $ LazyPat $ mk_tup_pat rec_tup_pats
- body = noLoc $ HsDo DoExpr (stmts ++ [return_stmt])
- [(n, HsVar id) | (n,id) <- ds_meths] -- A bit of a hack
- body_ty
+ body = noLoc $ HsDo ctxt rec_stmts return_app body_ty
body_ty = mkAppTy m_ty tup_ty
- tup_ty = mkCoreTupTy (map idType (trimmed_laters ++ rec_vars))
+ tup_ty = mkCoreTupTy (map idType (later_ids' ++ rec_ids))
-- mkCoreTupTy deals with singleton case
- Var return_id = lookupReboundName ds_meths returnMName
- Var mfix_id = lookupReboundName ds_meths mfixName
-
- return_stmt = noLoc $ ResultStmt return_app
return_app = nlHsApp (noLoc $ TyApp (nlHsVar return_id) [tup_ty])
(mk_ret_tup rets)
mk_wild_pat v = noLoc $ WildPat $ idType v
mk_later_pat :: Id -> LPat Id
- mk_later_pat v | v `elem` trimmed_laters = mk_wild_pat v
- | otherwise = nlVarPat v
+ mk_later_pat v | v `elem` later_ids' = mk_wild_pat v
+ | otherwise = nlVarPat v
mk_tup_pat :: [LPat Id] -> LPat Id
mk_tup_pat [p] = p
import {-# SOURCE #-} Match ( matchSinglePat )
import HsSyn ( Stmt(..), HsExpr(..), GRHSs(..), GRHS(..),
- HsMatchContext(..), Pat(..) )
+ LHsExpr, HsMatchContext(..), Pat(..) )
import CoreSyn ( CoreExpr )
import Var ( Id )
import Type ( Type )
in
returnDs match_result2
-dsGRHS kind pats rhs_ty (L loc (GRHS guard))
- = matchGuard (map unLoc guard) (DsMatchContext kind pats loc) rhs_ty
+dsGRHS kind pats rhs_ty (L loc (GRHS guards rhs))
+ = matchGuard (map unLoc guards) (DsMatchContext kind pats loc)
+ rhs rhs_ty
\end{code}
\begin{code}
matchGuard :: [Stmt Id] -- Guard
-> DsMatchContext -- Context
+ -> LHsExpr Id -- RHS
-> Type -- Type of RHS of guard
-> DsM MatchResult
-- See comments with HsExpr.Stmt re what an ExprStmt means
-- Here we must be in a guard context (not do-expression, nor list-comp)
-matchGuard [ResultStmt expr] ctx rhs_ty
- = do { core_expr <- dsLExpr expr
- ; return (cantFailMatchResult core_expr) }
+matchGuard [] ctx rhs rhs_ty
+ = do { core_rhs <- dsLExpr rhs
+ ; return (cantFailMatchResult core_rhs) }
-- ExprStmts must be guards
-- Turn an "otherwise" guard is a no-op
-matchGuard (ExprStmt (L _ (HsVar v)) _ : stmts) ctx rhs_ty
+matchGuard (ExprStmt (L _ (HsVar v)) _ _ : stmts) ctx rhs rhs_ty
| v `hasKey` otherwiseIdKey
|| v `hasKey` getUnique trueDataConId
-- trueDataConId doesn't have the same
-- unique as trueDataCon
- = matchGuard stmts ctx rhs_ty
+ = matchGuard stmts ctx rhs rhs_ty
-matchGuard (ExprStmt expr _ : stmts) ctx rhs_ty
- = matchGuard stmts ctx rhs_ty `thenDs` \ match_result ->
- dsLExpr expr `thenDs` \ pred_expr ->
+matchGuard (ExprStmt expr _ _ : stmts) ctx rhs rhs_ty
+ = matchGuard stmts ctx rhs rhs_ty `thenDs` \ match_result ->
+ dsLExpr expr `thenDs` \ pred_expr ->
returnDs (mkGuardedMatchResult pred_expr match_result)
-matchGuard (LetStmt binds : stmts) ctx rhs_ty
- = matchGuard stmts ctx rhs_ty `thenDs` \ match_result ->
+matchGuard (LetStmt binds : stmts) ctx rhs rhs_ty
+ = matchGuard stmts ctx rhs rhs_ty `thenDs` \ match_result ->
returnDs (adjustMatchResultDs (dsLet binds) match_result)
-- NB the dsLet occurs inside the match_result
-- Reason: dsLet takes the body expression as its argument
-- so we can't desugar the bindings without the
-- body expression in hand
-matchGuard (BindStmt pat bind_rhs : stmts) ctx rhs_ty
- = matchGuard stmts ctx rhs_ty `thenDs` \ match_result ->
- dsLExpr bind_rhs `thenDs` \ core_rhs ->
+matchGuard (BindStmt pat bind_rhs _ _ : stmts) ctx rhs rhs_ty
+ = matchGuard stmts ctx rhs rhs_ty `thenDs` \ match_result ->
+ dsLExpr bind_rhs `thenDs` \ core_rhs ->
matchSinglePat core_rhs ctx pat rhs_ty match_result
\end{code}
\begin{code}
dsListComp :: [LStmt Id]
+ -> LHsExpr Id
-> Type -- Type of list elements
-> DsM CoreExpr
-dsListComp lquals elt_ty
+dsListComp lquals body elt_ty
= getDOptsDs `thenDs` \dflags ->
let
quals = map unLoc lquals
|| isParallelComp quals
-- Foldr-style desugaring can't handle
-- parallel list comprehensions
- then deListComp quals (mkNilExpr elt_ty)
+ then deListComp quals body (mkNilExpr elt_ty)
else -- Foldr/build should be enabled, so desugar
-- into foldrs and builds
c_ty = mkFunTys [elt_ty, n_ty] n_ty
in
newSysLocalsDs [c_ty,n_ty] `thenDs` \ [c, n] ->
- dfListComp c n quals `thenDs` \ result ->
+ dfListComp c n quals body `thenDs` \ result ->
dsLookupGlobalId buildName `thenDs` \ build_id ->
returnDs (Var build_id `App` Type elt_ty
`App` mkLams [n_tyvar, c, n] result)
with the Unboxed variety.
\begin{code}
-deListComp :: [Stmt Id] -> CoreExpr -> DsM CoreExpr
+deListComp :: [Stmt Id] -> LHsExpr Id -> CoreExpr -> DsM CoreExpr
-deListComp (ParStmt stmtss_w_bndrs : quals) list
+deListComp (ParStmt stmtss_w_bndrs : quals) body list
= mappM do_list_comp stmtss_w_bndrs `thenDs` \ exps ->
mkZipBind qual_tys `thenDs` \ (zip_fn, zip_rhs) ->
-- Deal with [e | pat <- zip l1 .. ln] in example above
deBindComp pat (Let (Rec [(zip_fn, zip_rhs)]) (mkApps (Var zip_fn) exps))
- quals list
+ quals body list
where
bndrs_s = map snd stmtss_w_bndrs
qual_tys = map mk_bndrs_tys bndrs_s
do_list_comp (stmts, bndrs)
- = dsListComp (stmts ++ [noLoc $ ResultStmt (mk_hs_tuple_expr bndrs)])
+ = dsListComp stmts (mk_hs_tuple_expr bndrs)
(mk_bndrs_tys bndrs)
mk_bndrs_tys bndrs = mkCoreTupTy (map idType bndrs)
-- Last: the one to return
-deListComp [ResultStmt expr] list -- Figure 7.4, SLPJ, p 135, rule C above
- = dsLExpr expr `thenDs` \ core_expr ->
- returnDs (mkConsExpr (exprType core_expr) core_expr list)
+deListComp [] body list -- Figure 7.4, SLPJ, p 135, rule C above
+ = dsLExpr body `thenDs` \ core_body ->
+ returnDs (mkConsExpr (exprType core_body) core_body list)
-- Non-last: must be a guard
-deListComp (ExprStmt guard ty : quals) list -- rule B above
+deListComp (ExprStmt guard _ _ : quals) body list -- rule B above
= dsLExpr guard `thenDs` \ core_guard ->
- deListComp quals list `thenDs` \ core_rest ->
+ deListComp quals body list `thenDs` \ core_rest ->
returnDs (mkIfThenElse core_guard core_rest list)
-- [e | let B, qs] = let B in [e | qs]
-deListComp (LetStmt binds : quals) list
- = deListComp quals list `thenDs` \ core_rest ->
+deListComp (LetStmt binds : quals) body list
+ = deListComp quals body list `thenDs` \ core_rest ->
dsLet binds core_rest
-deListComp (BindStmt pat list1 : quals) core_list2 -- rule A' above
+deListComp (BindStmt pat list1 _ _ : quals) body core_list2 -- rule A' above
= dsLExpr list1 `thenDs` \ core_list1 ->
- deBindComp pat core_list1 quals core_list2
+ deBindComp pat core_list1 quals body core_list2
\end{code}
\begin{code}
-deBindComp pat core_list1 quals core_list2
+deBindComp pat core_list1 quals body core_list2
= let
u3_ty@u1_ty = exprType core_list1 -- two names, same thing
core_fail = App (Var h) (Var u3)
letrec_body = App (Var h) core_list1
in
- deListComp quals core_fail `thenDs` \ rest_expr ->
+ deListComp quals body core_fail `thenDs` \ rest_expr ->
matchSimply (Var u2) (StmtCtxt ListComp) pat
rest_expr core_fail `thenDs` \ core_match ->
let
\begin{code}
dfListComp :: Id -> Id -- 'c' and 'n'
-> [Stmt Id] -- the rest of the qual's
+ -> LHsExpr Id
-> DsM CoreExpr
-- Last: the one to return
-dfListComp c_id n_id [ResultStmt expr]
- = dsLExpr expr `thenDs` \ core_expr ->
- returnDs (mkApps (Var c_id) [core_expr, Var n_id])
+dfListComp c_id n_id [] body
+ = dsLExpr body `thenDs` \ core_body ->
+ returnDs (mkApps (Var c_id) [core_body, Var n_id])
-- Non-last: must be a guard
-dfListComp c_id n_id (ExprStmt guard ty : quals)
- = dsLExpr guard `thenDs` \ core_guard ->
- dfListComp c_id n_id quals `thenDs` \ core_rest ->
+dfListComp c_id n_id (ExprStmt guard _ _ : quals) body
+ = dsLExpr guard `thenDs` \ core_guard ->
+ dfListComp c_id n_id quals body `thenDs` \ core_rest ->
returnDs (mkIfThenElse core_guard core_rest (Var n_id))
-dfListComp c_id n_id (LetStmt binds : quals)
+dfListComp c_id n_id (LetStmt binds : quals) body
-- new in 1.3, local bindings
- = dfListComp c_id n_id quals `thenDs` \ core_rest ->
+ = dfListComp c_id n_id quals body `thenDs` \ core_rest ->
dsLet binds core_rest
-dfListComp c_id n_id (BindStmt pat list1 : quals)
+dfListComp c_id n_id (BindStmt pat list1 _ _ : quals) body
-- evaluate the two lists
= dsLExpr list1 `thenDs` \ core_list1 ->
newSysLocalsDs [b_ty,x_ty] `thenDs` \ [b,x] ->
-- build rest of the comprehesion
- dfListComp c_id b quals `thenDs` \ core_rest ->
+ dfListComp c_id b quals body `thenDs` \ core_rest ->
-- build the pattern match
matchSimply (Var x) (StmtCtxt ListComp)
-- [:e | qss:] = <<[:e | qss:]>> () [:():]
--
dsPArrComp :: [Stmt Id]
+ -> LHsExpr Id
-> Type -- Don't use; called with `undefined' below
-> DsM CoreExpr
-dsPArrComp qs _ =
+dsPArrComp qs body _ =
dsLookupGlobalId replicatePName `thenDs` \repP ->
let unitArray = mkApps (Var repP) [Type unitTy,
mkIntExpr 1,
mkCoreTup []]
in
- dePArrComp qs (mkTuplePat []) unitArray
+ dePArrComp qs body (mkTuplePat []) unitArray
-- the work horse
--
dePArrComp :: [Stmt Id]
+ -> LHsExpr Id
-> LPat Id -- the current generator pattern
-> CoreExpr -- the current generator expression
-> DsM CoreExpr
--
-- <<[:e' | :]>> pa ea = mapP (\pa -> e') ea
--
-dePArrComp [ResultStmt e'] pa cea =
+dePArrComp [] e' pa cea =
dsLookupGlobalId mapPName `thenDs` \mapP ->
let ty = parrElemType cea
in
--
-- <<[:e' | b, qs:]>> pa ea = <<[:e' | qs:]>> pa (filterP (\pa -> b) ea)
--
-dePArrComp (ExprStmt b _ : qs) pa cea =
+dePArrComp (ExprStmt b _ _ : qs) body pa cea =
dsLookupGlobalId filterPName `thenDs` \filterP ->
let ty = parrElemType cea
in
deLambda ty pa b `thenDs` \(clam,_) ->
- dePArrComp qs pa (mkApps (Var filterP) [Type ty, clam, cea])
+ dePArrComp qs body pa (mkApps (Var filterP) [Type ty, clam, cea])
--
-- <<[:e' | p <- e, qs:]>> pa ea =
-- let ef = filterP (\x -> case x of {p -> True; _ -> False}) e
-- in
-- <<[:e' | qs:]>> (pa, p) (crossP ea ef)
--
-dePArrComp (BindStmt p e : qs) pa cea =
+dePArrComp (BindStmt p e _ _ : qs) body pa cea =
dsLookupGlobalId filterPName `thenDs` \filterP ->
dsLookupGlobalId crossPName `thenDs` \crossP ->
dsLExpr e `thenDs` \ce ->
ty'cef = ty'ce -- filterP preserves the type
pa' = mkTuplePat [pa, p]
in
- dePArrComp qs pa' (mkApps (Var crossP) [Type ty'cea, Type ty'cef, cea, cef])
+ dePArrComp qs body pa' (mkApps (Var crossP) [Type ty'cea, Type ty'cef, cea, cef])
--
-- <<[:e' | let ds, qs:]>> pa ea =
-- <<[:e' | qs:]>> (pa, (x_1, ..., x_n))
-- where
-- {x_1, ..., x_n} = DV (ds) -- Defined Variables
--
-dePArrComp (LetStmt ds : qs) pa cea =
+dePArrComp (LetStmt ds : qs) body pa cea =
dsLookupGlobalId mapPName `thenDs` \mapP ->
let xs = map unLoc (collectGroupBinders ds)
ty'cea = parrElemType cea
let pa' = mkTuplePat [pa, mkTuplePat (map nlVarPat xs)]
proj = mkLams [v] ccase
in
- dePArrComp qs pa' (mkApps (Var mapP) [Type ty'cea, proj, cea])
+ dePArrComp qs body pa' (mkApps (Var mapP) [Type ty'cea, proj, cea])
--
-- <<[:e' | qs | qss:]>> pa ea =
-- <<[:e' | qss:]>> (pa, (x_1, ..., x_n))
-- where
-- {x_1, ..., x_n} = DV (qs)
--
-dePArrComp (ParStmt qss : qs) pa cea =
+dePArrComp (ParStmt qss : qs) body pa cea =
dsLookupGlobalId crossPName `thenDs` \crossP ->
deParStmt qss `thenDs` \(pQss,
ceQss) ->
ty'ceQss = parrElemType ceQss
pa' = mkTuplePat [pa, pQss]
in
- dePArrComp qs pa' (mkApps (Var crossP) [Type ty'cea, Type ty'ceQss,
- cea, ceQss])
+ dePArrComp qs body pa' (mkApps (Var crossP) [Type ty'cea, Type ty'ceQss,
+ cea, ceQss])
where
deParStmt [] =
-- empty parallel statement lists have not source representation
panic "DsListComp.dePArrComp: Empty parallel list comprehension"
deParStmt ((qs, xs):qss) = -- first statement
- let resStmt = ResultStmt $ mkExplicitTuple (map nlHsVar xs)
+ let res_expr = mkExplicitTuple (map nlHsVar xs)
in
- dsPArrComp (map unLoc qs ++ [resStmt]) undefined `thenDs` \cqs ->
+ dsPArrComp (map unLoc qs) res_expr undefined `thenDs` \cqs ->
parStmts qss (mkTuplePat (map nlVarPat xs)) cqs
---
parStmts [] pa cea = return (pa, cea)
parStmts ((qs, xs):qss) pa cea = -- subsequent statements (zip'ed)
dsLookupGlobalId zipPName `thenDs` \zipP ->
- let pa' = mkTuplePat [pa, mkTuplePat (map nlVarPat xs)]
- ty'cea = parrElemType cea
- resStmt = ResultStmt $ mkExplicitTuple (map nlHsVar xs)
+ let pa' = mkTuplePat [pa, mkTuplePat (map nlVarPat xs)]
+ ty'cea = parrElemType cea
+ res_expr = mkExplicitTuple (map nlHsVar xs)
in
- dsPArrComp (map unLoc qs ++ [resStmt]) undefined `thenDs` \cqs ->
+ dsPArrComp (map unLoc qs) res_expr undefined `thenDs` \cqs ->
let ty'cqs = parrElemType cqs
cea' = mkApps (Var zipP) [Type ty'cea, Type ty'cqs, cea, cqs]
in
; z <- repLetE ds e2
; wrapGenSyns ss z }
-- FIXME: I haven't got the types here right yet
-repE (HsDo DoExpr sts _ ty)
+repE (HsDo DoExpr sts body ty)
= do { (ss,zs) <- repLSts sts;
- e <- repDoE (nonEmptyCoreList zs);
+ body' <- repLE body;
+ ret <- repNoBindSt body';
+ e <- repDoE (nonEmptyCoreList (zs ++ [ret]));
wrapGenSyns ss e }
-repE (HsDo ListComp sts _ ty)
+repE (HsDo ListComp sts body ty)
= do { (ss,zs) <- repLSts sts;
- e <- repComp (nonEmptyCoreList zs);
+ body' <- repLE body;
+ ret <- repNoBindSt body';
+ e <- repComp (nonEmptyCoreList (zs ++ [ret]));
wrapGenSyns ss e }
repE (HsDo _ _ _ _) = panic "DsMeta.repE: Can't represent mdo and [: :] yet"
repE (ExplicitList ty es) = do { xs <- repLEs es; repListExp xs }
repE (ExplicitTuple es boxed)
| isBoxed boxed = do { xs <- repLEs es; repTup xs }
| otherwise = panic "DsMeta.repE: Can't represent unboxed tuples"
-repE (RecordCon c flds)
+repE (RecordCon c _ flds)
= do { x <- lookupLOcc c;
fs <- repFields flds;
repRecCon x fs }
-repE (RecordUpd e flds)
+repE (RecordUpd e flds _ _)
= do { x <- repLE e;
fs <- repFields flds;
repRecUpd x fs }
; wrapGenSyns (ss1++ss2) clause }}}
repGuards :: [LGRHS Name] -> DsM (Core TH.BodyQ)
-repGuards [L _ (GRHS [L _ (ResultStmt e)])]
+repGuards [L _ (GRHS [] e)]
= do {a <- repLE e; repNormal a }
repGuards other
= do { zs <- mapM process other;
wrapGenSyns (concat xs) gd }
where
process :: LGRHS Name -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp))))
- process (L _ (GRHS [])) = panic "No guards in guarded body"
- process (L _ (GRHS [L _ (ExprStmt e1 ty),
- L _ (ResultStmt e2)]))
+ process (L _ (GRHS [L _ (ExprStmt e1 _ _)] e2))
= do { x <- repLNormalGE e1 e2;
return ([], x) }
- process (L _ (GRHS ss))
+ process (L _ (GRHS ss rhs))
= do (gs, ss') <- repLSts ss
- g <- repPatGE (nonEmptyCoreList ss')
+ rhs' <- repLE rhs
+ g <- repPatGE (nonEmptyCoreList ss') rhs'
return (gs, g)
repFields :: [(Located Name, LHsExpr Name)] -> DsM (Core [TH.Q TH.FieldExp])
repLSts stmts = repSts (map unLoc stmts)
repSts :: [Stmt Name] -> DsM ([GenSymBind], [Core TH.StmtQ])
-repSts [ResultStmt e] =
- do { a <- repLE e
- ; e1 <- repNoBindSt a
- ; return ([], [e1]) }
-repSts (BindStmt p e : ss) =
+repSts (BindStmt p e _ _ : ss) =
do { e2 <- repLE e
; ss1 <- mkGenSyms (collectPatBinders p)
; addBinds ss1 $ do {
; z <- repLetSt ds
; (ss2,zs) <- addBinds ss1 (repSts ss)
; return (ss1++ss2, z : zs) }
-repSts (ExprStmt e ty : ss) =
+repSts (ExprStmt e _ _ : ss) =
do { e2 <- repLE e
; z <- repNoBindSt e2
; (ss2,zs) <- repSts ss
-- (\ p1 .. pn -> exp) by causing an error.
repLambda :: LMatch Name -> DsM (Core TH.ExpQ)
-repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [L _ (ResultStmt e)])] [])))
+repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [])] [])))
= do { let bndrs = collectPatsBinders ps ;
; ss <- mkGenSyms bndrs
; lam <- addBinds ss (
p2' <- repLP p2;
repPinfix p1' con_str p2' }
}
-repP (NPatIn l (Just _)) = panic "Can't cope with negative overloaded patterns yet (repP (NPatIn _ (Just _)))"
-repP (NPatIn l Nothing) = do { a <- repOverloadedLiteral l; repPlit a }
+repP (NPat l (Just _) _ _) = panic "Can't cope with negative overloaded patterns yet (repP (NPat _ (Just _)))"
+repP (NPat l Nothing _ _) = do { a <- repOverloadedLiteral l; repPlit a }
repP (SigPatIn p t) = do { p' <- repLP p; t' <- repLTy t; repPsig p' t' }
repP other = panic "Exotic pattern inside meta brackets"
repNormalGE :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
repNormalGE (MkC g) (MkC e) = rep2 normalGEName [g, e]
-repPatGE :: Core [TH.StmtQ] -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
-repPatGE (MkC ss) = rep2 patGEName [ss]
+repPatGE :: Core [TH.StmtQ] -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
+repPatGE (MkC ss) = rep2 patGName [ss]
------------- Stmts -------------------
repBindSt :: Core TH.PatQ -> Core TH.ExpQ -> DsM (Core TH.StmtQ)
mk_rational r = do rat_ty <- lookupType rationalTyConName
return $ HsRat r rat_ty
-repOverloadedLiteral :: HsOverLit -> DsM (Core TH.Lit)
+repOverloadedLiteral :: HsOverLit Name -> DsM (Core TH.Lit)
repOverloadedLiteral (HsIntegral i _) = do { lit <- mk_integer i; repLiteral lit }
repOverloadedLiteral (HsFractional f _) = do { lit <- mk_rational f; repLiteral lit }
-- The type Rational will be in the environment, becuase
cantFailMatchResult, alwaysFailMatchResult,
extractMatchResult, combineMatchResults,
adjustMatchResult, adjustMatchResultDs,
- mkCoLetMatchResult,
- mkGuardedMatchResult,
+ mkCoLetMatchResult, mkGuardedMatchResult,
+ matchCanFail,
mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult,
wrapBind, wrapBinds,
mkTupleType, mkTupleCase, mkBigCoreTup,
mkCoreTup, mkCoreTupTy,
- dsReboundNames, lookupReboundName,
+ dsSyntaxTable, lookupEvidence,
selectSimpleMatchVarL, selectMatchVars
) where
%************************************************************************
\begin{code}
-dsReboundNames :: ReboundNames Id
+dsSyntaxTable :: SyntaxTable Id
-> DsM ([CoreBind], -- Auxiliary bindings
[(Name,Id)]) -- Maps the standard name to its value
-dsReboundNames rebound_ids
+dsSyntaxTable rebound_ids
= mapAndUnzipDs mk_bind rebound_ids `thenDs` \ (binds_s, prs) ->
return (concat binds_s, prs)
where
newSysLocalDs (exprType rhs) `thenDs` \ id ->
return ([NonRec id rhs], (std_name, id))
-lookupReboundName :: [(Name,Id)] -> Name -> CoreExpr
-lookupReboundName prs std_name
- = Var (assocDefault (mk_panic std_name) prs std_name)
+lookupEvidence :: [(Name, Id)] -> Name -> Id
+lookupEvidence prs std_name
+ = assocDefault (mk_panic std_name) prs std_name
where
- mk_panic std_name = pprPanic "dsReboundNames" (ptext SLIT("Not found:") <+> ppr std_name)
+ mk_panic std_name = pprPanic "dsSyntaxTable" (ptext SLIT("Not found:") <+> ppr std_name)
\end{code}
Functions on MatchResults
\begin{code}
+matchCanFail :: MatchResult -> Bool
+matchCanFail (MatchResult CanFail _) = True
+matchCanFail (MatchResult CantFail _) = False
+
alwaysFailMatchResult :: MatchResult
alwaysFailMatchResult = MatchResult CanFail (\fail -> returnDs fail)
let
full_msg = showSDoc (hcat [ppr src_loc, text "|", text msg])
core_msg = Lit (mkStringLit full_msg)
+ -- mkStringLit returns a result of type String#
in
returnDs (mkApps (Var err_id) [Type ty, core_msg])
\end{code}
match_block eqns
= case firstPat (head eqns) of
- WildPat {} -> matchVariables vars ty eqns
- ConPatOut {} -> matchConFamily vars ty eqns
- NPlusKPatOut {} -> matchNPlusKPats vars ty eqns
- NPatOut {} -> matchNPats vars ty eqns
- LitPat {} -> matchLiterals vars ty eqns
+ WildPat {} -> matchVariables vars ty eqns
+ ConPatOut {} -> matchConFamily vars ty eqns
+ NPlusKPat {} -> matchNPlusKPats vars ty eqns
+ NPat {} -> matchNPats vars ty eqns
+ LitPat {} -> matchLiterals vars ty eqns
-- After tidying, there are only five kinds of patterns
-samePatFamily (WildPat {}) (WildPat {}) = True
-samePatFamily (ConPatOut {}) (ConPatOut {}) = True
-samePatFamily (NPlusKPatOut {}) (NPlusKPatOut {}) = True
-samePatFamily (NPatOut {}) (NPatOut {}) = True
-samePatFamily (LitPat {}) (LitPat {}) = True
-samePatFamily _ _ = False
+samePatFamily (WildPat {}) (WildPat {}) = True
+samePatFamily (ConPatOut {}) (ConPatOut {}) = True
+samePatFamily (NPlusKPat {}) (NPlusKPat {}) = True
+samePatFamily (NPat {}) (NPat {}) = True
+samePatFamily (LitPat {}) (LitPat {}) = True
+samePatFamily _ _ = False
matchVariables :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
-- Real true variables, just like in matchVar, SLPJ p 94
= returnDs (wrap, unLoc (tidyLitPat lit (noLoc pat)))
-- NPats: we *might* be able to replace these w/ a simpler form
-tidy1 v wrap pat@(NPatOut lit lit_ty _)
- = returnDs (wrap, unLoc (tidyNPat lit lit_ty (noLoc pat)))
+tidy1 v wrap pat@(NPat lit mb_neg _ lit_ty)
+ = returnDs (wrap, unLoc (tidyNPat lit mb_neg lit_ty (noLoc pat)))
-- and everything else goes through unchanged...
-> CoreExpr -- Return this if it doesn't
-> DsM CoreExpr
-matchSimply scrut kind pat result_expr fail_expr
- = getSrcSpanDs `thenDs` \ locn ->
- let
- ctx = DsMatchContext kind [unLoc pat] locn
+matchSimply scrut hs_ctx pat result_expr fail_expr
+ = let
match_result = cantFailMatchResult result_expr
rhs_ty = exprType fail_expr
-- Use exprType of fail_expr, because won't refine in the case of failure!
in
- matchSinglePat scrut ctx pat rhs_ty match_result `thenDs` \ match_result' ->
+ matchSinglePat scrut hs_ctx pat rhs_ty match_result `thenDs` \ match_result' ->
extractMatchResult match_result' fail_expr
-matchSinglePat :: CoreExpr -> DsMatchContext -> LPat Id
+matchSinglePat :: CoreExpr -> HsMatchContext Name -> LPat Id
-> Type -> MatchResult -> DsM MatchResult
-matchSinglePat (Var var) ctx pat ty match_result
- = getDOptsDs `thenDs` \ dflags ->
+matchSinglePat (Var var) hs_ctx (L _ pat) ty match_result
+ = getDOptsDs `thenDs` \ dflags ->
+ getSrcSpanDs `thenDs` \ locn ->
+ let
+ match_fn dflags
+ | dopt Opt_WarnSimplePatterns dflags = matchCheck ds_ctx
+ | otherwise = match
+ where
+ ds_ctx = DsMatchContext hs_ctx [pat] locn
+ in
match_fn dflags [var] ty [EqnInfo { eqn_wrap = idWrapper,
- eqn_pats = [unLoc pat],
+ eqn_pats = [pat],
eqn_rhs = match_result }]
- where
- match_fn dflags
- | dopt Opt_WarnSimplePatterns dflags = matchCheck ctx
- | otherwise = match
-matchSinglePat scrut ctx pat ty match_result
+matchSinglePat scrut hs_ctx pat ty match_result
= selectSimpleMatchVarL pat `thenDs` \ var ->
- matchSinglePat (Var var) ctx pat ty match_result `thenDs` \ match_result' ->
+ matchSinglePat (Var var) hs_ctx pat ty match_result `thenDs` \ match_result' ->
returnDs (adjustMatchResult (bindNonRec var scrut) match_result')
\end{code}
import {-# SOURCE #-} Match ( match )
-import HsSyn ( Pat(..), HsConDetails(..), isEmptyLHsBinds )
+import HsSyn ( Pat(..), HsConDetails(..) )
import DsBinds ( dsHsNestedBinds )
import DataCon ( isVanillaDataCon, dataConTyVars, dataConOrigArgTys )
import TcType ( tcTyConAppArgs )
\section[MatchLit]{Pattern-matching literal patterns}
\begin{code}
-module MatchLit ( dsLit, tidyLitPat, tidyNPat,
+module MatchLit ( dsLit, dsOverLit,
+ tidyLitPat, tidyNPat,
matchLiterals, matchNPlusKPats, matchNPats ) where
#include "HsVersions.h"
import DsUtils
import HsSyn
-import Id ( Id )
+import Id ( Id, idType )
import CoreSyn
import TyCon ( tyConDataCons )
-import TcType ( tcSplitTyConApp, isIntegerTy, isIntTy, isFloatTy, isDoubleTy )
+import TcType ( tcSplitTyConApp, isIntegerTy, isIntTy,
+ isFloatTy, isDoubleTy, isStringTy )
import Type ( Type )
import PrelNames ( ratioTyConKey )
import TysWiredIn ( stringTy, consDataCon, intDataCon, floatDataCon, doubleDataCon )
+import PrelNames ( eqStringName )
import Unique ( hasKey )
import Literal ( mkMachInt, Literal(..) )
import SrcLoc ( noLoc )
= case tcSplitTyConApp ty of
(tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey)
(head (tyConDataCons tycon), i_ty)
+
+dsOverLit :: HsOverLit Id -> DsM CoreExpr
+-- Post-typechecker, the SyntaxExpr field of an OverLit contains
+-- (an expression for) the literal value itself
+dsOverLit (HsIntegral _ lit) = dsExpr lit
+dsOverLit (HsFractional _ lit) = dsExpr lit
\end{code}
%************************************************************************
tidyLitPat :: HsLit -> LPat Id -> LPat Id
-- Result has only the following HsLits:
-- HsIntPrim, HsCharPrim, HsFloatPrim
--- HsDoublePrim, HsStringPrim ?
--- * HsInteger, HsRat, HsInt can't show up in LitPats,
--- * HsString has been turned into an NPat in tcPat
--- and we get rid of HsChar right here
+-- HsDoublePrim, HsStringPrim, HsString
+-- * HsInteger, HsRat, HsInt can't show up in LitPats
+-- * We get rid of HsChar right here
tidyLitPat (HsChar c) pat = mkCharLitPat c
-tidyLitPat lit pat = pat
-
-tidyNPat :: HsLit -> Type -> LPat Id -> LPat Id
-tidyNPat (HsString s) _ pat
+tidyLitPat (HsString s) pat
| lengthFS s <= 1 -- Short string literals only
= foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c,pat] stringTy)
(mkNilPat stringTy) (unpackFS s)
-- The stringTy is the type of the whole pattern, not
-- the type to instantiate (:) or [] with!
+tidyLitPat lit pat = pat
-tidyNPat lit lit_ty default_pat
- | isIntTy lit_ty = mkPrefixConPat intDataCon [noLoc $ LitPat (mk_int lit)] lit_ty
- | isFloatTy lit_ty = mkPrefixConPat floatDataCon [noLoc $ LitPat (mk_float lit)] lit_ty
- | isDoubleTy lit_ty = mkPrefixConPat doubleDataCon [noLoc $ LitPat (mk_double lit)] lit_ty
- | otherwise = default_pat
-
+----------------
+tidyNPat :: HsOverLit Id -> Maybe (SyntaxExpr Id) -> Type -> LPat Id -> LPat Id
+tidyNPat over_lit mb_neg lit_ty default_pat
+ | isIntTy lit_ty = mk_con_pat intDataCon (HsIntPrim int_val)
+ | isFloatTy lit_ty = mk_con_pat floatDataCon (HsFloatPrim rat_val)
+ | isDoubleTy lit_ty = mk_con_pat doubleDataCon (HsDoublePrim rat_val)
+ | otherwise = default_pat
where
- mk_int (HsInteger i _) = HsIntPrim i
-
- mk_float (HsInteger i _) = HsFloatPrim (fromInteger i)
- mk_float (HsRat f _) = HsFloatPrim f
-
- mk_double (HsInteger i _) = HsDoublePrim (fromInteger i)
- mk_double (HsRat f _) = HsDoublePrim f
+ mk_con_pat con lit = mkPrefixConPat con [noLoc $ LitPat lit] lit_ty
+ neg_lit = case (mb_neg, over_lit) of
+ (Nothing, _) -> over_lit
+ (Just _, HsIntegral i s) -> HsIntegral (-i) s
+ (Just _, HsFractional f s) -> HsFractional (-f) s
+
+ int_val :: Integer
+ int_val = case neg_lit of
+ HsIntegral i _ -> i
+ HsFractional f _ -> panic "tidyNPat"
+
+ rat_val :: Rational
+ rat_val = case neg_lit of
+ HsIntegral i _ -> fromInteger i
+ HsFractional f _ -> f
\end{code}
%************************************************************************
\begin{code}
-matchLiterals :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
+matchLiterals :: [Id]
+ -> Type -- Type of the whole case expression
+ -> [EquationInfo]
+ -> DsM MatchResult
-- All the EquationInfos have LitPats at the front
matchLiterals (var:vars) ty eqns
- = do { -- GROUP BY LITERAL
+ = do { -- Group by literal
let groups :: [[(Literal, EquationInfo)]]
groups = equivClasses cmpTaggedEqn (tagLitEqns eqns)
- -- DO THE MATCHING FOR EACH GROUP
+ -- Deal with each group
; alts <- mapM match_group groups
- -- MAKE THE PRIMITIVE CASE
- ; return (mkCoPrimCaseMatchResult var ty alts) }
+ -- Combine results. For everything except String
+ -- we can use a case expression; for String we need
+ -- a chain of if-then-else
+ ; if isStringTy (idType var) then
+ do { mrs <- mapM wrap_str_guard alts
+ ; return (foldr1 combineMatchResults mrs) }
+ else
+ return (mkCoPrimCaseMatchResult var ty alts)
+ }
where
match_group :: [(Literal, EquationInfo)] -> DsM (Literal, MatchResult)
match_group group
= do { let (lits, eqns) = unzip group
; match_result <- match vars ty (shiftEqns eqns)
; return (head lits, match_result) }
+
+ wrap_str_guard :: (Literal,MatchResult) -> DsM MatchResult
+ -- Equality check for string literals
+ wrap_str_guard (MachStr s, mr)
+ = do { eq_str <- dsLookupGlobalId eqStringName
+ ; lit <- mkStringExprFS s
+ ; let pred = mkApps (Var eq_str) [Var var, lit]
+ ; return (mkGuardedMatchResult pred mr) }
\end{code}
%************************************************************************
\begin{code}
matchNPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
--- All the EquationInfos have NPatOut at the front
+-- All the EquationInfos have NPat at the front
matchNPats (var:vars) ty eqns
= do { let groups :: [[(Literal, EquationInfo)]]
where
match_group :: [EquationInfo] -> DsM MatchResult
match_group (eqn1:eqns)
- = do { pred_expr <- dsExpr (HsApp (noLoc eq_chk) (nlHsVar var))
+ = do { lit_expr <- dsOverLit lit
+ ; neg_lit <- case mb_neg of
+ Nothing -> return lit_expr
+ Just neg -> do { neg_expr <- dsExpr neg
+ ; return (App neg_expr lit_expr) }
+ ; eq_expr <- dsExpr eq_chk
+ ; let pred_expr = mkApps eq_expr [Var var, neg_lit]
; match_result <- match vars ty (eqn1' : shiftEqns eqns)
; return (adjustMatchResult (eqn_wrap eqn1) $
-- Bring the eqn1 wrapper stuff into scope because
-- it may be used in pred_expr
mkGuardedMatchResult pred_expr match_result) }
where
- NPatOut _ _ eq_chk : pats1 = eqn_pats eqn1
+ NPat lit mb_neg eq_chk _ : pats1 = eqn_pats eqn1
eqn1' = eqn1 { eqn_wrap = idWrapper, eqn_pats = pats1 }
\end{code}
where
match_group :: [EquationInfo] -> DsM MatchResult
match_group (eqn1:eqns)
- = do { ge_expr <- dsExpr (HsApp (noLoc ge) (nlHsVar var))
- ; minusk_expr <- dsExpr (HsApp (noLoc sub) (nlHsVar var))
+ = do { ge_expr <- dsExpr ge
+ ; minus_expr <- dsExpr minus
+ ; lit_expr <- dsOverLit lit
+ ; let pred_expr = mkApps ge_expr [Var var, lit_expr]
+ minusk_expr = mkApps minus_expr [Var var, lit_expr]
; match_result <- match vars ty (eqn1' : map shift eqns)
; return (adjustMatchResult (eqn_wrap eqn1) $
-- Bring the eqn1 wrapper stuff into scope because
-- it may be used in ge_expr, minusk_expr
- mkGuardedMatchResult ge_expr $
+ mkGuardedMatchResult pred_expr $
mkCoLetMatchResult (NonRec n1 minusk_expr) $
match_result) }
where
- NPlusKPatOut (L _ n1) _ ge sub : pats1 = eqn_pats eqn1
+ NPlusKPat (L _ n1) lit ge minus : pats1 = eqn_pats eqn1
eqn1' = eqn1 { eqn_wrap = idWrapper, eqn_pats = pats1 }
shift eqn@(EqnInfo { eqn_wrap = wrap,
- eqn_pats = NPlusKPatOut (L _ n) _ _ _ : pats })
+ eqn_pats = NPlusKPat (L _ n) _ _ _ : pats })
= eqn { eqn_wrap = wrap . wrapBind n n1, eqn_pats = pats }
\end{code}
eqTaggedEqn (lit1,_) (lit2,_) = lit1 == lit2
tagLitEqns :: [EquationInfo] -> [(Literal, EquationInfo)]
-tagLitEqns eqns
- = [(get_lit eqn, eqn) | eqn <- eqns]
- where
- get_lit eqn = case firstPat eqn of
- LitPat hs_lit -> mk_core_lit hs_lit
- NPatOut hs_lit _ _ -> mk_core_lit hs_lit
- NPlusKPatOut _ i _ _ -> MachInt i
- other -> panic "tagLitEqns:bad pattern"
-
-mk_core_lit :: HsLit -> Literal
-mk_core_lit (HsIntPrim i) = mkMachInt i
-mk_core_lit (HsCharPrim c) = MachChar c
-mk_core_lit (HsStringPrim s) = MachStr s
-mk_core_lit (HsFloatPrim f) = MachFloat f
-mk_core_lit (HsDoublePrim d) = MachDouble d
-
- -- These ones are only needed in the NPatOut case,
- -- and the Literal is only used as a key for grouping,
- -- so the type doesn't matter. Actually I think HsInt, HsChar
- -- can't happen, but it does no harm to include them
-mk_core_lit (HsString s) = MachStr s
-mk_core_lit (HsRat r _) = MachFloat r
-mk_core_lit (HsInteger i _) = MachInt i
-mk_core_lit (HsInt i) = MachInt i
-mk_core_lit (HsChar c) = MachChar c
+tagLitEqns eqns = [(get_lit (firstPat eqn), eqn) | eqn <- eqns]
+
+get_lit :: Pat Id -> Literal
+-- Get a Core literal to use (only) a grouping key
+-- Hence its type doesn't need to match the type of the original literal
+get_lit (LitPat (HsIntPrim i)) = mkMachInt i
+get_lit (LitPat (HsCharPrim c)) = MachChar c
+get_lit (LitPat (HsStringPrim s)) = MachStr s
+get_lit (LitPat (HsFloatPrim f)) = MachFloat f
+get_lit (LitPat (HsDoublePrim d)) = MachDouble d
+get_lit (LitPat (HsString s)) = MachStr s
+
+get_lit (NPat (HsIntegral i _) Nothing _ _) = MachInt i
+get_lit (NPat (HsIntegral i _) (Just _) _ _) = MachInt (-i)
+get_lit (NPat (HsFractional r _) Nothing _ _) = MachFloat r
+get_lit (NPat (HsFractional r _) (Just _) _ _) = MachFloat (-r)
+
+get_lit (NPlusKPat _ (HsIntegral i _) _ _) = MachInt i
+
+-- These ones can't happen
+-- get_lit (LitPat (HsChar c))
+-- get_lit (LitPat (HsInt i))
+get_lit other = pprPanic "get_lit:bad pattern" (ppr other)
\end{code}
cvt (AppE x y) = HsApp (cvtl x) (cvtl y)
cvt (LamE ps e) = HsLam (mkMatchGroup [mkSimpleMatch (map cvtlp ps) (cvtl e)])
-cvt (TupE [e]) = cvt e
-cvt (TupE es) = ExplicitTuple(map cvtl es) Boxed
+cvt (TupE [e]) = cvt e
+cvt (TupE es) = ExplicitTuple(map cvtl es) Boxed
cvt (CondE x y z) = HsIf (cvtl x) (cvtl y) (cvtl z)
-cvt (LetE ds e) = HsLet (cvtdecs ds) (cvtl e)
+cvt (LetE ds e) = HsLet (cvtdecs ds) (cvtl e)
cvt (CaseE e ms) = HsCase (cvtl e) (mkMatchGroup (map cvtm ms))
-cvt (DoE ss) = HsDo DoExpr (cvtstmts ss) [] void
-cvt (CompE ss) = HsDo ListComp (cvtstmts ss) [] void
-cvt (ArithSeqE dd) = ArithSeqIn (cvtdd dd)
-cvt (ListE xs) = ExplicitList void (map cvtl xs)
+cvt (DoE ss) = cvtHsDo DoExpr ss
+cvt (CompE ss) = cvtHsDo ListComp ss
+cvt (ArithSeqE dd) = ArithSeq noPostTcExpr (cvtdd dd)
+cvt (ListE xs) = ExplicitList void (map cvtl xs)
cvt (InfixE (Just x) s (Just y))
= HsPar (noLoc $ OpApp (cvtl x) (cvtl s) undefined (cvtl y))
cvt (InfixE Nothing s (Just y)) = SectionR (cvtl s) (cvtl y)
cvt (InfixE (Just x) s Nothing ) = SectionL (cvtl x) (cvtl s)
cvt (InfixE Nothing s Nothing ) = cvt s -- Can I indicate this is an infix thing?
cvt (SigE e t) = ExprWithTySig (cvtl e) (cvtType t)
-cvt (RecConE c flds) = RecordCon (noLoc (cName c)) (map (\(x,y) -> (noLoc (vName x), cvtl y)) flds)
+cvt (RecConE c flds) = RecordCon (noLoc (cName c)) noPostTcExpr
+ (map (\(x,y) -> (noLoc (vName x), cvtl y)) flds)
cvt (RecUpdE e flds) = RecordUpd (cvtl e) (map (\(x,y) -> (noLoc (vName x), cvtl y)) flds)
+ placeHolderType placeHolderType
+
+cvtHsDo do_or_lc stmts
+ = HsDo do_or_ld (init stmts') body void
+ where
+ stmts' = cvtstmts ss
+ body = case last stmts' of
+ L _ (ExprStmt body _) -> body
cvtdecs :: [TH.Dec] -> [HsBindGroup RdrName]
cvtdecs [] = []
cvtstmts :: [TH.Stmt] -> [Hs.LStmt RdrName]
-cvtstmts [] = [] -- this is probably an error as every [stmt] should end with ResultStmt
-cvtstmts [NoBindS e] = [nlResultStmt (cvtl e)] -- when its the last element use ResultStmt
-cvtstmts (NoBindS e : ss) = nlExprStmt (cvtl e) : cvtstmts ss
-cvtstmts (TH.BindS p e : ss) = nlBindStmt (cvtlp p) (cvtl e) : cvtstmts ss
-cvtstmts (TH.LetS ds : ss) = nlLetStmt (cvtdecs ds) : cvtstmts ss
-cvtstmts (TH.ParS dss : ss) = nlParStmt [(cvtstmts ds, undefined) | ds <- dss] : cvtstmts ss
+cvtstmts [] = []
+cvtstmts (NoBindS e : ss) = noLoc (mkExprStmt (cvtl e)) : cvtstmts ss
+cvtstmts (TH.BindS p e : ss) = noLoc (mkBindStmt (cvtlp p) (cvtl e)) : cvtstmts ss
+cvtstmts (TH.LetS ds : ss) = noLoc (LetStmt (cvtdecs ds)) : cvtstmts ss
+cvtstmts (TH.ParS dss : ss) = noLoc (ParStmt [(cvtstmts ds, undefined) | ds <- dss]) : cvtstmts ss
cvtm :: TH.Match -> Hs.LMatch RdrName
cvtm (TH.Match p body wheres)
cvtguard :: TH.Body -> [LGRHS RdrName]
cvtguard (GuardedB pairs) = map cvtpair pairs
-cvtguard (NormalB e) = [noLoc (GRHS [ nlResultStmt (cvtl e) ])]
+cvtguard (NormalB e) = [noLoc (GRHS [] (cvtl e))]
cvtpair :: (TH.Guard,TH.Exp) -> LGRHS RdrName
-cvtpair (NormalG x,y) = noLoc (GRHS [nlBindStmt truePat (cvtl x),
- nlResultStmt (cvtl y)])
-cvtpair (PatG x,y) = noLoc (GRHS (cvtstmts x ++ [nlResultStmt (cvtl y)]))
+cvtpair (NormalG x,y) = noLoc (GRHS [nlBindStmt truePat (cvtl x)]
+ (cvtl y))
+cvtpair (PatG x,y) = noLoc (GRHS (cvtstmts x) (cvtl y))
-cvtOverLit :: Lit -> HsOverLit
+cvtOverLit :: Lit -> HsOverLit RdrName
cvtOverLit (IntegerL i) = mkHsIntegral i
cvtOverLit (RationalL r) = mkHsFractional r
-- An Integer is like an an (overloaded) '3' in a Haskell source program
cvtp :: TH.Pat -> Hs.Pat RdrName
cvtp (TH.LitP l)
- | overloadedLit l = NPatIn (cvtOverLit l) Nothing -- Not right for negative
+ | overloadedLit l = mkNPat (cvtOverLit l) Nothing -- Not right for negative
-- patterns; need to think
-- about that!
| otherwise = Hs.LitPat (cvtLit l)
data GRHSs a
type LHsExpr a = SrcLoc.Located (HsExpr a)
+type SyntaxExpr a = HsExpr a
+type PostTcExpr = HsExpr Var.Id
pprExpr :: (Outputable.OutputableBndr i) =>
HsExpr.HsExpr i -> Outputable.SDoc
import HsDecls ( HsGroup )
import HsPat ( LPat )
import HsLit ( HsLit(..), HsOverLit )
-import HsTypes ( LHsType, PostTcType, SyntaxName )
+import HsTypes ( LHsType, PostTcType )
import HsImpExp ( isOperator, pprHsVar )
-import HsBinds ( HsBindGroup )
+import HsBinds ( HsBindGroup, DictBinds )
-- others:
import Type ( Type, pprParendType )
import Var ( TyVar, Id )
import Name ( Name )
-import DataCon ( DataCon )
import BasicTypes ( IPName, Boxity, tupleParens, Fixity(..) )
import SrcLoc ( Located(..), unLoc )
import Outputable
\begin{code}
type LHsExpr id = Located (HsExpr id)
+-------------------------
+-- PostTcExpr is an evidence expression attached to the
+-- syntax tree by the type checker (c.f. postTcType)
+-- We use a PostTcTable where there are a bunch of pieces of
+-- evidence, more than is convenient to keep individually
+type PostTcExpr = HsExpr Id
+type PostTcTable = [(Name, Id)]
+
+noPostTcExpr :: PostTcExpr
+noPostTcExpr = HsLit (HsString FSLIT("noPostTcExpr"))
+
+noPostTcTable :: PostTcTable
+noPostTcTable = []
+
+-------------------------
+-- SyntaxExpr is like PostTcExpr, but it's filled in a little earlier,
+-- by the renamer. It's used for rebindable syntax.
+-- E.g. (>>=) is filled in before the renamer by the appropriate Name
+-- for (>>=), and then instantiated by the type checker with its
+-- type args tec
+
+type SyntaxExpr id = HsExpr id
+
+noSyntaxExpr :: SyntaxExpr id -- Before renaming, and sometimes after,
+ -- (if the syntax slot makes no sense)
+noSyntaxExpr = HsLit (HsString FSLIT("noSyntaxExpr"))
+
+
+type SyntaxTable id = [(Name, SyntaxExpr id)]
+-- *** Currently used only for CmdTop (sigh) ***
+-- * Before the renamer, this list is noSyntaxTable
+--
+-- * After the renamer, it takes the form [(std_name, HsVar actual_name)]
+-- For example, for the 'return' op of a monad
+-- normal case: (GHC.Base.return, HsVar GHC.Base.return)
+-- with rebindable syntax: (GHC.Base.return, return_22)
+-- where return_22 is whatever "return" is in scope
+--
+-- * After the type checker, it takes the form [(std_name, <expression>)]
+-- where <expression> is the evidence for the method
+
+noSyntaxTable :: SyntaxTable id
+noSyntaxTable = []
+
+
+-------------------------
data HsExpr id
= HsVar id -- variable
| HsIPVar (IPName id) -- implicit parameter
- | HsOverLit HsOverLit -- Overloaded literals; eliminated by type checker
+ | HsOverLit (HsOverLit id) -- Overloaded literals
| HsLit HsLit -- Simple (non-overloaded) literals
| HsLam (MatchGroup id) -- Currently always a single match
-- They are eventually removed by the type checker.
| NegApp (LHsExpr id) -- negated expr
- SyntaxName -- Name of 'negate' (see RnEnv.lookupSyntaxName)
+ (SyntaxExpr id) -- Name of 'negate'
| HsPar (LHsExpr id) -- parenthesised expr
-- because in this context we never use
-- the PatGuard or ParStmt variant
[LStmt id] -- "do":one or more stmts
- (ReboundNames id) -- Ids for [return,fail,>>=,>>]
- PostTcType -- Type of the whole expression
+ (LHsExpr id) -- The body; the last expression in the 'do'
+ -- of [ body | ... ] in a list comp
+ PostTcType -- Type of the whole expression
| ExplicitList -- syntactic list
PostTcType -- Gives type of components of list
-- Record construction
- | RecordCon (Located id) -- The constructor
+ | RecordCon (Located id) -- The constructor. After type checking
+ -- it's the *worker* Id of the constructor
+ PostTcExpr -- Data con Id applied to type args
(HsRecordBinds id)
- | RecordConOut DataCon
- (LHsExpr id) -- Data con Id applied to type args
- (HsRecordBinds id)
-
-
-- Record update
| RecordUpd (LHsExpr id)
(HsRecordBinds id)
-
- | RecordUpdOut (LHsExpr id) -- TRANSLATION
- Type -- Type of *input* record
- Type -- Type of *result* record (may differ from
+ PostTcType -- Type of *input* record
+ PostTcType -- Type of *result* record (may differ from
-- type of input record)
- (HsRecordBinds id)
| ExprWithTySig -- e :: type
(LHsExpr id)
(LHsExpr id)
(LHsType Name) -- Retain the signature for round-tripping purposes
- | ArithSeqIn -- arithmetic sequence
- (ArithSeqInfo id)
- | ArithSeqOut
- (LHsExpr id) -- (typechecked, of course)
+ | ArithSeq -- arithmetic sequence
+ PostTcExpr
(ArithSeqInfo id)
- | PArrSeqIn -- arith. sequence for parallel array
- (ArithSeqInfo id) -- [:e1..e2:] or [:e1, e2..e3:]
- | PArrSeqOut
- (LHsExpr id) -- (typechecked, of course)
+
+ | PArrSeq -- arith. sequence for parallel array
+ PostTcExpr -- [:e1..e2:] or [:e1, e2..e3:]
(ArithSeqInfo id)
| HsSCC FastString -- "set cost centre" (_scc_) annotation
-- pasted back in by the desugarer
\end{code}
-Table of bindings of names used in rebindable syntax.
-This gets filled in by the renamer.
-
-\begin{code}
-type ReboundNames id = [(Name, HsExpr id)]
--- * Before the renamer, this list is empty
---
--- * After the renamer, it takes the form [(std_name, HsVar actual_name)]
--- For example, for the 'return' op of a monad
--- normal case: (GHC.Base.return, HsVar GHC.Base.return)
--- with rebindable syntax: (GHC.Base.return, return_22)
--- where return_22 is whatever "return" is in scope
---
--- * After the type checker, it takes the form [(std_name, <expression>)]
--- where <expression> is the evidence for the method
-\end{code}
-
A @Dictionary@, unless of length 0 or 1, becomes a tuple. A
@ClassDictLam dictvars methods expr@ is, therefore:
\begin{verbatim}
= sep [hang (ptext SLIT("let")) 2 (pprBinds binds),
hang (ptext SLIT("in")) 2 (ppr expr)]
-ppr_expr (HsDo do_or_list_comp stmts _ _) = pprDo do_or_list_comp stmts
+ppr_expr (HsDo do_or_list_comp stmts body _) = pprDo do_or_list_comp stmts body
ppr_expr (ExplicitList _ exprs)
= brackets (fsep (punctuate comma (map ppr_lexpr exprs)))
ppr_expr (ExplicitTuple exprs boxity)
= tupleParens boxity (sep (punctuate comma (map ppr_lexpr exprs)))
-ppr_expr (RecordCon con_id rbinds)
+ppr_expr (RecordCon con_id con_expr rbinds)
= pp_rbinds (ppr con_id) rbinds
-ppr_expr (RecordConOut data_con con rbinds)
- = pp_rbinds (ppr con) rbinds
-ppr_expr (RecordUpd aexp rbinds)
- = pp_rbinds (pprParendExpr aexp) rbinds
-ppr_expr (RecordUpdOut aexp _ _ rbinds)
+ppr_expr (RecordUpd aexp rbinds _ _)
= pp_rbinds (pprParendExpr aexp) rbinds
ppr_expr (ExprWithTySig expr sig)
= hang (nest 2 (ppr_lexpr expr) <+> dcolon)
4 (ppr sig)
-ppr_expr (ArithSeqIn info)
- = brackets (ppr info)
-ppr_expr (ArithSeqOut expr info)
- = brackets (ppr info)
-
-ppr_expr (PArrSeqIn info)
- = pa_brackets (ppr info)
-ppr_expr (PArrSeqOut expr info)
- = pa_brackets (ppr info)
+ppr_expr (ArithSeq expr info) = brackets (ppr info)
+ppr_expr (PArrSeq expr info) = pa_brackets (ppr info)
-ppr_expr EWildPat = char '_'
+ppr_expr EWildPat = char '_'
ppr_expr (ELazyPat e) = char '~' <> pprParendExpr e
ppr_expr (EAsPat v e) = ppr v <> char '@' <> pprParendExpr e
-- because in this context we never use
-- the PatGuard or ParStmt variant
[Stmt id] -- HsExpr's are really HsCmd's
- (ReboundNames id)
PostTcType -- Type of the whole expression
SrcLoc
= HsCmdTop (LHsCmd id)
[PostTcType] -- types of inputs on the command's stack
PostTcType -- return type of the command
- (ReboundNames id)
+ (SyntaxTable id)
-- after type checking:
-- names used in the command's desugaring
\end{code}
-- Nothing after typechecking
(GRHSs id)
--- gaw 2004
hsLMatchPats :: LMatch id -> [LPat id]
hsLMatchPats (L _ (Match pats _ _)) = pats
data GRHSs id
= GRHSs [LGRHS id] -- Guarded RHSs
[HsBindGroup id] -- The where clause
--- gaw 2004
--- PostTcType -- Type of RHS (after type checking)
type LGRHS id = Located (GRHS id)
-data GRHS id
- = GRHS [LStmt id] -- The RHS is the final ResultStmt
+data GRHS id = GRHS [LStmt id] -- Guards
+ (LHsExpr id) -- Right hand side
\end{code}
We know the list must have at least one @Match@ in it.
pprMatch :: OutputableBndr id => HsMatchContext id -> Match id -> SDoc
--- gaw 2004
pprMatch ctxt (Match pats maybe_ty grhss)
= pp_name ctxt <+> sep [sep (map ppr pats),
ppr_maybe_ty,
pprGRHSs :: OutputableBndr id => HsMatchContext id -> GRHSs id -> SDoc
--- gaw 2004
pprGRHSs ctxt (GRHSs grhss binds)
= vcat (map (pprGRHS ctxt . unLoc) grhss)
$$
pprGRHS :: OutputableBndr id => HsMatchContext id -> GRHS id -> SDoc
-pprGRHS ctxt (GRHS [L _ (ResultStmt expr)])
+pprGRHS ctxt (GRHS [] expr)
= pp_rhs ctxt expr
-pprGRHS ctxt (GRHS guarded)
+pprGRHS ctxt (GRHS guards expr)
= sep [char '|' <+> interpp'SP guards, pp_rhs ctxt expr]
- where
- ResultStmt expr = unLoc (last guarded)
- -- Last stmt should be a ResultStmt for guards
- guards = init guarded
pp_rhs ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs)
\end{code}
\begin{code}
type LStmt id = Located (Stmt id)
+-- The SyntaxExprs in here are used *only* for do-notation, which
+-- has rebindable syntax. Otherwise they are unused.
data Stmt id
- = BindStmt (LPat id) (LHsExpr id)
+ = BindStmt (LPat id)
+ (LHsExpr id)
+ (SyntaxExpr id) -- The (>>=) operator
+ (SyntaxExpr id) -- The fail operator
+ -- The fail operator is noSyntaxExpr
+ -- if the pattern match can't fail
+
+ | ExprStmt (LHsExpr id)
+ (SyntaxExpr id) -- The (>>) operator
+ PostTcType -- Element type of the RHS (used for arrows)
+
| LetStmt [HsBindGroup id]
- | ResultStmt (LHsExpr id) -- See notes that follow
- | ExprStmt (LHsExpr id) PostTcType -- See notes that follow
- -- The type is the *element type* of the expression
-- ParStmts only occur in a list comprehension
| ParStmt [([LStmt id], [id])] -- After remaing, the ids are the binders
-- are used before they are bound in the stmts of the RecStmt
-- From a type-checking point of view, these ones have to be monomorphic
- --- This field is only valid after typechecking
- [LHsExpr id] -- These expressions correspond
+ --- These fields are only valid after typechecking
+ [PostTcExpr] -- These expressions correspond
-- 1-to-1 with the "recursive" [id], and are the expresions that
-- should be returned by the recursion. They may not quite be the
-- Ids themselves, because the Id may be *polymorphic*, but
-- the returned thing has to be *monomorphic*.
+ (DictBinds id) -- Method bindings of Ids bound by the RecStmt,
+ -- and used afterwards
\end{code}
-ExprStmts and ResultStmts are a bit tricky, because what they mean
+ExprStmts are a bit tricky, because what they mean
depends on the context. Consider the following contexts:
A do expression of type (m res_ty)
E :: m any_ty
Translation: E >> ...
- * ResultStmt E: do { ....; E }
- E :: m res_ty
- Translation: E
-
A list comprehensions of type [elt_ty]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
* ExprStmt E Bool: [ .. | .... E ]
E :: Bool
Translation: if E then fail else ...
- * ResultStmt E: [ E | ... ]
- E :: elt_ty
- Translation: return E
-
A guard list, guarding a RHS of type rhs_ty
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
* ExprStmt E Bool: f x | ..., E, ... = ...rhs...
E :: Bool
Translation: if E then fail else ...
- * ResultStmt E: f x | ...guards... = E
- E :: rhs_ty
- Translation: E
-
Array comprehensions are handled like list comprehensions -=chak
Note [RecStmt]
instance OutputableBndr id => Outputable (Stmt id) where
ppr stmt = pprStmt stmt
-pprStmt (BindStmt pat expr) = hsep [ppr pat, ptext SLIT("<-"), ppr expr]
-pprStmt (LetStmt binds) = hsep [ptext SLIT("let"), pprBinds binds]
-pprStmt (ExprStmt expr _) = ppr expr
-pprStmt (ResultStmt expr) = ppr expr
-pprStmt (ParStmt stmtss) = hsep (map (\stmts -> ptext SLIT("| ") <> ppr stmts) stmtss)
-pprStmt (RecStmt segment _ _ _) = ptext SLIT("rec") <+> braces (vcat (map ppr segment))
-
-pprDo :: OutputableBndr id => HsStmtContext any -> [LStmt 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
-
-pprComp :: OutputableBndr id => (SDoc -> SDoc) -> [LStmt id] -> SDoc
-pprComp brack stmts
+pprStmt (BindStmt pat expr _ _) = hsep [ppr pat, ptext SLIT("<-"), ppr expr]
+pprStmt (LetStmt binds) = hsep [ptext SLIT("let"), pprBinds binds]
+pprStmt (ExprStmt expr _ _) = ppr expr
+pprStmt (ParStmt stmtss) = hsep (map (\stmts -> ptext SLIT("| ") <> ppr stmts) stmtss)
+pprStmt (RecStmt segment _ _ _ _) = ptext SLIT("rec") <+> braces (vcat (map ppr segment))
+
+pprDo :: OutputableBndr id => HsStmtContext any -> [LStmt id] -> LHsExpr id -> SDoc
+pprDo DoExpr stmts body = hang (ptext SLIT("do")) 2 (vcat (map ppr stmts) $$ ppr body)
+pprDo (MDoExpr _) stmts body = hang (ptext SLIT("mdo")) 3 (vcat (map ppr stmts) $$ ppr body)
+pprDo ListComp stmts body = pprComp brackets stmts body
+pprDo PArrComp stmts body = pprComp pa_brackets stmts body
+
+pprComp :: OutputableBndr id => (SDoc -> SDoc) -> [LStmt id] -> LHsExpr id -> SDoc
+pprComp brack quals body
= brack $
- hang (ppr expr <+> char '|')
+ hang (ppr body <+> char '|')
4 (interpp'SP quals)
- where
- ResultStmt expr = unLoc (last stmts) -- Last stmt should
- quals = init stmts -- be an ResultStmt
\end{code}
%************************************************************************
data HsStmtContext id
= ListComp
| DoExpr
- | MDoExpr -- Recursive do-expression
+ | MDoExpr PostTcTable -- Recursive do-expression
+ -- (tiresomely, it needs table
+ -- of its return/bind ops)
| PArrComp -- Parallel array comprehension
| PatGuard (HsMatchContext id) -- Pattern guard for specified thing
| ParStmtCtxt (HsStmtContext id) -- A branch of a parallel stmt
\begin{code}
isDoExpr :: HsStmtContext id -> Bool
-isDoExpr DoExpr = True
-isDoExpr MDoExpr = True
-isDoExpr other = False
+isDoExpr DoExpr = True
+isDoExpr (MDoExpr _) = True
+isDoExpr other = False
\end{code}
\begin{code}
pprStmtContext (ParStmtCtxt c) = sep [ptext SLIT("a parallel branch of"), pprStmtContext c]
pprStmtContext (PatGuard ctxt) = ptext SLIT("a pattern guard for") $$ pprMatchContext ctxt
pprStmtContext DoExpr = ptext SLIT("a 'do' expression")
-pprStmtContext MDoExpr = ptext SLIT("an 'mdo' expression")
+pprStmtContext (MDoExpr _) = ptext SLIT("an 'mdo' expression")
pprStmtContext ListComp = ptext SLIT("a list comprehension")
pprStmtContext PArrComp = ptext SLIT("an array comprehension")
matchContextErrString (StmtCtxt (ParStmtCtxt c)) = matchContextErrString (StmtCtxt c)
matchContextErrString (StmtCtxt (PatGuard _)) = "pattern guard"
matchContextErrString (StmtCtxt DoExpr) = "'do' expression"
-matchContextErrString (StmtCtxt MDoExpr) = "'mdo' expression"
+matchContextErrString (StmtCtxt (MDoExpr _)) = "'mdo' expression"
matchContextErrString (StmtCtxt ListComp) = "list comprehension"
matchContextErrString (StmtCtxt PArrComp) = "array comprehension"
\end{code}
data GRHSs a
type LHsExpr a = Located (HsExpr a)
+type SyntaxExpr a = HsExpr a
pprExpr :: (OutputableBndr i) =>
HsExpr i -> SDoc
#include "HsVersions.h"
+import {-# SOURCE #-} HsExpr( SyntaxExpr )
import Type ( Type )
-import HsTypes ( SyntaxName )
import Outputable
import FastString
import Ratio ( Rational )
(HsDoublePrim x1) == (HsDoublePrim x2) = x1==x2
lit1 == lit2 = False
-data HsOverLit -- An overloaded literal
- = HsIntegral Integer SyntaxName -- Integer-looking literals;
- -- The name is fromInteger
- | HsFractional Rational SyntaxName -- Frac-looking literals
- -- The name is fromRational
+data HsOverLit id -- An overloaded literal
+ = HsIntegral Integer (SyntaxExpr id) -- Integer-looking literals;
+ | HsFractional Rational (SyntaxExpr id) -- Frac-looking literals
+ -- Before type checking, the SyntaxExpr is 'fromInteger' or 'fromRational'
+ -- After type checking, it is (fromInteger 3) or lit_78; that is,
+ -- the expression that should replace the literal.
+ -- This is unusual, because we're replacing 'fromInteger' with a call
+ -- to fromInteger. Reason: it allows commoning up of the fromInteger
+ -- calls, which wouldn't be possible if the desguarar made the application
-- Comparison operations are needed when grouping literals
-- for compiling pattern-matching (module MatchLit)
-instance Eq HsOverLit where
+instance Eq (HsOverLit id) where
(HsIntegral i1 _) == (HsIntegral i2 _) = i1 == i2
(HsFractional f1 _) == (HsFractional f2 _) = f1 == f2
l1 == l2 = False
-instance Ord HsOverLit where
+instance Ord (HsOverLit id) where
compare (HsIntegral i1 _) (HsIntegral i2 _) = i1 `compare` i2
compare (HsIntegral _ _) (HsFractional _ _) = LT
compare (HsFractional f1 _) (HsFractional f2 _) = f1 `compare` f2
ppr (HsDoublePrim d) = rational d <> text "##"
ppr (HsIntPrim i) = integer i <> char '#'
-instance Outputable HsOverLit where
+instance Outputable (HsOverLit id) where
ppr (HsIntegral i _) = integer i
ppr (HsFractional f _) = rational f
\end{code}
isWildPat,
patsAreAllCons, isConPat, isSigPat,
- patsAreAllLits, isLitPat
+ patsAreAllLits, isLitPat, isIrrefutableHsPat
) where
#include "HsVersions.h"
-import {-# SOURCE #-} HsExpr ( HsExpr )
+import {-# SOURCE #-} HsExpr ( SyntaxExpr )
-- friends:
import HsBinds ( DictBinds, emptyLHsBinds, pprLHsBinds )
import HsLit ( HsLit(HsCharPrim), HsOverLit )
-import HsTypes ( LHsType, SyntaxName, PostTcType )
+import HsTypes ( LHsType, PostTcType )
import BasicTypes ( Boxity, tupleParens )
-- others:
import PprCore ( {- instance OutputableBndr TyVar -} )
import TysWiredIn ( nilDataCon, charDataCon, charTy )
import Var ( TyVar )
-import DataCon ( DataCon )
+import DataCon ( DataCon, dataConTyCon )
+import TyCon ( isProductTyCon )
import Outputable
import Type ( Type )
import SrcLoc ( Located(..), unLoc, noLoc )
| LitPat HsLit -- Used for *non-overloaded* literal patterns:
-- Int#, Char#, Int, Char, String, etc.
- | NPatIn HsOverLit -- Always positive
- (Maybe SyntaxName) -- Just (Name of 'negate') for negative
- -- patterns, Nothing otherwise
-
- | NPatOut HsLit -- Used for literal patterns where there's an equality function to call
- -- The literal is retained so that the desugarer can readily identify
- -- equations with identical literal-patterns
- -- Always HsInteger, HsRat or HsString.
- -- *Unlike* NPatIn, for negative literals, the
- -- literal is acutally negative!
- Type -- Type of pattern, t
- (HsExpr id) -- Of type t -> Bool; detects match
-
- | NPlusKPatIn (Located id) -- n+k pattern
- HsOverLit -- It'll always be an HsIntegral
- SyntaxName -- Name of '-' (see RnEnv.lookupSyntaxName)
-
- | NPlusKPatOut (Located id)
- Integer
- (HsExpr id) -- Of type t -> Bool; detects match
- (HsExpr id) -- Of type t -> t; subtracts k
+ | NPat (HsOverLit id) -- *Always* positive
+ (Maybe (SyntaxExpr id)) -- Just (Name of 'negate') for negative
+ -- patterns, Nothing otherwise
+ (SyntaxExpr id) -- Equality checker, of type t->t->Bool
+ PostTcType -- Type of the pattern
+ | NPlusKPat (Located id) -- n+k pattern
+ (HsOverLit id) -- It'll always be an HsIntegral
+ (SyntaxExpr id) -- (>=) function, of type t->t->Bool
+ (SyntaxExpr id) -- Name of '-' (see RnEnv.lookupSyntaxName)
------------ Generics ---------------
| TypePat (LHsType id) -- Type pattern for generic definitions
else pprUserCon con details
pprPat (LitPat s) = ppr s
-pprPat (NPatIn l _) = ppr l
-pprPat (NPatOut l _ _) = ppr l
-pprPat (NPlusKPatIn n k _) = hcat [ppr n, char '+', ppr k]
-pprPat (NPlusKPatOut n k _ _) = hcat [ppr n, char '+', integer k]
+pprPat (NPat l _ _ _) = ppr l
+pprPat (NPlusKPat n k _ _) = hcat [ppr n, char '+', ppr k]
pprPat (TypePat ty) = ptext SLIT("{|") <> ppr ty <> ptext SLIT("|}")
pprPat (SigPatIn pat ty) = ppr pat <+> dcolon <+> ppr ty
pprPat (SigPatOut pat ty) = ppr pat <+> dcolon <+> ppr ty
isLitPat (AsPat _ pat) = isLitPat (unLoc pat)
isLitPat (LitPat _) = True
-isLitPat (NPatIn _ _) = True
-isLitPat (NPatOut _ _ _) = True
-isLitPat (NPlusKPatIn _ _ _) = True
-isLitPat (NPlusKPatOut _ _ _ _) = True
+isLitPat (NPat _ _ _ _) = True
+isLitPat (NPlusKPat _ _ _ _) = True
isLitPat other = False
+
+isIrrefutableHsPat :: LPat id -> Bool
+-- This function returns False if it's in doubt; specifically
+-- on a ConPatIn it doesn't know th size of the constructor family
+-- But if it returns True, the pattern is definitely irrefutable
+isIrrefutableHsPat pat
+ = go pat
+ where
+ go (L _ pat) = go1 pat
+
+ go1 (WildPat _) = True
+ go1 (VarPat _) = True
+ go1 (VarPatOut _ _) = True
+ go1 (LazyPat _) = True
+ go1 (ParPat pat) = go pat
+ go1 (AsPat _ pat) = go pat
+ go1 (SigPatIn pat _) = go pat
+ go1 (SigPatOut pat _) = go pat
+ go1 (ListPat pats _) = all go pats
+ go1 (TuplePat pats _) = all go pats
+ go1 (PArrPat pats _) = all go pats
+
+ go1 (ConPatIn _ _) = False -- Conservative
+ go1 (ConPatOut (L _ con) _ _ _ details _)
+ = isProductTyCon (dataConTyCon con)
+ && all go (hsConArgs details)
+
+ go1 (LitPat _) = False
+ go1 (NPat _ _ _ _) = False
+ go1 (NPlusKPat _ _ _ _) = False
+
+ go1 (TypePat _) = panic "isIrrefutableHsPat: type pattern"
+ go1 (DictPat _ _) = panic "isIrrefutableHsPat: type pattern"
\end{code}
-- Type place holder
PostTcType, placeHolderType,
- -- Name place holder
- SyntaxName, placeHolderName,
-
-- Printing
pprParendHsType, pprHsForAll, pprHsContext, ppr_hs_context, pprHsTyVarBndr
) where
import Type ( Type )
import Kind ( {- instance Outputable Kind -}, Kind,
pprParendKind, pprKind, isLiftedTypeKind )
-import Name ( Name, mkInternalName )
-import OccName ( mkVarOcc )
import BasicTypes ( IPName, Boxity, tupleParens )
-import PrelNames ( unboundKey )
-import SrcLoc ( noSrcLoc, Located(..), unLoc, noSrcSpan )
+import SrcLoc ( Located(..), unLoc, noSrcSpan )
import StaticFlags ( opt_PprStyle_Debug )
import Outputable
\end{code}
placeHolderType :: PostTcType -- Used before typechecking
placeHolderType = panic "Evaluated the place holder for a PostTcType"
-
-
-type SyntaxName = Name -- These names are filled in by the renamer
- -- Before then they are a placeHolderName (so that
- -- we can still print the HsSyn)
- -- They correspond to "rebindable syntax";
- -- See RnEnv.lookupSyntaxName
-
-placeHolderName :: SyntaxName
-placeHolderName = mkInternalName unboundKey
- (mkVarOcc FSLIT("syntaxPlaceHolder"))
- noSrcLoc
\end{code}
%************************************************************************
(pat:_) -> combineSrcSpans (getLoc pat) (getLoc rhs)
unguardedRHS :: LHsExpr id -> [LGRHS id]
-unguardedRHS rhs@(L loc _) = [L loc (GRHS [L loc (ResultStmt rhs)])]
+unguardedRHS rhs@(L loc _) = [L loc (GRHS [] rhs)]
mkHsAppTy :: LHsType name -> LHsType name -> LHsType name
mkHsAppTy t1 t2 = addCLoc t1 t2 (HsAppTy t1 t2)
= mkSimpleMatch [pat] expr
glueBindsOnGRHSs :: HsBindGroup id -> GRHSs id -> GRHSs id
--- gaw 2004
glueBindsOnGRHSs binds1 (GRHSs grhss binds2)
= GRHSs grhss (binds1 : binds2)
+-------------------------------
-- These are the bits of syntax that contain rebindable names
-- See RnEnv.lookupSyntaxName
-mkHsIntegral i = HsIntegral i placeHolderName
-mkHsFractional f = HsFractional f placeHolderName
-mkNPlusKPat n k = NPlusKPatIn n k placeHolderName
-mkHsDo ctxt stmts = HsDo ctxt stmts [] placeHolderType
+mkHsIntegral i = HsIntegral i noSyntaxExpr
+mkHsFractional f = HsFractional f noSyntaxExpr
+mkHsDo ctxt stmts body = HsDo ctxt stmts body placeHolderType
+
+mkNPat lit neg = NPat lit neg noSyntaxExpr placeHolderType
+mkNPlusKPat id lit = NPlusKPat id lit noSyntaxExpr noSyntaxExpr
+mkExprStmt expr = ExprStmt expr noSyntaxExpr placeHolderType
+mkBindStmt pat expr = BindStmt pat expr noSyntaxExpr noSyntaxExpr
+mkRecStmt stmts = RecStmt stmts [] [] [] emptyLHsBinds
+
+-------------------------------
--- A useful function for building @OpApps@. The operator is always a
-- variable, and we don't know the fixity yet.
mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar op)) (error "mkOpApp:fixity") e2
nlTuplePat pats box = noLoc (TuplePat pats box)
nlWildPat = noLoc (WildPat placeHolderType) -- Pre-typechecking
-nlHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id
-nlHsDo ctxt stmts = noLoc (mkHsDo ctxt stmts)
+nlHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> LHsExpr id
+nlHsDo ctxt stmts body = noLoc (mkHsDo ctxt stmts body)
nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2)
nlHsAppTy f t = noLoc (HsAppTy f t)
nlHsTyVar x = noLoc (HsTyVar x)
nlHsFunTy a b = noLoc (HsFunTy a b)
-
-nlExprStmt expr = noLoc (ExprStmt expr placeHolderType)
-nlBindStmt pat expr = noLoc (BindStmt pat expr)
-nlLetStmt binds = noLoc (LetStmt binds)
-nlResultStmt expr = noLoc (ResultStmt expr)
-nlParStmt stuff = noLoc (ParStmt stuff)
\end{code}
%************************************************************************
\begin{code}
-collectStmtsBinders :: [LStmt id] -> [Located id]
-collectStmtsBinders = concatMap collectLStmtBinders
+collectLStmtsBinders :: [LStmt id] -> [Located id]
+collectLStmtsBinders = concatMap collectLStmtBinders
+collectStmtsBinders :: [Stmt id] -> [Located id]
+collectStmtsBinders = concatMap collectStmtBinders
+
+collectLStmtBinders :: LStmt id -> [Located id]
collectLStmtBinders = collectStmtBinders . unLoc
collectStmtBinders :: Stmt id -> [Located id]
-- Id Binders for a Stmt... [but what about pattern-sig type vars]?
-collectStmtBinders (BindStmt pat _) = collectLocatedPatBinders pat
-collectStmtBinders (LetStmt binds) = collectGroupBinders binds
-collectStmtBinders (ExprStmt _ _) = []
-collectStmtBinders (ResultStmt _) = []
-collectStmtBinders (RecStmt ss _ _ _) = collectStmtsBinders ss
-collectStmtBinders other = panic "collectStmtBinders"
+collectStmtBinders (BindStmt pat _ _ _) = collectLocatedPatBinders pat
+collectStmtBinders (LetStmt binds) = collectGroupBinders binds
+collectStmtBinders (ExprStmt _ _ _) = []
+collectStmtBinders (RecStmt ss _ _ _ _) = collectLStmtsBinders ss
+collectStmtBinders other = panic "collectStmtBinders"
\end{code}
collectLocatedPatsBinders pats = foldr collectl [] pats
---------------------
-collectl (L l (VarPat var)) bndrs = L l var : bndrs
-collectl (L l (VarPatOut var bs)) bndrs = L l var : collectHsBindLocatedBinders bs
- ++ bndrs
-collectl (L l pat) bndrs = collect pat bndrs
-
----------------------
-collect (WildPat _) bndrs = bndrs
-collect (LazyPat pat) bndrs = collectl pat bndrs
-collect (AsPat a pat) bndrs = a : collectl pat bndrs
-collect (ParPat pat) bndrs = collectl pat bndrs
-
-collect (ListPat pats _) bndrs = foldr collectl bndrs pats
-collect (PArrPat pats _) bndrs = foldr collectl bndrs pats
-collect (TuplePat pats _) bndrs = foldr collectl bndrs pats
-
-collect (ConPatIn c ps) bndrs = foldr collectl bndrs (hsConArgs ps)
-collect (ConPatOut c _ ds bs ps _) bndrs = map noLoc ds
- ++ collectHsBindLocatedBinders bs
- ++ foldr collectl bndrs (hsConArgs ps)
-collect (LitPat _) bndrs = bndrs
-collect (NPatIn _ _) bndrs = bndrs
-collect (NPatOut _ _ _) bndrs = bndrs
-
-collect (NPlusKPatIn n _ _) bndrs = n : bndrs
-collect (NPlusKPatOut n _ _ _) bndrs = n : bndrs
-
-collect (SigPatIn pat _) bndrs = collectl pat bndrs
-collect (SigPatOut pat _) bndrs = collectl pat bndrs
-collect (TypePat ty) bndrs = bndrs
-collect (DictPat ids1 ids2) bndrs = map noLoc ids1 ++ map noLoc ids2
- ++ bndrs
+collectl (L l pat) bndrs
+ = go pat
+ where
+ go (VarPat var) = L l var : bndrs
+ go (VarPatOut var bs) = L l var : collectHsBindLocatedBinders bs
+ ++ bndrs
+ go (WildPat _) = bndrs
+ go (LazyPat pat) = collectl pat bndrs
+ go (AsPat a pat) = a : collectl pat bndrs
+ go (ParPat pat) = collectl pat bndrs
+
+ go (ListPat pats _) = foldr collectl bndrs pats
+ go (PArrPat pats _) = foldr collectl bndrs pats
+ go (TuplePat pats _) = foldr collectl bndrs pats
+
+ go (ConPatIn c ps) = foldr collectl bndrs (hsConArgs ps)
+ go (ConPatOut c _ ds bs ps _) = map noLoc ds
+ ++ collectHsBindLocatedBinders bs
+ ++ foldr collectl bndrs (hsConArgs ps)
+ go (LitPat _) = bndrs
+ go (NPat _ _ _ _) = bndrs
+ go (NPlusKPat n _ _ _) = n : bndrs
+
+ go (SigPatIn pat _) = collectl pat bndrs
+ go (SigPatOut pat _) = collectl pat bndrs
+ go (TypePat ty) = bndrs
+ go (DictPat ids1 ids2) = map noLoc ids1 ++ map noLoc ids2
+ ++ bndrs
\end{code}
\begin{code}
-> Maybe Module
-> [SCC ModSummary]
-- Calculate SCCs of the module graph, possibly dropping the hi-boot nodes
+-- The resulting list of strongly-connected-components is in topologically
+-- sorted order, starting with the module(s) at the bottom of the
+-- dependency graph (ie compile them first) and ending with the ones at
+-- the top.
--
-- Drop hi-boot nodes (first boolean arg)?
--
import Var ( Id )
import Module ( emptyModuleEnv )
-import RdrName ( RdrName )
+import RdrName ( GlobalRdrEnv, RdrName )
import HsSyn ( HsModule, LHsBinds )
import SrcLoc ( Located(..) )
import StringBuffer ( hGetStringBuffer )
import IfaceEnv ( initNameCache )
import LoadIface ( ifaceStats, initExternalPackageState )
import PrelInfo ( wiredInThings, basicKnownKeyNames )
-import RdrName ( GlobalRdrEnv )
import MkIface ( checkOldIface, mkIface )
import Desugar
import Flattening ( flatten )
; let icontext = hsc_IC hsc_env
; case maybe_stmt of {
Nothing -> return Nothing ; -- Parse error
- Just (Just (L _ (ExprStmt expr _)))
+ Just (Just (L _ (ExprStmt expr _ _)))
-> tcRnExpr hsc_env icontext expr ;
Just other -> do { errorMsg ("not an expression: `" ++ expr ++ "'") ;
return Nothing } ;
| gdrh { L1 [$1] }
gdrh :: { LGRHS RdrName }
- : '|' quals '=' exp { LL $ GRHS (reverse (L (getLoc $4) (ResultStmt $4) :
- unLoc $2)) }
+ : '|' quals '=' exp { sL (comb2 $1 $>) $ GRHS (reverse (unLoc $2)) $4 }
sigdecl :: { Located (OrdList (LHsDecl RdrName)) }
: infixexp '::' sigtype
| '-' fexp { LL $ mkHsNegApp $2 }
| 'do' stmtlist {% let loc = comb2 $1 $2 in
- checkDo loc (unLoc $2) >>= \ stmts ->
- return (L loc (mkHsDo DoExpr stmts)) }
+ checkDo loc (unLoc $2) >>= \ (stmts,body) ->
+ return (L loc (mkHsDo DoExpr stmts body)) }
| 'mdo' stmtlist {% let loc = comb2 $1 $2 in
- checkMDo loc (unLoc $2) >>= \ stmts ->
- return (L loc (mkHsDo MDoExpr stmts)) }
-
+ checkDo loc (unLoc $2) >>= \ (stmts,body) ->
+ return (L loc (mkHsDo (MDoExpr noPostTcTable) stmts body)) }
| scc_annot exp { LL $ if opt_SccProfilingOn
then HsSCC (unLoc $1) $2
else HsPar $2 }
list :: { LHsExpr RdrName }
: exp { L1 $ ExplicitList placeHolderType [$1] }
| lexps { L1 $ ExplicitList placeHolderType (reverse (unLoc $1)) }
- | exp '..' { LL $ ArithSeqIn (From $1) }
- | exp ',' exp '..' { LL $ ArithSeqIn (FromThen $1 $3) }
- | exp '..' exp { LL $ ArithSeqIn (FromTo $1 $3) }
- | exp ',' exp '..' exp { LL $ ArithSeqIn (FromThenTo $1 $3 $5) }
- | exp pquals { LL $ mkHsDo ListComp
- (reverse (L (getLoc $1) (ResultStmt $1) :
- unLoc $2)) }
+ | exp '..' { LL $ ArithSeq noPostTcExpr (From $1) }
+ | exp ',' exp '..' { LL $ ArithSeq noPostTcExpr (FromThen $1 $3) }
+ | exp '..' exp { LL $ ArithSeq noPostTcExpr (FromTo $1 $3) }
+ | exp ',' exp '..' exp { LL $ ArithSeq noPostTcExpr (FromThenTo $1 $3 $5) }
+ | exp pquals { sL (comb2 $1 $>) $ mkHsDo ListComp (reverse (unLoc $2)) $1 }
lexps :: { Located [LHsExpr RdrName] }
: lexps ',' exp { LL ($3 : unLoc $1) }
| exp { L1 $ ExplicitPArr placeHolderType [$1] }
| lexps { L1 $ ExplicitPArr placeHolderType
(reverse (unLoc $1)) }
- | exp '..' exp { LL $ PArrSeqIn (FromTo $1 $3) }
- | exp ',' exp '..' exp { LL $ PArrSeqIn (FromThenTo $1 $3 $5) }
- | exp pquals { LL $ mkHsDo PArrComp
- (reverse (L (getLoc $1) (ResultStmt $1) :
- unLoc $2))
- }
+ | exp '..' exp { LL $ PArrSeq noPostTcExpr (FromTo $1 $3) }
+ | exp ',' exp '..' exp { LL $ PArrSeq noPostTcExpr (FromThenTo $1 $3 $5) }
+ | exp pquals { sL (comb2 $1 $>) $ mkHsDo PArrComp (reverse (unLoc $2)) $1 }
-- We are reusing `lexps' and `pquals' from the list case.
| gdpat { L1 [$1] }
gdpat :: { LGRHS RdrName }
- : '|' quals '->' exp { let r = L (getLoc $4) (ResultStmt $4)
- in LL $ GRHS (reverse (r : unLoc $2)) }
+ : '|' quals '->' exp { sL (comb2 $1 $>) $ GRHS (reverse (unLoc $2)) $4 }
-----------------------------------------------------------------------------
-- Statement sequences
| vocurly stmts close { $2 }
-- do { ;; s ; s ; ; s ;; }
--- The last Stmt should be a ResultStmt, but that's hard to enforce
+-- The last Stmt should be an expression, but that's hard to enforce
-- here, because we need too much lookahead if we see do { e ; }
-- So we use ExprStmts throughout, and switch the last one over
-- in ParseUtils.checkDo instead
stmt :: { LStmt RdrName }
: qual { $1 }
| infixexp '->' exp {% checkPattern $3 >>= \p ->
- return (LL $ BindStmt p $1) }
- | 'rec' stmtlist { LL $ RecStmt (unLoc $2) undefined undefined undefined }
+ return (LL $ mkBindStmt p $1) }
+ | 'rec' stmtlist { LL $ mkRecStmt (unLoc $2) }
qual :: { LStmt RdrName }
: infixexp '<-' exp {% checkPattern $1 >>= \p ->
- return (LL $ BindStmt p $3) }
- | exp { L1 $ ExprStmt $1 placeHolderType }
+ return (LL $ mkBindStmt p $3) }
+ | exp { L1 $ mkExprStmt $1 }
| 'let' binds { LL $ LetStmt (unLoc $2) }
-----------------------------------------------------------------------------
where f (HsLit (HsIntPrim i)) = HsLit (HsIntPrim (-i))
f (HsLit (HsFloatPrim i)) = HsLit (HsFloatPrim (-i))
f (HsLit (HsDoublePrim i)) = HsLit (HsDoublePrim (-i))
- f expr = NegApp (L loc e) placeHolderName
+ f expr = NegApp (L loc e) noSyntaxExpr
\end{code}
%************************************************************************
-- We parse do { e1 ; e2 ; }
-- as [ExprStmt e1, ExprStmt e2]
-- checkDo (a) checks that the last thing is an ExprStmt
--- (b) transforms it to a ResultStmt
+-- (b) returns it separately
-- same comments apply for mdo as well
checkDo = checkDoMDo "a " "'do'"
checkMDo = checkDoMDo "an " "'mdo'"
-checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P [LStmt RdrName]
+checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
checkDoMDo pre nm loc [] = parseError loc ("Empty " ++ nm ++ " construct")
checkDoMDo pre nm loc ss = do
check ss
where
- check [L l (ExprStmt e _)] = return [L l (ResultStmt e)]
+ check [L l (ExprStmt e _ _)] = return ([], e)
check [L l _] = parseError l ("The last statement in " ++ pre ++ nm ++
" construct must be an expression")
check (s:ss) = do
- ss' <- check ss
- return (s:ss')
+ (ss',e') <- check ss
+ return ((s:ss'),e')
-- -------------------------------------------------------------------------
-- Checking Patterns.
-- Negation is recorded separately, so that the literal is zero or +ve
-- NB. Negative *primitive* literals are already handled by
-- RdrHsSyn.mkHsNegApp
- HsOverLit pos_lit -> return (NPatIn pos_lit Nothing)
+ HsOverLit pos_lit -> return (mkNPat pos_lit Nothing)
NegApp (L _ (HsOverLit pos_lit)) _
- -> return (NPatIn pos_lit (Just placeHolderName))
+ -> return (mkNPat pos_lit (Just noSyntaxExpr))
ELazyPat e -> checkLPat e >>= (return . LazyPat)
EAsPat n e -> checkLPat e >>= (return . AsPat n)
ExplicitTuple es b -> mapM (\e -> checkLPat e) es >>= \ps ->
return (TuplePat ps b)
- RecordCon c fs -> mapM checkPatField fs >>= \fs ->
+ RecordCon c _ fs -> mapM checkPatField fs >>= \fs ->
return (ConPatIn c (RecCon fs))
-- Generics
HsType ty -> return (TypePat ty)
-> P (HsExpr RdrName)
mkRecConstrOrUpdate (L l (HsVar c)) loc fs | isRdrDataCon c
- = return (RecordCon (L l c) fs)
+ = return (RecordCon (L l c) noPostTcExpr fs)
mkRecConstrOrUpdate exp loc fs@(_:_)
- = return (RecordUpd exp fs)
+ = return (RecordUpd exp fs placeHolderType placeHolderType)
mkRecConstrOrUpdate _ loc []
= parseError loc "Empty record update"
basicKnownKeyNames :: [Name]
basicKnownKeyNames
= genericTyConNames
- ++ monadNames
++ typeableClassNames
++ [ -- Type constructors (synonyms especially)
ioTyConName, ioDataConName,
-- Monad stuff
thenIOName, bindIOName, returnIOName, failIOName,
+ failMName, bindMName, thenMName, returnMName,
-- MonadRec stuff
mfixName,
, marshalStringName, unmarshalStringName, checkDotnetResName
]
-monadNames :: [Name] -- The monad ops need by a HsDo
-monadNames = [returnMName, failMName, bindMName, thenMName]
-
genericTyConNames :: [Name]
genericTyConNames = [crossTyConName, plusTyConName, genUnitTyConName]
\end{code}
range_RDR = varQual_RDR pREL_ARR FSLIT("range")
inRange_RDR = varQual_RDR pREL_ARR FSLIT("inRange")
index_RDR = varQual_RDR pREL_ARR FSLIT("index")
+unsafeIndex_RDR = varQual_RDR pREL_ARR FSLIT("unsafeIndex")
+unsafeRangeSize_RDR = varQual_RDR pREL_ARR FSLIT("unsafeRangeSize")
readList_RDR = varQual_RDR pREL_READ FSLIT("readList")
readListDefault_RDR = varQual_RDR pREL_READ FSLIT("readListDefault")
eqStringName = varQual pREL_BASE FSLIT("eqString") eqStringIdKey
-- Base classes (Eq, Ord, Functor)
-eqClassName = clsQual pREL_BASE FSLIT("Eq") eqClassKey
-eqName = methName eqClassName FSLIT("==") eqClassOpKey
-ordClassName = clsQual pREL_BASE FSLIT("Ord") ordClassKey
-geName = methName ordClassName FSLIT(">=") geClassOpKey
+eqClassName = clsQual pREL_BASE FSLIT("Eq") eqClassKey
+eqName = methName eqClassName FSLIT("==") eqClassOpKey
+ordClassName = clsQual pREL_BASE FSLIT("Ord") ordClassKey
+geName = methName ordClassName FSLIT(">=") geClassOpKey
functorClassName = clsQual pREL_BASE FSLIT("Functor") functorClassKey
-- Class Monad
-monadClassName = clsQual pREL_BASE FSLIT("Monad") monadClassKey
-thenMName = methName monadClassName FSLIT(">>") thenMClassOpKey
-bindMName = methName monadClassName FSLIT(">>=") bindMClassOpKey
+monadClassName = clsQual pREL_BASE FSLIT("Monad") monadClassKey
+thenMName = methName monadClassName FSLIT(">>") thenMClassOpKey
+bindMName = methName monadClassName FSLIT(">>=") bindMClassOpKey
returnMName = methName monadClassName FSLIT("return") returnMClassOpKey
-failMName = methName monadClassName FSLIT("fail") failMClassOpKey
+failMName = methName monadClassName FSLIT("fail") failMClassOpKey
-- Random PrelBase functions
otherwiseIdName = varQual pREL_BASE FSLIT("otherwise") otherwiseIdKey
buildName = varQual pREL_BASE FSLIT("build") buildIdKey
augmentName = varQual pREL_BASE FSLIT("augment") augmentIdKey
appendName = varQual pREL_BASE FSLIT("++") appendIdKey
-andName = varQual pREL_BASE FSLIT("&&") andIdKey
-orName = varQual pREL_BASE FSLIT("||") orIdKey
+andName = varQual pREL_BASE FSLIT("&&") andIdKey
+orName = varQual pREL_BASE FSLIT("||") orIdKey
assertName = varQual pREL_BASE FSLIT("assert") assertIdKey
-- PrelTup
lookupTopFixSigNames, lookupSrcOcc_maybe,
lookupFixityRn, lookupLocatedSigOccRn,
lookupLocatedInstDeclBndr,
- lookupSyntaxName, lookupSyntaxNames, lookupImportedName,
+ lookupSyntaxName, lookupSyntaxTable, lookupImportedName,
newLocalsRn, newIPNameRn,
bindLocalNames, bindLocalNamesFV,
import LoadIface ( loadHomeInterface, loadSrcInterface )
import IfaceEnv ( lookupOrig, newGlobalBinder, newIPName )
-import HsSyn ( FixitySig(..), ReboundNames, HsExpr(..),
+import HsSyn ( FixitySig(..), HsExpr(..), SyntaxExpr, SyntaxTable,
HsType(..), HsExplicitForAll(..), LHsTyVarBndr, LHsType,
LSig, Sig(..), Fixity, hsLTyVarName, hsLTyVarLocNames, replaceTyVarName )
import RdrHsSyn ( extractHsTyRdrTyVars )
We store the relevant Name in the HsSyn tree, in
* HsIntegral/HsFractional
* NegApp
- * NPlusKPatIn
+ * NPlusKPat
* HsDo
respectively. Initially, we just store the "standard" name (PrelNames.fromIntegralName,
fromRationalName etc), but the renamer changes this to the appropriate user
checks the type of the user thing against the type of the standard thing.
\begin{code}
-lookupSyntaxName :: Name -- The standard name
- -> RnM (Name, FreeVars) -- Possibly a non-standard name
+lookupSyntaxName :: Name -- The standard name
+ -> RnM (SyntaxExpr Name, FreeVars) -- Possibly a non-standard name
lookupSyntaxName std_name
= doptM Opt_ImplicitPrelude `thenM` \ implicit_prelude ->
if implicit_prelude then normal_case
else
-- Get the similarly named thing from the local environment
lookupOccRn (mkRdrUnqual (nameOccName std_name)) `thenM` \ usr_name ->
- returnM (usr_name, unitFV usr_name)
+ returnM (HsVar usr_name, unitFV usr_name)
where
- normal_case = returnM (std_name, emptyFVs)
+ normal_case = returnM (HsVar std_name, emptyFVs)
-lookupSyntaxNames :: [Name] -- Standard names
- -> RnM (ReboundNames Name, FreeVars) -- See comments with HsExpr.ReboundNames
-lookupSyntaxNames std_names
+lookupSyntaxTable :: [Name] -- Standard names
+ -> RnM (SyntaxTable Name, FreeVars) -- See comments with HsExpr.ReboundNames
+lookupSyntaxTable std_names
= doptM Opt_ImplicitPrelude `thenM` \ implicit_prelude ->
if implicit_prelude then normal_case
else
\begin{code}
module RnExpr (
- rnMatchGroup, rnMatch, rnGRHSs, rnLExpr, rnExpr, rnStmts,
+ rnMatchGroup, rnMatch, rnGRHSs, rnLExpr, rnExpr,
checkPrecMatch, checkTH
) where
import BasicTypes ( Fixity(..), FixityDirection(..), negateFixity, compareFixity )
import PrelNames ( hasKey, assertIdKey, assertErrorName,
loopAName, choiceAName, appAName, arrAName, composeAName, firstAName,
- negateName, monadNames, mfixName )
+ negateName, thenMName, bindMName, failMName )
import Name ( Name, nameOccName )
import NameSet
import RdrName ( RdrName )
rnGRHS :: HsMatchContext Name -> LGRHS RdrName -> RnM (LGRHS Name, FreeVars)
rnGRHS ctxt = wrapLocFstM (rnGRHS' ctxt)
-rnGRHS' ctxt (GRHS guarded)
- = doptM Opt_GlasgowExts `thenM` \ opt_GlasgowExts ->
- checkM (opt_GlasgowExts || is_standard_guard guarded)
- (addWarn (nonStdGuardErr guarded)) `thenM_`
+rnGRHS' ctxt (GRHS guards rhs)
+ = do { opt_GlasgowExts <- doptM Opt_GlasgowExts
+ ; checkM (opt_GlasgowExts || is_standard_guard guards)
+ (addWarn (nonStdGuardErr guards))
- rnStmts (PatGuard ctxt) guarded `thenM` \ (guarded', fvs) ->
- returnM (GRHS guarded', fvs)
+ ; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) guards $
+ rnLExpr rhs
+ ; return (GRHS guards' rhs', fvs) }
where
-- Standard Haskell 1.4 guards are just a single boolean
-- expression, rather than a list of qualifiers as in the
-- Glasgow extension
- is_standard_guard [L _ (ResultStmt _)] = True
- is_standard_guard [L _ (ExprStmt _ _), L _ (ResultStmt _)] = True
- is_standard_guard other = False
+ is_standard_guard [] = True
+ is_standard_guard [L _ (ExprStmt _ _ _)] = True
+ is_standard_guard other = False
\end{code}
%************************************************************************
rnLExpr expr `thenM` \ (expr',fvExpr) ->
returnM (HsLet binds' expr', fvExpr)
-rnExpr e@(HsDo do_or_lc stmts _ _)
- = rnStmts do_or_lc stmts `thenM` \ (stmts', fvs) ->
-
- -- Check the statement list ends in an expression
- case last stmts' of {
- L _ (ResultStmt _) -> returnM () ;
- other -> addLocErr other (doStmtListErr do_or_lc)
- } `thenM_`
-
- -- Generate the rebindable syntax for the monad
- lookupSyntaxNames syntax_names `thenM` \ (syntax_names', monad_fvs) ->
-
- returnM (HsDo do_or_lc stmts' syntax_names' placeHolderType, fvs `plusFV` monad_fvs)
- where
- syntax_names = case do_or_lc of
- DoExpr -> monadNames
- MDoExpr -> monadNames ++ [mfixName]
- other -> []
+rnExpr e@(HsDo do_or_lc stmts body _)
+ = do { ((stmts', body'), fvs) <- rnStmts do_or_lc stmts $
+ rnLExpr body
+ ; return (HsDo do_or_lc stmts' body' placeHolderType, fvs) }
rnExpr (ExplicitList _ exps)
= rnExprs exps `thenM` \ (exps', fvs) ->
tup_size = length exps
tycon_name = tupleTyCon_name boxity tup_size
-rnExpr (RecordCon con_id rbinds)
+rnExpr (RecordCon con_id _ rbinds)
= lookupLocatedOccRn con_id `thenM` \ conname ->
rnRbinds "construction" rbinds `thenM` \ (rbinds', fvRbinds) ->
- returnM (RecordCon conname rbinds', fvRbinds `addOneFV` unLoc conname)
+ returnM (RecordCon conname noPostTcExpr rbinds',
+ fvRbinds `addOneFV` unLoc conname)
-rnExpr (RecordUpd expr rbinds)
+rnExpr (RecordUpd expr rbinds _ _)
= rnLExpr expr `thenM` \ (expr', fvExpr) ->
rnRbinds "update" rbinds `thenM` \ (rbinds', fvRbinds) ->
- returnM (RecordUpd expr' rbinds', fvExpr `plusFV` fvRbinds)
+ returnM (RecordUpd expr' rbinds' placeHolderType placeHolderType,
+ fvExpr `plusFV` fvRbinds)
rnExpr (ExprWithTySig expr pty)
= rnLExpr expr `thenM` \ (expr', fvExpr) ->
where
doc = text "In a type argument"
-rnExpr (ArithSeqIn seq)
+rnExpr (ArithSeq _ seq)
= rnArithSeq seq `thenM` \ (new_seq, fvs) ->
- returnM (ArithSeqIn new_seq, fvs)
+ returnM (ArithSeq noPostTcExpr new_seq, fvs)
-rnExpr (PArrSeqIn seq)
+rnExpr (PArrSeq _ seq)
= rnArithSeq seq `thenM` \ (new_seq, fvs) ->
- returnM (PArrSeqIn new_seq, fvs)
+ returnM (PArrSeq noPostTcExpr new_seq, fvs)
\end{code}
These three are pattern syntax appearing in expressions.
rnCmdArgs cmds `thenM` \ (cmds',fvCmds) ->
returnM (HsArrForm op' fixity cmds', fvOp `plusFV` fvCmds)
+rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)
+ -- DictApp, DictLam, TyApp, TyLam
+
---------------------------
-- Deal with fixity (cf mkOpAppRn for the method)
nameSetToList (methodNamesCmd (unLoc cmd'))
in
-- Generate the rebindable syntax for the monad
- lookupSyntaxNames cmd_names `thenM` \ (cmd_names', cmd_fvs) ->
+ lookupSyntaxTable cmd_names `thenM` \ (cmd_names', cmd_fvs) ->
returnM (HsCmdTop cmd' [] placeHolderType cmd_names',
fvCmd `plusFV` cmd_fvs)
convertOpFormsCmd (HsLet binds cmd)
= HsLet binds (convertOpFormsLCmd cmd)
-convertOpFormsCmd (HsDo ctxt stmts ids ty)
- = HsDo ctxt (map (fmap convertOpFormsStmt) stmts) ids ty
+convertOpFormsCmd (HsDo ctxt stmts body ty)
+ = HsDo ctxt (map (fmap convertOpFormsStmt) stmts)
+ (convertOpFormsLCmd body) ty
-- Anything else is unchanged. This includes HsArrForm (already done),
-- things with no sub-commands, and illegal commands (which will be
-- caught by the type checker)
convertOpFormsCmd c = c
-convertOpFormsStmt (BindStmt pat cmd)
- = BindStmt pat (convertOpFormsLCmd cmd)
-convertOpFormsStmt (ResultStmt cmd)
- = ResultStmt (convertOpFormsLCmd cmd)
-convertOpFormsStmt (ExprStmt cmd ty)
- = ExprStmt (convertOpFormsLCmd cmd) ty
-convertOpFormsStmt (RecStmt stmts lvs rvs es)
- = RecStmt (map (fmap convertOpFormsStmt) stmts) lvs rvs es
+convertOpFormsStmt (BindStmt pat cmd _ _)
+ = BindStmt pat (convertOpFormsLCmd cmd) noSyntaxExpr noSyntaxExpr
+convertOpFormsStmt (ExprStmt cmd _ _)
+ = ExprStmt (convertOpFormsLCmd cmd) noSyntaxExpr placeHolderType
+convertOpFormsStmt (RecStmt stmts lvs rvs es binds)
+ = RecStmt (map (fmap convertOpFormsStmt) stmts) lvs rvs es binds
convertOpFormsStmt stmt = stmt
convertOpFormsMatch (MatchGroup ms ty)
= GRHSs (map convertOpFormsGRHS grhss) binds
convertOpFormsGRHS = fmap convert
- where convert (GRHS stmts)
- = let
- (L loc (ResultStmt cmd)) = last stmts
- in
- GRHS (init stmts ++ [L loc (ResultStmt (convertOpFormsLCmd cmd))])
+ where
+ convert (GRHS stmts cmd) = GRHS stmts (convertOpFormsLCmd cmd)
---------------------------------------------------
type CmdNeeds = FreeVars -- Only inhabitants are
methodNamesCmd (HsLet b c) = methodNamesLCmd c
-methodNamesCmd (HsDo sc stmts rbs ty) = methodNamesStmts stmts
+methodNamesCmd (HsDo sc stmts body ty)
+ = methodNamesStmts stmts `plusFV` methodNamesLCmd body
methodNamesCmd (HsApp c e) = methodNamesLCmd c
methodNamesGRHSs (GRHSs grhss binds) = plusFVs (map methodNamesGRHS grhss)
-------------------------------------------------
-methodNamesGRHS (L _ (GRHS stmts)) = methodNamesLStmt (last stmts)
+methodNamesGRHS (L _ (GRHS stmts rhs)) = methodNamesLCmd rhs
---------------------------------------------------
methodNamesStmts stmts = plusFVs (map methodNamesLStmt stmts)
---------------------------------------------------
methodNamesLStmt = methodNamesStmt . unLoc
-methodNamesStmt (ResultStmt cmd) = methodNamesLCmd cmd
-methodNamesStmt (ExprStmt cmd ty) = methodNamesLCmd cmd
-methodNamesStmt (BindStmt pat cmd ) = methodNamesLCmd cmd
-methodNamesStmt (RecStmt stmts lvs rvs es)
+methodNamesStmt (ExprStmt cmd _ _) = methodNamesLCmd cmd
+methodNamesStmt (BindStmt pat cmd _ _) = methodNamesLCmd cmd
+methodNamesStmt (RecStmt stmts _ _ _ _)
= methodNamesStmts stmts `addOneFV` loopAName
methodNamesStmt (LetStmt b) = emptyFVs
methodNamesStmt (ParStmt ss) = emptyFVs
%************************************************************************
\begin{code}
-rnStmts :: HsStmtContext Name -> [LStmt RdrName] -> RnM ([LStmt Name], FreeVars)
+rnStmts :: HsStmtContext Name -> [LStmt RdrName]
+ -> RnM (thing, FreeVars)
+ -> RnM (([LStmt Name], thing), FreeVars)
-rnStmts MDoExpr = rnMDoStmts
-rnStmts ctxt = rnNormalStmts ctxt
+rnStmts (MDoExpr _) = rnMDoStmts
+rnStmts ctxt = rnNormalStmts ctxt
-rnNormalStmts :: HsStmtContext Name -> [LStmt RdrName] -> RnM ([LStmt Name], FreeVars)
+rnNormalStmts :: HsStmtContext Name -> [LStmt RdrName]
+ -> RnM (thing, FreeVars)
+ -> RnM (([LStmt Name], thing), 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 (L loc (ExprStmt expr _) : stmts)
- = rnLExpr expr `thenM` \ (expr', fv_expr) ->
- rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) ->
- returnM (L loc (ExprStmt expr' placeHolderType) : stmts',
- fv_expr `plusFV` fvs)
+rnNormalStmts ctxt [] thing_inside
+ = do { (thing, fvs) <- thing_inside
+ ; return (([],thing), fvs) }
-rnNormalStmts ctxt [L loc (ResultStmt expr)]
- = rnLExpr expr `thenM` \ (expr', fv_expr) ->
- returnM ([L loc (ResultStmt expr')], fv_expr)
-
-rnNormalStmts ctxt (L loc (BindStmt pat expr) : stmts)
- = rnLExpr expr `thenM` \ (expr', fv_expr) ->
- -- The binders do not scope over the expression
-
- let
- reportUnused =
- case ctxt of
- ParStmtCtxt{} -> False
- _ -> True
- in
- rnPatsAndThen (StmtCtxt ctxt) reportUnused [pat] $ \ [pat'] ->
- rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) ->
- returnM (L loc (BindStmt pat' expr') : stmts',
- fv_expr `plusFV` fvs) -- fv_expr shouldn't really be filtered by
- -- the rnPatsAndThen, but it does not matter
-
-rnNormalStmts ctxt (L loc (LetStmt binds) : stmts)
- = checkErr (ok ctxt binds) (badIpBinds binds) `thenM_`
- rnBindGroupsAndThen binds ( \ binds' ->
- rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) ->
- returnM (L loc (LetStmt binds') : stmts', fvs))
+rnNormalStmts ctxt (L loc stmt : stmts) thing_inside
+ = do { ((stmt', (stmts', thing)), fvs)
+ <- rnStmt ctxt stmt $
+ rnNormalStmts ctxt stmts thing_inside
+ ; return (((L loc stmt' : stmts'), thing), fvs) }
+
+rnStmt :: HsStmtContext Name -> Stmt RdrName
+ -> RnM (thing, FreeVars)
+ -> RnM ((Stmt Name, thing), FreeVars)
+
+rnStmt ctxt (ExprStmt expr _ _) thing_inside
+ = do { (expr', fv_expr) <- rnLExpr expr
+ ; (then_op, fvs1) <- lookupSyntaxName thenMName
+ ; (thing, fvs2) <- thing_inside
+ ; return ((ExprStmt expr' then_op placeHolderType, thing),
+ fv_expr `plusFV` fvs1 `plusFV` fvs2) }
+
+rnStmt ctxt (BindStmt pat expr _ _) thing_inside
+ = do { (expr', fv_expr) <- rnLExpr expr
+ -- The binders do not scope over the expression
+ ; (bind_op, fvs1) <- lookupSyntaxName bindMName
+ ; (fail_op, fvs2) <- lookupSyntaxName failMName
+
+ ; let reportUnused = case ctxt of
+ ParStmtCtxt{} -> False
+ _ -> True
+ ; rnPatsAndThen (StmtCtxt ctxt) reportUnused [pat] $ \ [pat'] -> do
+ { (thing, fvs3) <- thing_inside
+ ; return ((BindStmt pat' expr' bind_op fail_op, thing),
+ fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
+ -- fv_expr shouldn't really be filtered by
+ -- the rnPatsAndThen, but it does not matter
+
+rnStmt ctxt (LetStmt binds) thing_inside
+ = do { checkErr (ok ctxt binds) (badIpBinds binds)
+ ; rnBindGroupsAndThen binds $ \ binds' -> do
+ { (thing, fvs) <- thing_inside
+ ; return ((LetStmt binds', thing), fvs) }}
where
-- We do not allow implicit-parameter bindings in a parallel
-- list comprehension. I'm not sure what it might mean.
is_ip_bind (HsIPBinds _) = True
is_ip_bind _ = False
-rnNormalStmts ctxt (L loc (ParStmt stmtss) : stmts)
- = doptM Opt_GlasgowExts `thenM` \ opt_GlasgowExts ->
- checkM opt_GlasgowExts parStmtErr `thenM_`
- mapFvRn rn_branch stmtss `thenM` \ (stmtss', fv_stmtss) ->
- let
- bndrss :: [[Name]] -- NB: Name, not RdrName
- bndrss = map (map unLoc . collectStmtsBinders) stmtss'
- (bndrs, dups) = removeDups cmpByOcc (concat bndrss)
- in
- mappM dupErr dups `thenM` \ _ ->
- bindLocalNamesFV bndrs $
+rnStmt ctxt (ParStmt stmtss) thing_inside
+ = do { opt_GlasgowExts <- doptM Opt_GlasgowExts
+ ; checkM opt_GlasgowExts parStmtErr
+ ; (stmtss'_w_unit, fv_stmtss) <- mapFvRn rn_branch stmtss
+ ; let
+ bndrss :: [[Name]] -- NB: Name, not RdrName
+ bndrss = map (map unLoc . collectLStmtsBinders) stmtss'
+ (bndrs, dups) = removeDups cmpByOcc (concat bndrss)
+ stmtss' = map fst stmtss'_w_unit
+ ; mappM dupErr dups
+
+ ; bindLocalNamesFV bndrs $ do
+ { (thing, fvs) <- thing_inside
-- 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) ->
-- Cut down the exported binders to just the ones needed in the body
- let
- used_bndrs_s = map (filter (`elemNameSet` fvs)) bndrss
- unused_bndrs = filter (not . (`elemNameSet` fvs)) bndrs
- in
+ ; let used_bndrs_s = map (filter (`elemNameSet` fvs)) bndrss
+ unused_bndrs = filter (not . (`elemNameSet` fvs)) bndrs
+
-- With processing of the branches and the tail of comprehension done,
-- we can finally compute&report any unused ParStmt binders.
- warnUnusedMatches unused_bndrs `thenM_`
- returnM (L loc (ParStmt (stmtss' `zip` used_bndrs_s)) : stmts',
- fv_stmtss `plusFV` fvs)
+ ; warnUnusedMatches unused_bndrs
+ ; return ((ParStmt (stmtss' `zip` used_bndrs_s), thing),
+ fv_stmtss `plusFV` fvs) }}
where
- rn_branch (stmts, _) = rnNormalStmts (ParStmtCtxt ctxt) stmts
+ rn_branch (stmts, _) = rnNormalStmts (ParStmtCtxt ctxt) stmts $
+ return ((), emptyFVs)
cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2
dupErr (v:_) = addErr (ptext SLIT("Duplicate binding in parallel list comprehension for:")
<+> quotes (ppr v))
-rnNormalStmts ctxt (L loc (RecStmt rec_stmts _ _ _) : stmts)
- = bindLocatedLocalsRn doc (collectStmtsBinders rec_stmts) $ \ _ ->
- rn_rec_stmts rec_stmts `thenM` \ segs ->
- rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) ->
+rnStmt ctxt (RecStmt rec_stmts _ _ _ _) thing_inside
+ = bindLocatedLocalsRn doc (collectLStmtsBinders rec_stmts) $ \ _ ->
+ rn_rec_stmts rec_stmts `thenM` \ segs ->
+ thing_inside `thenM` \ (thing, fvs) ->
let
segs_w_fwd_refs = addFwdRefs segs
(ds, us, fs, rec_stmts') = unzip4 segs_w_fwd_refs
later_vars = nameSetToList (plusFVs ds `intersectNameSet` fvs)
fwd_vars = nameSetToList (plusFVs fs)
uses = plusFVs us
+ rec_stmt = RecStmt rec_stmts' later_vars fwd_vars [] emptyLHsBinds
in
- returnM (L loc (RecStmt rec_stmts' later_vars fwd_vars []) : stmts',
- uses `plusFV` fvs)
+ returnM ((rec_stmt, thing), uses `plusFV` fvs)
where
doc = text "In a recursive do statement"
\end{code}
----------------------------------------------------
-rnMDoStmts :: [LStmt RdrName] -> RnM ([LStmt Name], FreeVars)
-rnMDoStmts stmts
+rnMDoStmts :: [LStmt RdrName]
+ -> RnM (thing, FreeVars)
+ -> RnM (([LStmt Name], thing), FreeVars)
+rnMDoStmts stmts thing_inside
= -- Step1: bring all the binders of the mdo into scope
-- Remember that this also removes the binders from the
-- finally-returned free-vars
- bindLocatedLocalsRn doc (collectStmtsBinders stmts) $ \ _ ->
-
+ bindLocatedLocalsRn doc (collectLStmtsBinders stmts) $ \ _ ->
+ do {
-- 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
-- (This set may not be empty, because we're in a recursive
-- context.)
- rn_rec_stmts stmts `thenM` \ segs ->
- let
+ segs <- rn_rec_stmts stmts
+
+ ; (thing, fvs_later) <- thing_inside
+
+ ; 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
+ 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
+ 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
+ (stmts', fvs) = segsToStmts grouped_segs fvs_later
+ ; return ((stmts', thing), fvs) }
+ where
doc = text "In a recursive mdo-expression"
-- Assumes all binders are already in scope
-- Turns each stmt into a singleton Stmt
-rn_rec_stmt (L loc (ExprStmt expr _))
+rn_rec_stmt (L loc (ExprStmt expr _ _))
= rnLExpr expr `thenM` \ (expr', fvs) ->
- returnM [(emptyNameSet, fvs, emptyNameSet,
- L loc (ExprStmt expr' placeHolderType))]
-
-rn_rec_stmt (L loc (ResultStmt expr))
- = rnLExpr expr `thenM` \ (expr', fvs) ->
- returnM [(emptyNameSet, fvs, emptyNameSet,
- L loc (ResultStmt expr'))]
+ lookupSyntaxName thenMName `thenM` \ (then_op, fvs1) ->
+ returnM [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet,
+ L loc (ExprStmt expr' then_op placeHolderType))]
-rn_rec_stmt (L loc (BindStmt pat expr))
+rn_rec_stmt (L loc (BindStmt pat expr _ _))
= rnLExpr expr `thenM` \ (expr', fv_expr) ->
- rnLPat pat `thenM` \ (pat', fv_pat) ->
+ rnLPat pat `thenM` \ (pat', fv_pat) ->
+ lookupSyntaxName bindMName `thenM` \ (bind_op, fvs1) ->
+ lookupSyntaxName failMName `thenM` \ (fail_op, fvs2) ->
let
bndrs = mkNameSet (collectPatBinders pat')
- fvs = fv_expr `plusFV` fv_pat
+ fvs = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2
in
returnM [(bndrs, fvs, bndrs `intersectNameSet` fvs,
- L loc (BindStmt pat' expr'))]
+ L loc (BindStmt pat' expr' bind_op fail_op))]
rn_rec_stmt (L loc (LetStmt binds))
= rnBindGroups binds `thenM` \ (binds', du_binds) ->
returnM [(duDefs du_binds, duUses du_binds,
emptyNameSet, L loc (LetStmt binds'))]
-rn_rec_stmt (L loc (RecStmt stmts _ _ _)) -- Flatten Rec inside Rec
+rn_rec_stmt (L loc (RecStmt stmts _ _ _ _)) -- Flatten Rec inside Rec
= rn_rec_stmts stmts
rn_rec_stmt stmt@(L _ (ParStmt _)) -- Syntactically illegal in mdo
----------------------------------------------------
-segsToStmts :: [Segment [LStmt Name]] -> ([LStmt Name], FreeVars)
+segsToStmts :: [Segment [LStmt Name]]
+ -> FreeVars -- Free vars used 'later'
+ -> ([LStmt Name], FreeVars)
-segsToStmts [] = ([], emptyFVs)
-segsToStmts ((defs, uses, fwds, ss) : segs)
+segsToStmts [] fvs_later = ([], fvs_later)
+segsToStmts ((defs, uses, fwds, ss) : segs) fvs_later
= ASSERT( not (null ss) )
(new_stmt : later_stmts, later_uses `plusFV` uses)
where
- (later_stmts, later_uses) = segsToStmts segs
+ (later_stmts, later_uses) = segsToStmts segs fvs_later
new_stmt | non_rec = head ss
| otherwise = L (getLoc (head ss)) $
- RecStmt ss (nameSetToList used_later) (nameSetToList fwds) []
+ RecStmt ss (nameSetToList used_later) (nameSetToList fwds)
+ [] emptyLHsBinds
where
non_rec = isSingleton ss && isEmptyNameSet fwds
used_later = defs `intersectNameSet` later_uses
-- Parser initially makes negation bind more tightly than any other operator
-- And "deriving" code should respect this (use HsPar if not)
-mkNegAppRn :: LHsExpr id -> SyntaxName -> RnM (HsExpr id)
+mkNegAppRn :: LHsExpr id -> SyntaxExpr id -> RnM (HsExpr id)
mkNegAppRn neg_arg neg_name
= ASSERT( not_op_app (unLoc neg_arg) )
returnM (NegApp neg_arg neg_name)
= sep [ptext SLIT("Pattern syntax in expression context:"),
nest 4 (ppr e)]
-doStmtListErr do_or_lc e
- = sep [quotes (text binder_name) <+> ptext SLIT("statements must end in expression:"),
- nest 4 (ppr e)]
- where
- binder_name = case do_or_lc of
- MDoExpr -> "mdo"
- other -> "do"
-
#ifdef GHCI
checkTH e what = returnM () -- OK
#else
newIPNameRn, bindPatSigTyVarsFV, bindLocatedLocalsFV )
import TcRnMonad
import RdrName ( RdrName, elemLocalRdrEnv )
-import PrelNames ( eqClassName, integralClassName,
+import PrelNames ( eqClassName, integralClassName, geName, eqName,
negateName, minusName, lengthPName, indexPName,
plusIntegerName, fromIntegerName, timesIntegerName,
ratioDataConName, fromRationalName )
= rnLit lit `thenM_`
returnM (LitPat lit, emptyFVs)
-rnPat (NPatIn lit mb_neg)
+rnPat (NPat lit mb_neg eq _)
= 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)
+ lookupSyntaxName eqName `thenM` \ (eq', fvs3) ->
+ returnM (NPat lit' mb_neg' eq' placeHolderType,
+ fvs1 `plusFV` fvs2 `plusFV` fvs3 `addOneFV` eqClassName)
-- Needed to find equality on pattern
-rnPat (NPlusKPatIn name lit _)
+rnPat (NPlusKPat name lit _ _)
= rnOverLit lit `thenM` \ (lit', fvs1) ->
lookupLocatedBndrRn name `thenM` \ name' ->
lookupSyntaxName minusName `thenM` \ (minus, fvs2) ->
- returnM (NPlusKPatIn name' lit' minus,
- fvs1 `plusFV` fvs2 `addOneFV` integralClassName)
+ lookupSyntaxName geName `thenM` \ (ge, fvs3) ->
+ returnM (NPlusKPat name' lit' ge minus,
+ fvs1 `plusFV` fvs2 `plusFV` fvs3 `addOneFV` integralClassName)
-- The Report says that n+k patterns must be in Integral
rnPat (LazyPat pat)
tidyInsts, tidyMoreInsts,
newDicts, newDictAtLoc, newDictsAtLoc, cloneDict,
- newOverloadedLit, newIPDict,
+ tcOverloadedLit, newIPDict,
newMethod, newMethodFromName, newMethodWithGivenTy,
tcInstClassOp, tcInstCall, tcInstStupidTheta,
- tcSyntaxName, tcStdSyntaxName,
+ tcSyntaxName,
tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE,
ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts,
#include "HsVersions.h"
-import {-# SOURCE #-} TcExpr( tcCheckSigma )
+import {-# SOURCE #-} TcExpr( tcCheckSigma, tcSyntaxOp )
import {-# SOURCE #-} TcUnify ( unifyTauTy ) -- Used in checkKind (sigh)
-import HsSyn ( HsLit(..), HsOverLit(..), HsExpr(..), LHsExpr, mkHsApp )
+import HsSyn ( HsLit(..), HsOverLit(..), HsExpr(..), LHsExpr, mkHsApp,
+ nlHsLit, nlHsVar )
import TcHsSyn ( TcId, TcIdSet,
- mkHsTyApp, mkHsDictApp, mkHsConApp, zonkId,
+ mkHsTyApp, mkHsDictApp, zonkId,
mkCoercion, ExprCoFn
)
import TcRnMonad
tcInstTyVar, tcInstType, tcSkolType
)
import TcType ( Type, TcType, TcThetaType, TcTyVarSet, TcTyVar, TcPredType,
- PredType(..), SkolemInfo(..), typeKind, mkSigmaTy,
- tcSplitForAllTys, tcSplitForAllTys,
+ PredType(..), SkolemInfo(..), Expected(..), typeKind, mkSigmaTy,
+ tcSplitForAllTys, tcSplitForAllTys, mkFunTy,
tcSplitPhiTy, tcIsTyVarTy, tcSplitDFunTy, tcSplitDFunHead,
isIntTy,isFloatTy, isIntegerTy, isDoubleTy,
tcIsTyVarTy, mkPredTy, mkTyVarTy, mkTyVarTys,
import Packages ( isHomeModule )
import HscTypes ( ExternalPackageState(..) )
import CoreFVs ( idFreeTyVars )
-import DataCon ( DataCon, dataConTyVars, dataConStupidTheta, dataConName )
+import DataCon ( DataCon, dataConTyVars, dataConStupidTheta, dataConName, dataConWrapId )
import Id ( Id, idName, idType, mkUserLocal, mkLocalId )
import PrelInfo ( isStandardClass, isNoDictClass )
import Name ( Name, mkMethodOcc, getOccName, getSrcLoc, nameModule,
returnM inst
\end{code}
-In newOverloadedLit we convert directly to an Int or Integer if we
+In tcOverloadedLit we convert directly to an Int or Integer if we
know that's what we want. This may save some time, by not
temporarily generating overloaded literals, but it won't catch all
cases (the rest are caught in lookupInst).
\begin{code}
-newOverloadedLit :: InstOrigin
- -> HsOverLit
+tcOverloadedLit :: InstOrigin
+ -> HsOverLit Name
-> TcType
- -> TcM (LHsExpr TcId)
-newOverloadedLit orig lit@(HsIntegral i fi) expected_ty
- | fi /= fromIntegerName -- Do not generate a LitInst for rebindable syntax.
- -- Reason: tcSyntaxName does unification
- -- which is very inconvenient in tcSimplify
- -- ToDo: noLoc sadness
- = tcSyntaxName orig expected_ty (fromIntegerName, HsVar fi) `thenM` \ (_,expr) ->
- mkIntegerLit i `thenM` \ integer_lit ->
- returnM (mkHsApp (noLoc expr) integer_lit)
- -- The mkHsApp will get the loc from the literal
+ -> TcM (HsOverLit TcId)
+tcOverloadedLit orig lit@(HsIntegral i fi) expected_ty
+ | fi `isHsVar` fromIntegerName -- Do not generate a LitInst for rebindable syntax.
+ -- Reason: If we do, tcSimplify will call lookupInst, which
+ -- will call tcSyntaxName, which does unification,
+ -- which tcSimplify doesn't like
+ -- ToDo: noLoc sadness
+ = do { integer_ty <- tcMetaTy integerTyConName
+ ; fi' <- tcSyntaxOp orig fi (mkFunTy integer_ty expected_ty)
+ ; return (HsIntegral i (HsApp (noLoc fi') (nlHsLit (HsInteger i integer_ty)))) }
+
| Just expr <- shortCutIntLit i expected_ty
- = returnM expr
+ = return (HsIntegral i expr)
| otherwise
- = newLitInst orig lit expected_ty
+ = do { expr <- newLitInst orig lit expected_ty
+ ; return (HsIntegral i expr) }
-newOverloadedLit orig lit@(HsFractional r fr) expected_ty
- | fr /= fromRationalName -- c.f. HsIntegral case
- = tcSyntaxName orig expected_ty (fromRationalName, HsVar fr) `thenM` \ (_,expr) ->
- mkRatLit r `thenM` \ rat_lit ->
- returnM (mkHsApp (noLoc expr) rat_lit)
- -- The mkHsApp will get the loc from the literal
+tcOverloadedLit orig lit@(HsFractional r fr) expected_ty
+ | fr `isHsVar` fromRationalName -- c.f. HsIntegral case
+ = do { rat_ty <- tcMetaTy rationalTyConName
+ ; fr' <- tcSyntaxOp orig fr (mkFunTy rat_ty expected_ty)
+ ; return (HsFractional r (HsApp (noLoc fr') (nlHsLit (HsRat r rat_ty)))) }
| Just expr <- shortCutFracLit r expected_ty
- = returnM expr
+ = return (HsFractional r expr)
| otherwise
- = newLitInst orig lit expected_ty
-
-newLitInst :: InstOrigin -> HsOverLit -> TcType -> TcM (LHsExpr TcId)
-newLitInst orig lit expected_ty
- = getInstLoc orig `thenM` \ loc ->
- newUnique `thenM` \ new_uniq ->
- let
- lit_nm = mkSystemVarNameEncoded new_uniq FSLIT("lit")
- -- The "encoded" bit means that we don't need to z-encode
- -- the string every time we call this!
- lit_inst = LitInst lit_nm lit expected_ty loc
- in
- extendLIE lit_inst `thenM_`
- returnM (L (instLocSrcSpan loc) (HsVar (instToId lit_inst)))
-
-shortCutIntLit :: Integer -> TcType -> Maybe (LHsExpr TcId) -- Returns noLoc'd result :-)
+ = do { expr <- newLitInst orig lit expected_ty
+ ; return (HsFractional r expr) }
+
+newLitInst :: InstOrigin -> HsOverLit Name -> TcType -> TcM (HsExpr TcId)
+newLitInst orig lit expected_ty -- Make a LitInst
+ = do { loc <- getInstLoc orig
+ ; new_uniq <- newUnique
+ ; let
+ lit_nm = mkSystemVarNameEncoded new_uniq FSLIT("lit")
+ -- The "encoded" bit means that we don't need to
+ -- z-encode the string every time we call this!
+ lit_inst = LitInst lit_nm lit expected_ty loc
+ ; extendLIE lit_inst
+ ; return (HsVar (instToId lit_inst)) }
+
+shortCutIntLit :: Integer -> TcType -> Maybe (HsExpr TcId)
shortCutIntLit i ty
| isIntTy ty && inIntRange i -- Short cut for Int
- = Just (noLoc (HsLit (HsInt i)))
+ = Just (HsLit (HsInt i))
| isIntegerTy ty -- Short cut for Integer
- = Just (noLoc (HsLit (HsInteger i ty)))
+ = Just (HsLit (HsInteger i ty))
| otherwise = Nothing
-shortCutFracLit :: Rational -> TcType -> Maybe (LHsExpr TcId) -- Returns noLoc'd result :-)
+shortCutFracLit :: Rational -> TcType -> Maybe (HsExpr TcId)
shortCutFracLit f ty
| isFloatTy ty
- = Just (mkHsConApp floatDataCon [] [HsLit (HsFloatPrim f)])
+ = Just (mk_lit floatDataCon (HsFloatPrim f))
| isDoubleTy ty
- = Just (mkHsConApp doubleDataCon [] [HsLit (HsDoublePrim f)])
+ = Just (mk_lit doubleDataCon (HsDoublePrim f))
| otherwise = Nothing
+ where
+ mk_lit con lit = HsApp (nlHsVar (dataConWrapId con)) (nlHsLit lit)
mkIntegerLit :: Integer -> TcM (LHsExpr TcId)
mkIntegerLit i
= tcMetaTy rationalTyConName `thenM` \ rat_ty ->
getSrcSpanM `thenM` \ span ->
returnM (L span $ HsLit (HsRat r rat_ty))
+
+isHsVar :: HsExpr Name -> Name -> Bool
+isHsVar (HsVar f) g = f==g
+isHsVar other g = False
\end{code}
-- Look for short cuts first: if the literal is *definitely* a
-- int, integer, float or a double, generate the real thing here.
--- This is essential (see nofib/spectral/nucleic).
+-- This is essential (see nofib/spectral/nucleic).
-- [Same shortcut as in newOverloadedLit, but we
-- may have done some unification by now]
-
lookupInst inst@(LitInst _nm (HsIntegral i from_integer_name) ty loc)
| Just expr <- shortCutIntLit i ty
- = returnM (GenInst [] expr) -- GenInst, not SimpleInst, because
+ = returnM (GenInst [] (noLoc expr)) -- GenInst, not SimpleInst, because
-- expr may be a constructor application
| otherwise
- = ASSERT( from_integer_name == fromIntegerName ) -- A LitInst invariant
+ = ASSERT( from_integer_name `isHsVar` fromIntegerName ) -- A LitInst invariant
tcLookupId fromIntegerName `thenM` \ from_integer ->
tcInstClassOp loc from_integer [ty] `thenM` \ method_inst ->
mkIntegerLit i `thenM` \ integer_lit ->
lookupInst inst@(LitInst _nm (HsFractional f from_rat_name) ty loc)
| Just expr <- shortCutFracLit f ty
- = returnM (GenInst [] expr)
+ = returnM (GenInst [] (noLoc expr))
| otherwise
- = ASSERT( from_rat_name == fromRationalName ) -- A LitInst invariant
+ = ASSERT( from_rat_name `isHsVar` fromRationalName ) -- A LitInst invariant
tcLookupId fromRationalName `thenM` \ from_rational ->
tcInstClassOp loc from_rational [ty] `thenM` \ method_inst ->
mkRatLit f `thenM` \ rat_lit ->
%* *
%************************************************************************
-
Suppose we are doing the -fno-implicit-prelude thing, and we encounter
a do-expression. We have to find (>>) in the current environment, which is
done by the rename. Then we have to check that it has the same type as
-> TcType -- Type to instantiate it at
-> (Name, HsExpr Name) -- (Standard name, user name)
-> TcM (Name, HsExpr TcId) -- (Standard name, suitable expression)
-
+-- *** NOW USED ONLY FOR CmdTop (sigh) ***
-- NB: tcSyntaxName calls tcExpr, and hence can do unification.
-- So we do not call it from lookupInst, which is called from tcSimplify
tcSyntaxName orig ty (std_nm, HsVar user_nm)
| std_nm == user_nm
- = tcStdSyntaxName orig ty std_nm
+ = newMethodFromName orig ty std_nm `thenM` \ id ->
+ returnM (std_nm, HsVar id)
tcSyntaxName orig ty (std_nm, user_nm_expr)
= tcLookupId std_nm `thenM` \ std_id ->
tcCheckSigma (L span user_nm_expr) sigma1 `thenM` \ expr ->
returnM (std_nm, unLoc expr)
-tcStdSyntaxName :: InstOrigin
- -> TcType -- Type to instantiate it at
- -> Name -- Standard name
- -> TcM (Name, HsExpr TcId) -- (Standard name, suitable expression)
-
-tcStdSyntaxName orig ty std_nm
- = newMethodFromName orig ty std_nm `thenM` \ id ->
- returnM (std_nm, HsVar id)
-
syntaxNameCtxt name orig ty tidy_env
= getInstLoc orig `thenM` \ inst_loc ->
let
import HsSyn
import TcHsSyn ( mkHsLet )
-import TcMatches ( TcStmtCtxt(..), tcMatchPats, matchCtxt, tcStmts,
- TcMatchCtxt(..), tcMatchesCase )
+import TcMatches ( tcMatchPats, matchCtxt, tcStmts, tcMDoStmt, tcGuardStmt,
+ TcMatchCtxt(..), tcMatchesCase )
import TcType ( TcType, TcTauType, TcRhoType, mkFunTys, mkTyConApp,
mkTyVarTy, mkAppTys, tcSplitTyConApp_maybe, tcEqType,
n_pats = length pats
stk' = drop n_pats cmd_stk
match_ctxt = LambdaExpr -- Maybe KappaExpr?
+ pg_ctxt = PatGuard match_ctxt
tc_grhss (GRHSs grhss binds)
- = tcBindsAndThen glueBindsOnGRHSs binds $
+ = tcBindsAndThen glueBindsOnGRHSs binds $
do { grhss' <- mappM (wrapLocM tc_grhs) grhss
; return (GRHSs grhss' []) }
- stmt_ctxt = SC { sc_what = PatGuard match_ctxt,
- sc_rhs = tcInferRho,
- sc_body = \ body -> tcCmd env body (stk', res_ty),
- sc_ty = res_ty } -- ToDo: Is this right?
- tc_grhs (GRHS guarded)
- = do { guarded' <- tcStmts stmt_ctxt guarded
- ; return (GRHS guarded') }
+ tc_grhs (GRHS guards body)
+ = do { (guards', rhs') <- tcStmts pg_ctxt
+ (tcGuardStmt res_ty)
+ guards
+ (tcCmd env body (stk', res_ty))
+ ; return (GRHS guards' rhs') }
-------------------------------------------
-- Do notation
-tc_cmd env cmd@(HsDo do_or_lc stmts _ ty) (cmd_stk, res_ty)
+tc_cmd env cmd@(HsDo do_or_lc stmts body ty) (cmd_stk, res_ty)
= do { checkTc (null cmd_stk) (nonEmptyCmdStkErr cmd)
- ; stmts' <- tcStmts stmt_ctxt stmts
- ; return (HsDo do_or_lc stmts' [] res_ty) }
- -- The 'methods' needed for the HsDo are in the enclosing HsCmd
- -- hence the empty list here
+ ; (stmts', body') <- tcStmts do_or_lc tc_stmt stmts $
+ tcCmd env body ([], res_ty)
+ ; return (HsDo do_or_lc stmts' body' res_ty) }
where
- stmt_ctxt = SC { sc_what = do_or_lc,
- sc_rhs = tc_rhs,
- sc_body = tc_ret,
- sc_ty = res_ty }
-
+ tc_stmt = tcMDoStmt res_ty tc_rhs
tc_rhs rhs = do { ty <- newTyFlexiVarTy liftedTypeKind
; rhs' <- tcCmd env rhs ([], ty)
; return (rhs', ty) }
- tc_ret body = tcCmd env body ([], res_ty)
-----------------------------------------------------------------
HsExpr.LHsExpr Name.Name
-> TcType.Expected TcType.TcType
-> TcRnTypes.TcM (HsExpr.LHsExpr Var.Id)
+
+tcSyntaxOp ::
+ TcRnTypes.InstOrigin
+ -> HsExpr.HsExpr Name.Name
+ -> TcType.TcType
+ -> TcRnTypes.TcM (HsExpr.HsExpr Var.Id)
\section[TcExpr]{Typecheck an expression}
\begin{code}
-module TcExpr ( tcCheckSigma, tcCheckRho, tcInferRho, tcMonoExpr ) where
+module TcExpr ( tcCheckSigma, tcCheckRho, tcInferRho,
+ tcMonoExpr, tcExpr, tcSyntaxOp
+ ) where
#include "HsVersions.h"
#ifdef GHCI /* Only if bootstrapped */
import {-# SOURCE #-} TcSplice( tcSpliceExpr, tcBracket )
+import HsSyn ( nlHsVar )
import Id ( Id )
import Name ( isExternalName )
import TcType ( isTauTy )
#endif
import HsSyn ( HsExpr(..), LHsExpr, HsLit(..), ArithSeqInfo(..), recBindFields,
- HsMatchContext(..), HsRecordBinds, mkHsApp, nlHsVar )
+ HsMatchContext(..), HsRecordBinds, mkHsApp )
import TcHsSyn ( hsLitType, (<$>) )
import TcRnMonad
-import TcUnify ( Expected(..), tcInfer, zapExpectedType, zapExpectedTo, tcSubExp, tcGen,
+import TcUnify ( Expected(..), tcInfer, zapExpectedType, zapExpectedTo,
+ tcSubExp, tcGen, tcSub,
unifyFunTys, zapToListTy, zapToTyConApp )
import BasicTypes ( isMarkedStrict )
-import Inst ( newOverloadedLit, newMethodFromName, newIPDict,
+import Inst ( tcOverloadedLit, newMethodFromName, newIPDict,
newDicts, newMethodWithGivenTy, tcInstStupidTheta, tcInstCall )
import TcBinds ( tcBindsAndThen )
import TcEnv ( tcLookup, tcLookupId, checkProcLevel,
import Kind ( openTypeKind, liftedTypeKind, argTypeKind )
import Id ( idType, recordSelectorFieldLabel, isRecordSelector )
-import DataCon ( DataCon, dataConFieldLabels, dataConStrictMarks, dataConWrapId )
+import DataCon ( DataCon, dataConFieldLabels, dataConStrictMarks,
+ dataConWrapId, dataConWorkId )
import Name ( Name )
import TyCon ( TyCon, FieldLabel, tyConTyVars, tyConStupidTheta,
tyConDataCons, tyConFields )
import TysWiredIn ( boolTy, parrTyCon, tupleTyCon )
import PrelNames ( enumFromName, enumFromThenName,
enumFromToName, enumFromThenToName,
- enumFromToPName, enumFromThenToPName
+ enumFromToPName, enumFromThenToPName, negateName
)
import ListSetOps ( minusList )
import DynFlags
tcInferRho :: LHsExpr Name -> TcM (LHsExpr TcId, TcRhoType)
tcInferRho (L loc (HsVar name)) = setSrcSpan loc $ do
- { (e,_,ty) <- tcId name; return (L loc e, ty)}
+ { (e,_,ty) <- tcId (OccurrenceOf name) name
+ ; return (L loc e, ty) }
tcInferRho expr = tcInfer (tcMonoExpr expr)
+
+tcSyntaxOp :: InstOrigin -> HsExpr Name -> TcType -> TcM (HsExpr TcId)
+-- Typecheck a syntax operator, checking that it has the specified type
+-- The operator is always a variable at this stage (i.e. renamer output)
+tcSyntaxOp orig (HsVar op) ty = do { (expr', _, id_ty) <- tcId orig op
+ ; co_fn <- tcSub ty id_ty
+ ; returnM (co_fn <$> expr') }
+tcSyntaxOp orig other ty = pprPanic "tcSyntaxOp" (ppr other)
\end{code}
-> TcM (LHsExpr TcId)
tcMonoExpr (L loc expr) res_ty
- = setSrcSpan loc (do { expr' <- tc_expr expr res_ty
+ = setSrcSpan loc (do { expr' <- tcExpr expr res_ty
; return (L loc expr') })
-tc_expr :: HsExpr Name -> Expected TcRhoType -> TcM (HsExpr TcId)
-tc_expr (HsVar name) res_ty
- = do { (expr', _, id_ty) <- tcId name
+tcExpr :: HsExpr Name -> Expected TcRhoType -> TcM (HsExpr TcId)
+tcExpr (HsVar name) res_ty
+ = do { (expr', _, id_ty) <- tcId (OccurrenceOf name) name
; co_fn <- tcSubExp res_ty id_ty
; returnM (co_fn <$> expr') }
-tc_expr (HsIPVar ip) res_ty
+tcExpr (HsIPVar ip) res_ty
= -- Implicit parameters must have a *tau-type* not a
-- type scheme. We enforce this by creating a fresh
-- type variable as its type. (Because res_ty may not
%************************************************************************
\begin{code}
-tc_expr in_expr@(ExprWithTySig expr poly_ty) res_ty
+tcExpr in_expr@(ExprWithTySig expr poly_ty) res_ty
= addErrCtxt (exprCtxt in_expr) $
tcHsSigType ExprSigCtxt poly_ty `thenM` \ sig_tc_ty ->
tcThingWithSig sig_tc_ty (tcCheckRho expr) res_ty `thenM` \ (co_fn, expr') ->
returnM (co_fn <$> ExprWithTySigOut expr' poly_ty)
-tc_expr (HsType ty) res_ty
+tcExpr (HsType ty) res_ty
= failWithTc (text "Can't handle type argument:" <+> ppr ty)
-- This is the syntax for type applications that I was planning
-- but there are difficulties (e.g. what order for type args)
%************************************************************************
\begin{code}
-tc_expr (HsPar expr) res_ty = tcMonoExpr expr res_ty `thenM` \ expr' ->
+tcExpr (HsPar expr) res_ty = tcMonoExpr expr res_ty `thenM` \ expr' ->
returnM (HsPar expr')
-tc_expr (HsSCC lbl expr) res_ty = tcMonoExpr expr res_ty `thenM` \ expr' ->
+tcExpr (HsSCC lbl expr) res_ty = tcMonoExpr expr res_ty `thenM` \ expr' ->
returnM (HsSCC lbl expr')
-tc_expr (HsCoreAnn lbl expr) res_ty = tcMonoExpr expr res_ty `thenM` \ expr' -> -- hdaume: core annotation
+tcExpr (HsCoreAnn lbl expr) res_ty = tcMonoExpr expr res_ty `thenM` \ expr' -> -- hdaume: core annotation
returnM (HsCoreAnn lbl expr')
-tc_expr (HsLit lit) res_ty = tcLit lit res_ty
+tcExpr (HsLit lit) res_ty = tcLit lit res_ty
-tc_expr (HsOverLit lit) res_ty
+tcExpr (HsOverLit lit) res_ty
= zapExpectedType res_ty liftedTypeKind `thenM` \ res_ty' ->
-- Overloaded literals must have liftedTypeKind, because
-- we're instantiating an overloaded function here,
-- whereas res_ty might be openTypeKind. This was a bug in 6.2.2
- newOverloadedLit (LiteralOrigin lit) lit res_ty' `thenM` \ lit_expr ->
- returnM (unLoc lit_expr) -- ToDo: nasty unLoc
+ tcOverloadedLit (LiteralOrigin lit) lit res_ty' `thenM` \ lit' ->
+ returnM (HsOverLit lit')
-tc_expr (NegApp expr neg_name) res_ty
- = tc_expr (HsApp (nlHsVar neg_name) expr) res_ty
- -- ToDo: use tcSyntaxName
+tcExpr (NegApp expr neg_expr) res_ty
+ = do { res_ty' <- zapExpectedType res_ty liftedTypeKind
+ ; neg_expr' <- tcSyntaxOp (OccurrenceOf negateName) neg_expr
+ (mkFunTy res_ty' res_ty')
+ ; expr' <- tcCheckRho expr res_ty'
+ ; return (NegApp expr' neg_expr') }
-tc_expr (HsLam match) res_ty
+tcExpr (HsLam match) res_ty
= tcMatchLambda match res_ty `thenM` \ match' ->
returnM (HsLam match')
-tc_expr (HsApp e1 e2) res_ty
+tcExpr (HsApp e1 e2) res_ty
= tcApp e1 [e2] res_ty
\end{code}
-- or just
-- op e
-tc_expr in_expr@(SectionL arg1 op) res_ty
+tcExpr in_expr@(SectionL arg1 op) res_ty
= tcInferRho op `thenM` \ (op', op_ty) ->
unifyFunTys 2 op_ty {- two args -} `thenM` \ ([arg1_ty, arg2_ty], op_res_ty) ->
tcArg op (arg1, arg1_ty, 1) `thenM` \ arg1' ->
-- Right sections, equivalent to \ x -> x op expr, or
-- \ x -> op x expr
-tc_expr in_expr@(SectionR op arg2) res_ty
+tcExpr in_expr@(SectionR op arg2) res_ty
= tcInferRho op `thenM` \ (op', op_ty) ->
unifyFunTys 2 op_ty {- two args -} `thenM` \ ([arg1_ty, arg2_ty], op_res_ty) ->
tcArg op (arg2, arg2_ty, 2) `thenM` \ arg2' ->
-- equivalent to (op e1) e2:
-tc_expr in_expr@(OpApp arg1 op fix arg2) res_ty
+tcExpr in_expr@(OpApp arg1 op fix arg2) res_ty
= tcInferRho op `thenM` \ (op', op_ty) ->
unifyFunTys 2 op_ty {- two args -} `thenM` \ ([arg1_ty, arg2_ty], op_res_ty) ->
tcArg op (arg1, arg1_ty, 1) `thenM` \ arg1' ->
\end{code}
\begin{code}
-tc_expr (HsLet binds (L loc expr)) res_ty
+tcExpr (HsLet binds (L loc expr)) res_ty
= tcBindsAndThen
glue
binds -- Bindings to check
- (setSrcSpan loc $ tc_expr expr res_ty)
+ (setSrcSpan loc $ tcExpr expr res_ty)
where
glue bind expr = HsLet [bind] (L loc expr)
-tc_expr in_expr@(HsCase scrut matches) exp_ty
+tcExpr in_expr@(HsCase scrut matches) exp_ty
= -- We used to typecheck the case alternatives first.
-- The case patterns tend to give good type info to use
-- when typechecking the scrutinee. For example
match_ctxt = MC { mc_what = CaseAlt,
mc_body = tcMonoExpr }
-tc_expr (HsIf pred b1 b2) res_ty
- = addErrCtxt (predCtxt pred) (
- tcCheckRho pred boolTy ) `thenM` \ pred' ->
+tcExpr (HsIf pred b1 b2) res_ty
+ = addErrCtxt (predCtxt pred)
+ (tcCheckRho pred boolTy) `thenM` \ pred' ->
zapExpectedType res_ty openTypeKind `thenM` \ res_ty' ->
-- C.f. the call to zapToType in TcMatches.tcMatches
tcCheckRho b2 res_ty' `thenM` \ b2' ->
returnM (HsIf pred' b1' b2')
-tc_expr (HsDo do_or_lc stmts method_names _) res_ty
- = zapExpectedType res_ty liftedTypeKind `thenM` \ res_ty' ->
- -- All comprehensions yield a monotype of kind *
- tcDoStmts do_or_lc stmts method_names res_ty' `thenM` \ (stmts', methods') ->
- returnM (HsDo do_or_lc stmts' methods' res_ty')
+tcExpr (HsDo do_or_lc stmts body _) res_ty
+ = tcDoStmts do_or_lc stmts body res_ty
-tc_expr in_expr@(ExplicitList _ exprs) res_ty -- Non-empty list
+tcExpr in_expr@(ExplicitList _ exprs) res_ty -- Non-empty list
= zapToListTy res_ty `thenM` \ elt_ty ->
mappM (tc_elt elt_ty) exprs `thenM` \ exprs' ->
returnM (ExplicitList elt_ty exprs')
= addErrCtxt (listCtxt expr) $
tcCheckRho expr elt_ty
-tc_expr in_expr@(ExplicitPArr _ exprs) res_ty -- maybe empty
+tcExpr in_expr@(ExplicitPArr _ exprs) res_ty -- maybe empty
= do { [elt_ty] <- zapToTyConApp parrTyCon res_ty
; exprs' <- mappM (tc_elt elt_ty) exprs
; return (ExplicitPArr elt_ty exprs') }
tc_elt elt_ty expr
= addErrCtxt (parrCtxt expr) (tcCheckRho expr elt_ty)
-tc_expr (ExplicitTuple exprs boxity) res_ty
+tcExpr (ExplicitTuple exprs boxity) res_ty
= do { arg_tys <- zapToTyConApp (tupleTyCon boxity (length exprs)) res_ty
; exprs' <- tcCheckRhos exprs arg_tys
; return (ExplicitTuple exprs' boxity) }
-tc_expr (HsProc pat cmd) res_ty
+tcExpr (HsProc pat cmd) res_ty
= tcProc pat cmd res_ty `thenM` \ (pat', cmd') ->
returnM (HsProc pat' cmd')
-tc_expr e@(HsArrApp _ _ _ _ _) _
+tcExpr e@(HsArrApp _ _ _ _ _) _
= failWithTc (vcat [ptext SLIT("The arrow command"), nest 2 (ppr e),
ptext SLIT("was found where an expression was expected")])
-tc_expr e@(HsArrForm _ _ _) _
+tcExpr e@(HsArrForm _ _ _) _
= failWithTc (vcat [ptext SLIT("The arrow command"), nest 2 (ppr e),
ptext SLIT("was found where an expression was expected")])
\end{code}
%************************************************************************
\begin{code}
-tc_expr expr@(RecordCon con@(L loc con_name) rbinds) res_ty
+tcExpr expr@(RecordCon con@(L loc con_name) _ rbinds) res_ty
= addErrCtxt (recordConCtxt expr) $
- addLocM tcId con `thenM` \ (con_expr, _, con_tau) ->
+ addLocM (tcId (OccurrenceOf con_name)) con `thenM` \ (con_expr, _, con_tau) ->
let
(_, record_ty) = tcSplitFunTys con_tau
(tycon, ty_args) = tcSplitTyConApp record_ty
-- Check for missing fields
checkMissingFields data_con rbinds `thenM_`
- returnM (RecordConOut data_con (L loc con_expr) rbinds')
+ returnM (RecordCon (L loc (dataConWorkId data_con)) con_expr rbinds')
-- The main complication with RecordUpd is that we need to explicitly
-- handle the *non-updated* fields. Consider:
--
-- All this is done in STEP 4 below.
-tc_expr expr@(RecordUpd record_expr rbinds) res_ty
+tcExpr expr@(RecordUpd record_expr rbinds _ _) res_ty
= addErrCtxt (recordUpdCtxt expr) $
-- STEP 0
extendLIEs dicts `thenM_`
-- Phew!
- returnM (RecordUpdOut record_expr' record_ty result_record_ty rbinds')
+ returnM (RecordUpd record_expr' rbinds' record_ty result_record_ty)
\end{code}
%************************************************************************
\begin{code}
-tc_expr (ArithSeqIn seq@(From expr)) res_ty
+tcExpr (ArithSeq _ seq@(From expr)) res_ty
= zapToListTy res_ty `thenM` \ elt_ty ->
tcCheckRho expr elt_ty `thenM` \ expr' ->
newMethodFromName (ArithSeqOrigin seq)
elt_ty enumFromName `thenM` \ enum_from ->
- returnM (ArithSeqOut (nlHsVar enum_from) (From expr'))
+ returnM (ArithSeq (HsVar enum_from) (From expr'))
-tc_expr in_expr@(ArithSeqIn seq@(FromThen expr1 expr2)) res_ty
+tcExpr in_expr@(ArithSeq _ seq@(FromThen expr1 expr2)) res_ty
= addErrCtxt (arithSeqCtxt in_expr) $
zapToListTy res_ty `thenM` \ elt_ty ->
tcCheckRho expr1 elt_ty `thenM` \ expr1' ->
newMethodFromName (ArithSeqOrigin seq)
elt_ty enumFromThenName `thenM` \ enum_from_then ->
- returnM (ArithSeqOut (nlHsVar enum_from_then) (FromThen expr1' expr2'))
+ returnM (ArithSeq (HsVar enum_from_then) (FromThen expr1' expr2'))
-tc_expr in_expr@(ArithSeqIn seq@(FromTo expr1 expr2)) res_ty
+tcExpr in_expr@(ArithSeq _ seq@(FromTo expr1 expr2)) res_ty
= addErrCtxt (arithSeqCtxt in_expr) $
zapToListTy res_ty `thenM` \ elt_ty ->
tcCheckRho expr1 elt_ty `thenM` \ expr1' ->
newMethodFromName (ArithSeqOrigin seq)
elt_ty enumFromToName `thenM` \ enum_from_to ->
- returnM (ArithSeqOut (nlHsVar enum_from_to) (FromTo expr1' expr2'))
+ returnM (ArithSeq (HsVar enum_from_to) (FromTo expr1' expr2'))
-tc_expr in_expr@(ArithSeqIn seq@(FromThenTo expr1 expr2 expr3)) res_ty
+tcExpr in_expr@(ArithSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty
= addErrCtxt (arithSeqCtxt in_expr) $
zapToListTy res_ty `thenM` \ elt_ty ->
tcCheckRho expr1 elt_ty `thenM` \ expr1' ->
newMethodFromName (ArithSeqOrigin seq)
elt_ty enumFromThenToName `thenM` \ eft ->
- returnM (ArithSeqOut (nlHsVar eft) (FromThenTo expr1' expr2' expr3'))
+ returnM (ArithSeq (HsVar eft) (FromThenTo expr1' expr2' expr3'))
-tc_expr in_expr@(PArrSeqIn seq@(FromTo expr1 expr2)) res_ty
+tcExpr in_expr@(PArrSeq _ seq@(FromTo expr1 expr2)) res_ty
= addErrCtxt (parrSeqCtxt in_expr) $
zapToTyConApp parrTyCon res_ty `thenM` \ [elt_ty] ->
tcCheckRho expr1 elt_ty `thenM` \ expr1' ->
newMethodFromName (PArrSeqOrigin seq)
elt_ty enumFromToPName `thenM` \ enum_from_to ->
- returnM (PArrSeqOut (nlHsVar enum_from_to) (FromTo expr1' expr2'))
+ returnM (PArrSeq (HsVar enum_from_to) (FromTo expr1' expr2'))
-tc_expr in_expr@(PArrSeqIn seq@(FromThenTo expr1 expr2 expr3)) res_ty
+tcExpr in_expr@(PArrSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty
= addErrCtxt (parrSeqCtxt in_expr) $
zapToTyConApp parrTyCon res_ty `thenM` \ [elt_ty] ->
tcCheckRho expr1 elt_ty `thenM` \ expr1' ->
newMethodFromName (PArrSeqOrigin seq)
elt_ty enumFromThenToPName `thenM` \ eft ->
- returnM (PArrSeqOut (nlHsVar eft) (FromThenTo expr1' expr2' expr3'))
+ returnM (PArrSeq (HsVar eft) (FromThenTo expr1' expr2' expr3'))
-tc_expr (PArrSeqIn _) _
+tcExpr (PArrSeq _ _) _
= panic "TcExpr.tcMonoExpr: Infinite parallel array!"
-- the parser shouldn't have generated it and the renamer shouldn't have
-- let it through
\begin{code}
#ifdef GHCI /* Only if bootstrapped */
-- Rename excludes these cases otherwise
-tc_expr (HsSpliceE splice) res_ty = tcSpliceExpr splice res_ty
-tc_expr (HsBracket brack) res_ty = do { e <- tcBracket brack res_ty
+tcExpr (HsSpliceE splice) res_ty = tcSpliceExpr splice res_ty
+tcExpr (HsBracket brack) res_ty = do { e <- tcBracket brack res_ty
; return (unLoc e) }
#endif /* GHCI */
\end{code}
%************************************************************************
\begin{code}
-tc_expr other _ = pprPanic "tcMonoExpr" (ppr other)
+tcExpr other _ = pprPanic "tcMonoExpr" (ppr other)
\end{code}
-- If the function isn't simple, infer its type, and return no
-- type variables
tcFun (L loc (HsVar f)) = setSrcSpan loc $ do
- { (fun', tvs, fun_tau) <- tcId f
+ { (fun', tvs, fun_tau) <- tcId (OccurrenceOf f) f
; return (L loc fun', tvs, fun_tau) }
tcFun fun = do { (fun', fun_tau) <- tcInfer (tcMonoExpr fun)
; return (fun', [], fun_tau) }
b) perhaps fewer separated lambdas
\begin{code}
-tcId :: Name -> TcM (HsExpr TcId, [TcTyVar], TcRhoType)
+tcId :: InstOrigin -> Name -> TcM (HsExpr TcId, [TcTyVar], TcRhoType)
-- Return the type variables at which the function
-- is instantiated, as well as the translated variable and its type
-tcId id_name -- Look up the Id and instantiate its type
+tcId orig id_name -- Look up the Id and instantiate its type
= tcLookup id_name `thenM` \ thing ->
case thing of {
AGlobal (ADataCon con) -- Similar, but instantiate the stupid theta too
| otherwise = case tcSplitSigmaTy fun_ty of
(_,[],_) -> False -- Not overloaded
(_,theta,_) -> not (any isLinearPred theta)
-
- orig = OccurrenceOf id_name
\end{code}
%************************************************************************
import Name ( Name )
import Var ( Id )
import TcType ( TcType, Expected )
-import TcRnTypes( TcM )
+import TcRnTypes( TcM, InstOrigin )
tcCheckSigma ::
LHsExpr Name
LHsExpr Name
-> Expected TcType
-> TcM (LHsExpr Id)
+
+tcSyntaxOp ::
+ InstOrigin
+ -> HsExpr Name
+ -> TcType
+ -> TcM (HsExpr Id)
\end{code}
map tag2con_Foo (enumFromTo (I# a#) (I# b#))
}}
- index c@(a, b) d
- = if inRange c d
- then case (con2tag_Foo d -# con2tag_Foo a) of
+ -- Generate code for unsafeIndex, becuase using index leads
+ -- to lots of redundant range tests
+ unsafeIndex c@(a, b) d
+ = case (con2tag_Foo d -# con2tag_Foo a) of
r# -> I# r#
- else error "Ix.Foo.index: out of range"
inRange (a, b) c
= let
then enum_ixes
else single_con_ixes
where
- tycon_str = getOccString tycon
tycon_loc = getSrcSpan tycon
--------------------------------------------------------------
(nlHsVarApps intDataCon_RDR [bh_RDR]))
enum_index
- = mk_easy_FunBind tycon_loc index_RDR
+ = mk_easy_FunBind tycon_loc unsafeIndex_RDR
[noLoc (AsPat (noLoc c_RDR)
(nlTuplePat [a_Pat, nlWildPat] Boxed)),
d_Pat] emptyLHsBinds (
- nlHsIf (nlHsPar (nlHsVarApps inRange_RDR [c_RDR, d_RDR])) (
untag_Expr tycon [(a_RDR, ah_RDR)] (
untag_Expr tycon [(d_RDR, dh_RDR)] (
let
(genOpApp (nlHsVar dh_RDR) minusInt_RDR (nlHsVar ah_RDR))
[mkSimpleHsAlt (nlVarPat c_RDR) rhs]
))
- ) {-else-} (
- nlHsApp (nlHsVar error_RDR) (nlHsLit (HsString (mkFastString ("Ix."++tycon_str++".index: out of range\n"))))
- ))
+ )
enum_inRange
= mk_easy_FunBind tycon_loc inRange_RDR
single_con_range
= mk_easy_FunBind tycon_loc range_RDR
[nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] emptyLHsBinds $
- nlHsDo ListComp stmts
+ nlHsDo ListComp stmts con_expr
where
stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
- ++
- [nlResultStmt con_expr]
- mk_qual a b c = nlBindStmt (nlVarPat c)
+ mk_qual a b c = noLoc $ mkBindStmt (nlVarPat c)
(nlHsApp (nlHsVar range_RDR)
(nlTuple [nlHsVar a, nlHsVar b] Boxed))
----------------
single_con_index
- = mk_easy_FunBind tycon_loc index_RDR
+ = mk_easy_FunBind tycon_loc unsafeIndex_RDR
[nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
- con_pat cs_needed] (unitBag range_size) (
- foldl mk_index (nlHsIntLit 0) (zip3 as_needed bs_needed cs_needed))
+ con_pat cs_needed] emptyBag
+ (mk_index (zip3 as_needed bs_needed cs_needed))
where
- mk_index multiply_by (l, u, i)
+ -- index (l1,u1) i1 + rangeSize (l1,u1) * (index (l2,u2) i2 + ...)
+ mk_index [] = nlHsIntLit 0
+ mk_index [(l,u,i)] = mk_one l u i
+ mk_index ((l,u,i) : rest)
= genOpApp (
- (nlHsApps index_RDR [nlTuple [nlHsVar l, nlHsVar u] Boxed,
- nlHsVar i])
- ) plus_RDR (
+ mk_one l u i
+ ) plus_RDR (
genOpApp (
- (nlHsApp (nlHsVar rangeSize_RDR)
+ (nlHsApp (nlHsVar unsafeRangeSize_RDR)
(nlTuple [nlHsVar l, nlHsVar u] Boxed))
- ) times_RDR multiply_by
+ ) times_RDR (mk_index rest)
)
-
- range_size
- = mk_easy_FunBind tycon_loc rangeSize_RDR
- [nlTuplePat [a_Pat, b_Pat] Boxed] emptyLHsBinds (
- genOpApp (
- (nlHsApps index_RDR [nlTuple [a_Expr, b_Expr] Boxed,
- b_Expr])
- ) plus_RDR (nlHsIntLit 1))
+ mk_one l u i
+ = nlHsApps unsafeIndex_RDR [nlTuple [nlHsVar l, nlHsVar u] Boxed, nlHsVar i]
------------------
single_con_inRange
read_nullary_cons
= case nullary_cons of
[] -> []
- [con] -> [nlHsDo DoExpr [bindLex (ident_pat (data_con_str con)),
- result_stmt con []]]
+ [con] -> [nlHsDo DoExpr [bindLex (ident_pat (data_con_str con))]
+ (result_expr con [])]
_ -> [nlHsApp (nlHsVar choose_RDR)
(nlList (map mk_pair nullary_cons))]
Boxed
read_non_nullary_con data_con
- = nlHsApps prec_RDR [nlHsIntLit prec, nlHsDo DoExpr stmts]
+ = nlHsApps prec_RDR [nlHsIntLit prec, nlHsDo DoExpr stmts body]
where
stmts | is_infix = infix_stmts
| length labels > 0 = lbl_stmts
| otherwise = prefix_stmts
+ body = result_expr data_con as_needed
+
prefix_stmts -- T a b c
= [bindLex (ident_pat (data_con_str_w_parens data_con))]
++ read_args
- ++ [result_stmt data_con as_needed]
infix_stmts -- a %% b
= [read_a1,
bindLex (symbol_pat (data_con_str data_con)),
- read_a2,
- result_stmt data_con [a1,a2]]
+ read_a2]
lbl_stmts -- T { f1 = a, f2 = b }
= [bindLex (ident_pat (data_con_str_w_parens data_con)),
read_punc "{"]
++ concat (intersperse [read_punc ","] field_stmts)
- ++ [read_punc "}", result_stmt data_con as_needed]
+ ++ [read_punc "}"]
field_stmts = zipWithEqual "lbl_stmts" read_field labels as_needed
as_needed = take con_arity as_RDRs
read_args = zipWithEqual "gen_Read_binds" read_arg as_needed (dataConOrigArgTys data_con)
(read_a1:read_a2:_) = read_args
- (a1:a2:_) = as_needed
prec = getPrec is_infix get_fixity dc_nm
------------------------------------------------------------------------
-- Helpers
------------------------------------------------------------------------
mk_alt e1 e2 = genOpApp e1 alt_RDR e2
- bindLex pat = nlBindStmt pat (nlHsVar lexP_RDR)
- result_stmt c as = nlResultStmt (nlHsApp (nlHsVar returnM_RDR) (con_app c as))
+ bindLex pat = noLoc (mkBindStmt pat (nlHsVar lexP_RDR))
con_app c as = nlHsVarApps (getRdrName c) as
+ result_expr c as = nlHsApp (nlHsVar returnM_RDR) (con_app c as)
punc_pat s = nlConPat punc_RDR [nlLitPat (mkHsString s)] -- Punc 'c'
ident_pat s = nlConPat ident_RDR [nlLitPat s] -- Ident "foo"
read_punc c = bindLex (punc_pat c)
read_arg a ty
| isUnLiftedType ty = pprPanic "Error in deriving:" (text "Can't read unlifted types yet:" <+> ppr ty)
- | otherwise = nlBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR])
+ | otherwise = noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR]))
read_field lbl a = read_lbl lbl ++
[read_punc "=",
- nlBindStmt (nlVarPat a) (nlHsVarApps reset_RDR [readPrec_RDR])]
+ noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps reset_RDR [readPrec_RDR]))]
-- When reading field labels we might encounter
-- a = 3
ch_RDR = mkVarUnqual FSLIT("c#")
dh_RDR = mkVarUnqual FSLIT("d#")
cmp_eq_RDR = mkVarUnqual FSLIT("cmp_eq")
-rangeSize_RDR = mkVarUnqual FSLIT("rangeSize")
as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
voidTy, listTyCon, tupleTyCon )
import TyCon ( mkPrimTyCon, tyConKind, PrimRep(..) )
import Kind ( splitKindFunTys )
-import Name ( getOccName, mkInternalName, mkDerivedTyConOcc )
+import Name ( Name, getOccName, mkInternalName, mkDerivedTyConOcc )
import Var ( Var, isId, isLocalVar, tyVarKind )
import VarSet
import VarEnv
import Maybe ( isNothing )
import Unique ( Uniquable(..) )
import SrcLoc ( noSrcLoc, noLoc, Located(..), unLoc )
+import Util ( mapSnd )
import Bag
import Outputable
\end{code}
pat_type (TuplePat pats box) = mkTupleTy box (length pats) (map hsPatType pats)
pat_type (ConPatOut _ _ _ _ _ ty) = ty
pat_type (SigPatOut pat ty) = ty
-pat_type (NPatOut lit ty _) = ty
-pat_type (NPlusKPatOut id _ _ _) = idType (unLoc id)
+pat_type (NPat lit _ _ ty) = ty
+pat_type (NPlusKPat id _ _ _) = idType (unLoc id)
pat_type (DictPat ds ms) = case (ds ++ ms) of
[] -> unitTy
[d] -> idType d
-- Ids defined in this module should be in the envt;
-- ignore others. (Actually, data constructors are also
-- not LocalVars, even when locally defined, but that is fine.)
+-- (Also foreign-imported things aren't currently in the ZonkEnv;
+-- that's ok because they don't need zonking.)
--
-- Actually, Template Haskell works in 'chunks' of declarations, and
-- an earlier chunk won't be in the 'env' that the zonking phase
-- 'orElse' case in the LocalVar branch.
--
-- Even without template splices, in module Main, the checking of
--- 'main' is done as a separte chunk.
+-- 'main' is done as a separate chunk.
zonkIdOcc (ZonkEnv zonk_ty env) id
| isLocalVar id = lookupVarEnv env id `orElse` id
| otherwise = id
zonkGRHSs env (GRHSs grhss binds)
= zonkNestedBinds env binds `thenM` \ (new_env, new_binds) ->
let
- zonk_grhs (GRHS guarded)
- = zonkStmts new_env guarded `thenM` \ new_guarded ->
- returnM (GRHS new_guarded)
+ zonk_grhs (GRHS guarded rhs)
+ = zonkStmts new_env guarded `thenM` \ (env2, new_guarded) ->
+ zonkLExpr env2 rhs `thenM` \ new_rhs ->
+ returnM (GRHS new_guarded new_rhs)
in
mappM (wrapLocM zonk_grhs) grhss `thenM` \ new_grhss ->
returnM (GRHSs new_grhss new_binds)
zonkExpr env (HsLit lit)
= returnM (HsLit lit)
--- HsOverLit doesn't appear in typechecker output
+
+zonkExpr env (HsOverLit lit)
+ = do { lit' <- zonkOverLit env lit
+ ; return (HsOverLit lit') }
zonkExpr env (HsLam matches)
= zonkMatchGroup env matches `thenM` \ new_matches ->
zonkLExpr env e2 `thenM` \ new_e2 ->
returnM (OpApp new_e1 new_op fixity new_e2)
-zonkExpr env (NegApp _ _) = panic "zonkExpr env: NegApp"
+zonkExpr env (NegApp expr op)
+ = zonkLExpr env expr `thenM` \ new_expr ->
+ zonkExpr env op `thenM` \ new_op ->
+ returnM (NegApp new_expr new_op)
zonkExpr env (HsPar e)
= zonkLExpr env e `thenM` \new_e ->
zonkLExpr env expr `thenM` \ new_expr ->
returnM (SectionR new_op new_expr)
--- gaw 2004
zonkExpr env (HsCase expr ms)
= zonkLExpr env expr `thenM` \ new_expr ->
zonkMatchGroup env ms `thenM` \ new_ms ->
zonkLExpr new_env expr `thenM` \ new_expr ->
returnM (HsLet new_binds new_expr)
-zonkExpr env (HsDo do_or_lc stmts ids ty)
- = zonkStmts env stmts `thenM` \ new_stmts ->
+zonkExpr env (HsDo do_or_lc stmts body ty)
+ = zonkStmts env stmts `thenM` \ (new_env, new_stmts) ->
+ zonkLExpr new_env body `thenM` \ new_body ->
zonkTcTypeToType env ty `thenM` \ new_ty ->
- zonkReboundNames env ids `thenM` \ new_ids ->
- returnM (HsDo do_or_lc new_stmts new_ids new_ty)
+ returnM (HsDo (zonkDo env do_or_lc)
+ new_stmts new_body new_ty)
zonkExpr env (ExplicitList ty exprs)
= zonkTcTypeToType env ty `thenM` \ new_ty ->
= zonkLExprs env exprs `thenM` \ new_exprs ->
returnM (ExplicitTuple new_exprs boxed)
-zonkExpr env (RecordConOut data_con con_expr rbinds)
- = zonkLExpr env con_expr `thenM` \ new_con_expr ->
+zonkExpr env (RecordCon data_con con_expr rbinds)
+ = zonkExpr env con_expr `thenM` \ new_con_expr ->
zonkRbinds env rbinds `thenM` \ new_rbinds ->
- returnM (RecordConOut data_con new_con_expr new_rbinds)
+ returnM (RecordCon data_con new_con_expr new_rbinds)
-zonkExpr env (RecordUpd _ _) = panic "zonkExpr env:RecordUpd"
-
-zonkExpr env (RecordUpdOut expr in_ty out_ty rbinds)
+zonkExpr env (RecordUpd expr rbinds in_ty out_ty)
= zonkLExpr env expr `thenM` \ new_expr ->
zonkTcTypeToType env in_ty `thenM` \ new_in_ty ->
zonkTcTypeToType env out_ty `thenM` \ new_out_ty ->
zonkRbinds env rbinds `thenM` \ new_rbinds ->
- returnM (RecordUpdOut new_expr new_in_ty new_out_ty new_rbinds)
+ returnM (RecordUpd new_expr new_rbinds new_in_ty new_out_ty)
zonkExpr env (ExprWithTySigOut e ty)
= do { e' <- zonkLExpr env e
; return (ExprWithTySigOut e' ty) }
zonkExpr env (ExprWithTySig _ _) = panic "zonkExpr env:ExprWithTySig"
-zonkExpr env (ArithSeqIn _) = panic "zonkExpr env:ArithSeqIn"
-zonkExpr env (PArrSeqIn _) = panic "zonkExpr env:PArrSeqIn"
-zonkExpr env (ArithSeqOut expr info)
- = zonkLExpr env expr `thenM` \ new_expr ->
+zonkExpr env (ArithSeq expr info)
+ = zonkExpr env expr `thenM` \ new_expr ->
zonkArithSeq env info `thenM` \ new_info ->
- returnM (ArithSeqOut new_expr new_info)
+ returnM (ArithSeq new_expr new_info)
-zonkExpr env (PArrSeqOut expr info)
- = zonkLExpr env expr `thenM` \ new_expr ->
+zonkExpr env (PArrSeq expr info)
+ = zonkExpr env expr `thenM` \ new_expr ->
zonkArithSeq env info `thenM` \ new_info ->
- returnM (PArrSeqOut new_expr new_info)
+ returnM (PArrSeq new_expr new_info)
zonkExpr env (HsSCC lbl expr)
= zonkLExpr env expr `thenM` \ new_expr ->
returnM (TyLam tyvars new_expr)
zonkExpr env (TyApp expr tys)
- = zonkLExpr env expr `thenM` \ new_expr ->
- mappM (zonkTcTypeToType env) tys `thenM` \ new_tys ->
+ = zonkLExpr env expr `thenM` \ new_expr ->
+ zonkTcTypeToTypes env tys `thenM` \ new_tys ->
returnM (TyApp new_expr new_tys)
zonkExpr env (DictLam dicts expr)
mappM (zonkCmdTop env) args `thenM` \ new_args ->
returnM (HsArrForm new_op fixity new_args)
+zonkExpr env other = pprPanic "zonkExpr" (ppr other)
+
zonkCmdTop :: ZonkEnv -> LHsCmdTop TcId -> TcM (LHsCmdTop Id)
zonkCmdTop env cmd = wrapLocM (zonk_cmd_top env) cmd
zonk_cmd_top env (HsCmdTop cmd stack_tys ty ids)
- = zonkLExpr env cmd `thenM` \ new_cmd ->
- mappM (zonkTcTypeToType env) stack_tys
- `thenM` \ new_stack_tys ->
+ = zonkLExpr env cmd `thenM` \ new_cmd ->
+ zonkTcTypeToTypes env stack_tys `thenM` \ new_stack_tys ->
zonkTcTypeToType env ty `thenM` \ new_ty ->
- zonkReboundNames env ids `thenM` \ new_ids ->
+ mapSndM (zonkExpr env) ids `thenM` \ new_ids ->
returnM (HsCmdTop new_cmd new_stack_tys new_ty new_ids)
-------------------------------------------------------------------------
-zonkReboundNames :: ZonkEnv -> ReboundNames Id -> TcM (ReboundNames Id)
-zonkReboundNames env prs
- = mapM zonk prs
- where
- zonk (n, e) = zonkExpr env e `thenM` \ new_e ->
- returnM (n, new_e)
+zonkDo :: ZonkEnv -> HsStmtContext Name -> HsStmtContext Name
+-- Only used for 'do', so the only Ids are in a MDoExpr table
+zonkDo env (MDoExpr tbl) = MDoExpr (mapSnd (zonkIdOcc env) tbl)
+zonkDo env do_or_lc = do_or_lc
+-------------------------------------------------------------------------
+zonkOverLit :: ZonkEnv -> HsOverLit TcId -> TcM (HsOverLit Id)
+zonkOverLit env (HsIntegral i e)
+ = do { e' <- zonkExpr env e; return (HsIntegral i e') }
+zonkOverLit env (HsFractional r e)
+ = do { e' <- zonkExpr env e; return (HsFractional r e') }
-------------------------------------------------------------------------
zonkArithSeq :: ZonkEnv -> ArithSeqInfo TcId -> TcM (ArithSeqInfo Id)
-------------------------------------------------------------------------
-zonkStmts :: ZonkEnv -> [LStmt TcId] -> TcM [LStmt Id]
-
-zonkStmts env stmts = zonk_stmts env stmts `thenM` \ (_, stmts) ->
- returnM stmts
+zonkStmts :: ZonkEnv -> [LStmt TcId] -> TcM (ZonkEnv, [LStmt Id])
+zonkStmts env [] = return (env, [])
+zonkStmts env (s:ss) = do { (env1, s') <- wrapLocSndM (zonkStmt env) s
+ ; (env2, ss') <- zonkStmts env1 ss
+ ; return (env2, s' : ss') }
-zonk_stmts :: ZonkEnv -> [LStmt TcId] -> TcM (ZonkEnv, [LStmt Id])
-zonk_stmts env [] = return (env, [])
-zonk_stmts env (s:ss) = do { (env1, s') <- wrapLocSndM (zonkStmt env) s
- ; (env2, ss') <- zonk_stmts env1 ss
- ; return (env2, s' : ss') }
+get (ZonkEnv _ env) = env
zonkStmt :: ZonkEnv -> Stmt TcId -> TcM (ZonkEnv, Stmt Id)
zonkStmt env (ParStmt stmts_w_bndrs)
in
return (env1, ParStmt new_stmts_w_bndrs)
where
- zonk_branch (stmts, bndrs) = zonk_stmts env stmts `thenM` \ (env1, new_stmts) ->
+ zonk_branch (stmts, bndrs) = zonkStmts env stmts `thenM` \ (env1, new_stmts) ->
returnM (new_stmts, zonkIdOccs env1 bndrs)
-zonkStmt env (RecStmt segStmts lvs rvs rets)
+zonkStmt env (RecStmt segStmts lvs rvs rets binds)
= zonkIdBndrs env rvs `thenM` \ new_rvs ->
let
env1 = extendZonkEnv env new_rvs
in
- zonk_stmts env1 segStmts `thenM` \ (env2, new_segStmts) ->
+ zonkStmts env1 segStmts `thenM` \ (env2, new_segStmts) ->
-- Zonk the ret-expressions in an envt that
-- has the polymorphic bindings in the envt
- zonkLExprs env2 rets `thenM` \ new_rets ->
+ mapM (zonkExpr env2) rets `thenM` \ new_rets ->
let
new_lvs = zonkIdOccs env2 lvs
env3 = extendZonkEnv env new_lvs -- Only the lvs are needed
in
- returnM (env3, RecStmt new_segStmts new_lvs new_rvs new_rets)
-
-zonkStmt env (ResultStmt expr)
- = zonkLExpr env expr `thenM` \ new_expr ->
- returnM (env, ResultStmt new_expr)
+ zonkRecMonoBinds env3 binds `thenM` \ (env4, new_binds) ->
+ returnM (env4, RecStmt new_segStmts new_lvs new_rvs new_rets new_binds)
-zonkStmt env (ExprStmt expr ty)
+zonkStmt env (ExprStmt expr then_op ty)
= zonkLExpr env expr `thenM` \ new_expr ->
+ zonkExpr env then_op `thenM` \ new_then ->
zonkTcTypeToType env ty `thenM` \ new_ty ->
- returnM (env, ExprStmt new_expr new_ty)
+ returnM (env, ExprStmt new_expr new_then new_ty)
zonkStmt env (LetStmt binds)
= zonkNestedBinds env binds `thenM` \ (env1, new_binds) ->
returnM (env1, LetStmt new_binds)
-zonkStmt env (BindStmt pat expr)
+zonkStmt env (BindStmt pat expr bind_op fail_op)
= do { new_expr <- zonkLExpr env expr
; (env1, new_pat) <- zonkPat env pat
- ; return (env1, BindStmt new_pat new_expr) }
+ ; new_bind <- zonkExpr env bind_op
+ ; new_fail <- zonkExpr env fail_op
+ ; return (env1, BindStmt new_pat new_expr new_bind new_fail) }
-------------------------------------------------------------------------
; (env', pat') <- zonkPat env pat
; return (env', SigPatOut pat' ty') }
-zonk_pat env (NPatOut lit ty expr)
- = do { ty' <- zonkTcTypeToType env ty
- ; expr' <- zonkExpr env expr
- ; return (env, NPatOut lit ty' expr') }
+zonk_pat env (NPat lit mb_neg eq_expr ty)
+ = do { lit' <- zonkOverLit env lit
+ ; mb_neg' <- case mb_neg of
+ Nothing -> return Nothing
+ Just neg -> do { neg' <- zonkExpr env neg
+ ; return (Just neg') }
+ ; eq_expr' <- zonkExpr env eq_expr
+ ; ty' <- zonkTcTypeToType env ty
+ ; return (env, NPat lit' mb_neg' eq_expr' ty') }
-zonk_pat env (NPlusKPatOut (L loc n) k e1 e2)
+zonk_pat env (NPlusKPat (L loc n) lit e1 e2)
= do { n' <- zonkIdBndr env n
- ; e1' <- zonkExpr env e1
+ ; lit' <- zonkOverLit env lit
+ ; e1' <- zonkExpr env e1
; e2' <- zonkExpr env e2
- ; return (extendZonkEnv1 env n', NPlusKPatOut (L loc n') k e1' e2') }
+ ; return (extendZonkEnv1 env n', NPlusKPat (L loc n') lit' e1' e2') }
zonk_pat env (DictPat ds ms)
= do { ds' <- zonkIdBndrs env ds
zonkTcTypeToType :: ZonkEnv -> TcType -> TcM Type
zonkTcTypeToType (ZonkEnv zonk_ty _) ty = zonk_ty ty
+zonkTcTypeToTypes :: ZonkEnv -> [TcType] -> TcM [Type]
+zonkTcTypeToTypes env tys = mapM (zonkTcTypeToType env) tys
+
zonkTypeCollecting :: TcRef TyVarSet -> TcType -> TcM Type
-- This variant collects unbound type variables in a mutable variable
zonkTypeCollecting unbound_tv_set
\begin{code}
module TcMatches ( tcMatchesFun, tcGRHSsPat, tcMatchesCase, tcMatchLambda,
matchCtxt,
- tcDoStmts, tcStmtsAndThen, tcStmts, tcThingWithSig,
+ tcDoStmts, tcStmts, tcMDoStmt, tcGuardStmt, tcThingWithSig,
tcMatchPats,
- TcStmtCtxt(..), TcMatchCtxt(..)
+ TcMatchCtxt(..)
) where
#include "HsVersions.h"
-import {-# SOURCE #-} TcExpr( tcCheckRho, tcInferRho, tcMonoExpr )
+import {-# SOURCE #-} TcExpr( tcSyntaxOp, tcCheckRho, tcInferRho, tcMonoExpr, tcCheckSigma )
import HsSyn ( HsExpr(..), LHsExpr, MatchGroup(..),
Match(..), LMatch, GRHSs(..), GRHS(..),
Stmt(..), LStmt, HsMatchContext(..), HsStmtContext(..),
- ReboundNames, LPat, HsBindGroup(..),
- pprMatch, isDoExpr,
- pprMatchContext, pprStmtContext, pprStmtResultContext,
- collectPatsBinders, glueBindsOnGRHSs
+ LPat, pprMatch, isIrrefutableHsPat,
+ pprMatchContext, pprStmtContext, pprMatchRhsContext,
+ collectPatsBinders, glueBindsOnGRHSs, noSyntaxExpr
)
import TcHsSyn ( ExprCoFn, isIdCoercion, (<$>), (<.>) )
import TcRnMonad
import TcHsType ( tcHsPatSigType, UserTypeCtxt(..) )
-import Inst ( tcSyntaxName, tcInstCall )
+import Inst ( tcInstCall, newMethodFromName )
import TcEnv ( TcId, tcLookupLocalIds, tcLookupId, tcExtendIdEnv,
tcExtendTyVarEnv )
import TcPat ( PatCtxt(..), tcPats )
import TcMType ( newTyFlexiVarTy, newTyFlexiVarTys, zonkTcType )
import TcType ( TcType, TcTyVar, TcSigmaType, TcRhoType, mkFunTys,
- tyVarsOfTypes, tidyOpenTypes, isSigmaTy, mkTyConApp,
- liftedTypeKind, openTypeKind, mkArrowKind, mkAppTy )
+ tyVarsOfTypes, tidyOpenTypes, isSigmaTy,
+ liftedTypeKind, openTypeKind, mkFunTy, mkAppTy )
import TcBinds ( tcBindsAndThen )
import TcUnify ( Expected(..), zapExpectedType, readExpectedType,
- unifyTauTy, subFunTys, unifyListTy, unifyTyConApp,
+ unifyTauTy, subFunTys, unifyTyConApp,
checkSigTyVarsWrt, zapExpectedBranches, tcSubExp, tcGen,
- unifyAppTy )
+ unifyAppTy, zapToListTy, zapToTyConApp )
import TcSimplify ( bindInstsOfLocalFuns )
import Name ( Name )
-import TysWiredIn ( boolTy, parrTyCon, listTyCon )
+import TysWiredIn ( stringTy, boolTy, parrTyCon, listTyCon, mkListTy, mkPArrTy )
+import PrelNames ( bindMName, returnMName, mfixName, thenMName, failMName )
import Id ( idType, mkLocalId )
+import TyCon ( TyCon )
import CoreFVs ( idFreeTyVars )
import VarSet
-import BasicTypes ( RecFlag(..) )
-import Util ( isSingleton, notNull )
+import Util ( isSingleton )
import Outputable
-import SrcLoc ( Located(..), noLoc )
+import SrcLoc ( Located(..) )
import List ( nub )
\end{code}
lift_grhss co_fn (GRHSs grhss binds)
= GRHSs (map (fmap lift_grhs) grhss) binds
where
- lift_grhs (GRHS stmts) = GRHS (map lift_stmt stmts)
-
- lift_stmt (L loc (ResultStmt e)) = L loc (ResultStmt (fmap (co_fn <$>) e))
- lift_stmt stmt = stmt
+ lift_grhs (GRHS stmts rhs) = GRHS stmts (fmap (co_fn <$>) rhs)
-------------
tcGRHSs :: TcMatchCtxt -> GRHSs Name
-- f = \(x::forall a.a->a) -> <stuff>
-- This is a consequence of the fact that tcStmts takes a TcType,
-- not a Expected TcType, a decision we could revisit if necessary
-tcGRHSs ctxt (GRHSs [L loc1 (GRHS [L loc2 (ResultStmt rhs)])] binds) exp_ty
+tcGRHSs ctxt (GRHSs [L loc1 (GRHS [] rhs)] binds) exp_ty
= tcBindsAndThen glueBindsOnGRHSs binds $
mc_body ctxt rhs exp_ty `thenM` \ rhs' ->
- returnM (GRHSs [L loc1 (GRHS [L loc2 (ResultStmt rhs')])] [])
+ returnM (GRHSs [L loc1 (GRHS [] rhs')] [])
tcGRHSs ctxt (GRHSs grhss binds) exp_ty
= tcBindsAndThen glueBindsOnGRHSs binds $
- zapExpectedType exp_ty openTypeKind `thenM` \ exp_ty' ->
- -- Even if there is only one guard, we zap the RHS type to
- -- a monotype. Reason: it makes tcStmts much easier,
- -- and even a one-armed guard has a notional second arm
- let
- stmt_ctxt = SC { sc_what = PatGuard (mc_what ctxt),
- sc_rhs = tcInferRho,
- sc_body = sc_body,
- sc_ty = exp_ty' }
- sc_body body = mc_body ctxt body (Check exp_ty')
-
- tc_grhs (GRHS guarded)
- = tcStmts stmt_ctxt guarded `thenM` \ guarded' ->
- returnM (GRHS guarded')
- in
- mappM (wrapLocM tc_grhs) grhss `thenM` \ grhss' ->
- returnM (GRHSs grhss' [])
+ do { exp_ty' <- zapExpectedType exp_ty openTypeKind
+ -- Even if there is only one guard, we zap the RHS type to
+ -- a monotype. Reason: it makes tcStmts much easier,
+ -- and even a one-armed guard has a notional second arm
+
+ ; let match_ctxt = mc_what ctxt
+ stmt_ctxt = PatGuard match_ctxt
+ tc_grhs (GRHS guards rhs)
+ = do { (guards', rhs')
+ <- tcStmts stmt_ctxt (tcGuardStmt exp_ty') guards $
+ addErrCtxt (grhsCtxt match_ctxt rhs) $
+ tcCheckRho rhs exp_ty'
+ ; return (GRHS guards' rhs') }
+
+ ; grhss' <- mappM (wrapLocM tc_grhs) grhss
+ ; returnM (GRHSs grhss' []) }
\end{code}
\begin{code}
tcDoStmts :: HsStmtContext Name
- -> [LStmt Name] -> ReboundNames Name
- -> TcRhoType -- To keep it simple, we don't have an "expected" type here
- -> TcM ([LStmt TcId], ReboundNames TcId)
-tcDoStmts PArrComp stmts method_names res_ty
- = do { [elt_ty] <- unifyTyConApp parrTyCon res_ty
- ; stmts' <- tcComprehension PArrComp parrTyCon elt_ty stmts
- ; return (stmts', [{- unused -}]) }
-
-tcDoStmts ListComp stmts method_names res_ty
- = unifyListTy res_ty ` thenM` \ elt_ty ->
- tcComprehension ListComp listTyCon elt_ty stmts `thenM` \ stmts' ->
- returnM (stmts', [{- unused -}])
-
-tcDoStmts do_or_mdo stmts method_names res_ty
- = newTyFlexiVarTy (mkArrowKind liftedTypeKind liftedTypeKind) `thenM` \ m_ty ->
- newTyFlexiVarTy liftedTypeKind `thenM` \ elt_ty ->
- unifyTauTy res_ty (mkAppTy m_ty elt_ty) `thenM_`
- let
- ctxt = SC { sc_what = do_or_mdo,
- sc_rhs = \ rhs -> do { (rhs', rhs_ty) <- tcInferRho rhs
- ; rhs_elt_ty <- unifyAppTy m_ty rhs_ty
- ; return (rhs', rhs_elt_ty) },
- sc_body = \ body -> tcCheckRho body res_ty,
- sc_ty = res_ty }
- in
- tcStmts ctxt 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,
- -- not only for typechecker efficiency, but also because otherwise during
- -- simplification we end up with silly stuff like
- -- then = case d of (t,r) -> t
- -- then = then
- -- where the second "then" sees that it already exists in the "available" stuff.
- mapM (tcSyntaxName DoOrigin m_ty) method_names `thenM` \ methods ->
-
- returnM (stmts', methods)
-
-tcComprehension do_or_lc m_tycon elt_ty stmts
- = tcStmts ctxt stmts
- where
- ctxt = SC { sc_what = do_or_lc,
- sc_rhs = \ rhs -> do { (rhs', rhs_ty) <- tcInferRho rhs
- ; [rhs_elt_ty] <- unifyTyConApp m_tycon rhs_ty
- ; return (rhs', rhs_elt_ty) },
- sc_body = \ body -> tcCheckRho body elt_ty, -- Note: no m_tycon here!
- sc_ty = mkTyConApp m_tycon [elt_ty] }
+ -> [LStmt Name]
+ -> LHsExpr Name
+ -> Expected TcRhoType
+ -> TcM (HsExpr TcId) -- Returns a HsDo
+tcDoStmts ListComp stmts body res_ty
+ = do { elt_ty <- zapToListTy res_ty
+ ; (stmts', body') <- tcStmts ListComp (tcLcStmt listTyCon elt_ty) stmts $
+ addErrCtxt (doBodyCtxt ListComp body) $
+ tcCheckRho body elt_ty
+ ; return (HsDo ListComp stmts' body' (mkListTy elt_ty)) }
+
+tcDoStmts PArrComp stmts body res_ty
+ = do { [elt_ty] <- zapToTyConApp parrTyCon res_ty
+ ; (stmts', body') <- tcStmts PArrComp (tcLcStmt parrTyCon elt_ty) stmts $
+ addErrCtxt (doBodyCtxt PArrComp body) $
+ tcCheckRho body elt_ty
+ ; return (HsDo PArrComp stmts' body' (mkPArrTy elt_ty)) }
+
+tcDoStmts DoExpr stmts body res_ty
+ = do { res_ty' <- zapExpectedType res_ty liftedTypeKind
+ ; (m_ty, _) <- unifyAppTy res_ty'
+ ; (stmts', body') <- tcStmts DoExpr (tcDoStmt m_ty res_ty') stmts $
+ addErrCtxt (doBodyCtxt DoExpr body) $
+ tcCheckRho body res_ty'
+ ; return (HsDo DoExpr stmts' body' res_ty') }
+
+tcDoStmts cxt@(MDoExpr _) stmts body res_ty
+ = do { res_ty' <- zapExpectedType res_ty liftedTypeKind
+ ; (m_ty, _) <- unifyAppTy res_ty'
+ ; let tc_rhs rhs = do { (rhs', rhs_ty) <- tcInferRho rhs
+ ; (n_ty, pat_ty) <- unifyAppTy rhs_ty
+ ; unifyTauTy m_ty n_ty
+ ; return (rhs', pat_ty) }
+
+ ; (stmts', body') <- tcStmts cxt (tcMDoStmt res_ty' tc_rhs) stmts $
+ addErrCtxt (doBodyCtxt cxt body) $
+ tcCheckRho body res_ty'
+
+ ; let names = [mfixName, bindMName, thenMName, returnMName, failMName]
+ ; insts <- mapM (newMethodFromName DoOrigin m_ty) names
+ ; return (HsDo (MDoExpr (names `zip` insts)) stmts' body' res_ty') }
+
+tcDoStmts ctxt stmts body res_ty = pprPanic "tcDoStmts" (pprStmtContext ctxt)
\end{code}
%* *
%************************************************************************
-Typechecking statements is rendered a bit tricky by parallel list comprehensions:
-
- [ (g x, h x) | ... ; let g v = ...
- | ... ; let h v = ... ]
-
-It's possible that g,h are overloaded, so we need to feed the LIE from the
-(g x, h x) up through both lots of bindings (so we get the bindInstsOfLocalFuns).
-Similarly if we had an existential pattern match:
-
- data T = forall a. Show a => C a
-
- [ (show x, show y) | ... ; C x <- ...
- | ... ; C y <- ... ]
-
-Then we need the LIE from (show x, show y) to be simplified against
-the bindings for x and y.
-
-It's difficult to do this in parallel, so we rely on the renamer to
-ensure that g,h and x,y don't duplicate, and simply grow the environment.
-So the binders of the first parallel group will be in scope in the second
-group. But that's fine; there's no shadowing to worry about.
-
\begin{code}
-tcStmts ctxt stmts
- = ASSERT( notNull stmts )
- tcStmtsAndThen (:) ctxt stmts (returnM [])
-
-data TcStmtCtxt
- = SC { sc_what :: HsStmtContext Name, -- What kind of thing this is
- sc_rhs :: LHsExpr Name -> TcM (LHsExpr TcId, TcType), -- Type inference for RHS computations
- sc_body :: LHsExpr Name -> TcM (LHsExpr TcId), -- Type checker for return computation
- sc_ty :: TcType } -- Return type; used *only* to check
- -- for escape in existential patterns
- -- We use type *inference* for the RHS computations, becuase of GADTs.
- -- do { pat <- rhs; <rest> }
- -- is rather like
- -- case rhs of { pat -> <rest> }
- -- We do inference on rhs, so that information about its type can be refined
- -- when type-checking the pattern.
-
-tcStmtsAndThen
- :: (LStmt TcId -> thing -> thing) -- Combiner
- -> TcStmtCtxt
+type TcStmtChecker
+ = forall thing. HsStmtContext Name
+ -> Stmt Name
+ -> TcM thing
+ -> TcM (Stmt TcId, thing)
+
+tcStmts :: HsStmtContext Name
+ -> TcStmtChecker -- NB: higher-rank type
-> [LStmt Name]
-> TcM thing
- -> TcM thing
+ -> TcM ([LStmt TcId], thing)
- -- Base case
-tcStmtsAndThen combine ctxt [] thing_inside
- = thing_inside
+-- Note the higher-rank type. stmt_chk is applied at different
+-- types in the equations for tcStmts
-tcStmtsAndThen combine ctxt (stmt:stmts) thing_inside
- = tcStmtAndThen combine ctxt stmt $
- tcStmtsAndThen combine ctxt stmts $
- thing_inside
+tcStmts ctxt stmt_chk [] thing_inside
+ = do { thing <- thing_inside
+ ; return ([], thing) }
- -- LetStmt
-tcStmtAndThen combine ctxt (L _ (LetStmt binds)) thing_inside
- = tcBindsAndThen -- No error context, but a binding group is
- (glue_binds combine) -- rather a large thing for an error context anyway
+-- LetStmts are handled uniformly, regardless of context
+tcStmts ctxt stmt_chk (L loc (LetStmt binds) : stmts) thing_inside
+ = tcBindsAndThen -- No error context, but a binding group is
+ glue_binds -- rather a large thing for an error context anyway
binds
- thing_inside
-
- -- BindStmt
-tcStmtAndThen combine ctxt (L src_loc stmt@(BindStmt pat exp)) thing_inside
- = setSrcSpan src_loc $
- addErrCtxt (stmtCtxt ctxt stmt) $
- do { (exp', pat_ty) <- sc_rhs ctxt exp
- ; ([pat'], thing) <- tcMatchPats [pat] [Check pat_ty] (Check (sc_ty ctxt)) $
- popErrCtxt thing_inside
- ; return (combine (L src_loc (BindStmt pat' exp')) thing) }
-
- -- ExprStmt
-tcStmtAndThen combine ctxt (L src_loc stmt@(ExprStmt exp _)) thing_inside
- = setSrcSpan src_loc (
- addErrCtxt (stmtCtxt ctxt stmt) $
- if isDoExpr (sc_what ctxt)
- then -- do or mdo; the expression is a computation
- sc_rhs ctxt exp `thenM` \ (exp', exp_ty) ->
- returnM (L src_loc (ExprStmt exp' exp_ty))
- else -- List comprehensions, pattern guards; expression is a boolean
- tcCheckRho exp boolTy `thenM` \ exp' ->
- returnM (L src_loc (ExprStmt exp' boolTy))
- ) `thenM` \ stmt' ->
-
- thing_inside `thenM` \ thing ->
- returnM (combine stmt' thing)
-
-
- -- ParStmt
-tcStmtAndThen combine ctxt (L src_loc (ParStmt bndr_stmts_s)) thing_inside
- = loop bndr_stmts_s `thenM` \ (pairs', thing) ->
- returnM (combine (L src_loc (ParStmt pairs')) thing)
+ (tcStmts ctxt stmt_chk stmts thing_inside)
where
- loop [] = thing_inside `thenM` \ thing ->
- returnM ([], thing)
-
- loop ((stmts, bndrs) : pairs)
- = tcStmtsAndThen combine_par ctxt stmts $
- -- Notice we pass on ctxt; the result type is used only
- -- to get escaping type variables for checkExistentialPat
- tcLookupLocalIds bndrs `thenM` \ bndrs' ->
- loop pairs `thenM` \ (pairs', thing) ->
- returnM (([], bndrs') : pairs', thing)
-
- combine_par stmt ((stmts, bndrs) : pairs , thing) = ((stmt:stmts, bndrs) : pairs, thing)
-
- -- RecStmt
-tcStmtAndThen combine ctxt (L src_loc (RecStmt stmts laterNames recNames _)) thing_inside
- = newTyFlexiVarTys (length recNames) liftedTypeKind `thenM` \ recTys ->
- let
- rec_ids = zipWith mkLocalId recNames recTys
- in
- tcExtendIdEnv rec_ids $
- tcStmtsAndThen combine_rec ctxt stmts (
- zipWithM tc_ret recNames recTys `thenM` \ rec_rets ->
- tcLookupLocalIds laterNames `thenM` \ later_ids ->
- returnM ([], (later_ids, rec_rets))
- ) `thenM` \ (stmts', (later_ids, rec_rets)) ->
-
- tcExtendIdEnv later_ids $
- -- NB: The rec_ids for the recursive things
- -- already scope over this part. This binding may shadow
- -- some of them with polymorphic things with the same Name
- -- (see note [RecStmt] in HsExpr)
- getLIE thing_inside `thenM` \ (thing, lie) ->
- bindInstsOfLocalFuns lie later_ids `thenM` \ lie_binds ->
+ glue_binds binds (stmts, thing) = (L loc (LetStmt [binds]) : stmts, thing)
+
+
+-- For the vanilla case, handle the location-setting part
+tcStmts ctxt stmt_chk (L loc stmt : stmts) thing_inside
+ = do { (stmt', (stmts', thing)) <-
+ setSrcSpan loc $
+ addErrCtxt (stmtCtxt ctxt stmt) $
+ stmt_chk ctxt stmt $
+ popErrCtxt $
+ tcStmts ctxt stmt_chk stmts $
+ thing_inside
+ ; return (L loc stmt' : stmts', thing) }
+
+--------------------------------
+-- Pattern guards
+tcGuardStmt :: TcType -> TcStmtChecker
+tcGuardStmt res_ty ctxt (ExprStmt guard _ _) thing_inside
+ = do { guard' <- tcCheckRho guard boolTy
+ ; thing <- thing_inside
+ ; return (ExprStmt guard' noSyntaxExpr boolTy, thing) }
+
+tcGuardStmt res_ty ctxt (BindStmt pat rhs _ _) thing_inside
+ = do { (rhs', rhs_ty) <- tcInferRho rhs
+ ; (pat', thing) <- tcBindPat pat rhs_ty res_ty thing_inside
+ ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
+
+tcGuardStmt res_ty ctxt stmt thing_inside
+ = pprPanic "tcGuardStmt: unexpected Stmt" (ppr stmt)
+
+
+--------------------------------
+-- List comprehensions and PArrays
+
+tcLcStmt :: TyCon -- The list/Parray type constructor ([] or PArray)
+ -> TcType -- The element type of the list or PArray
+ -> TcStmtChecker
+
+-- A generator, pat <- rhs
+tcLcStmt m_tc elt_ty ctxt (BindStmt pat rhs _ _) thing_inside
+ = do { (rhs', rhs_ty) <- tcInferRho rhs
+ ; [pat_ty] <- unifyTyConApp m_tc rhs_ty
+ ; (pat', thing) <- tcBindPat pat pat_ty elt_ty thing_inside
+ ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
+
+-- A boolean guard
+tcLcStmt m_tc elt_ty ctxt (ExprStmt rhs _ _) thing_inside
+ = do { rhs' <- tcCheckRho rhs boolTy
+ ; thing <- thing_inside
+ ; return (ExprStmt rhs' noSyntaxExpr boolTy, thing) }
+
+-- A parallel set of comprehensions
+-- [ (g x, h x) | ... ; let g v = ...
+-- | ... ; let h v = ... ]
+--
+-- It's possible that g,h are overloaded, so we need to feed the LIE from the
+-- (g x, h x) up through both lots of bindings (so we get the bindInstsOfLocalFuns).
+-- Similarly if we had an existential pattern match:
+--
+-- data T = forall a. Show a => C a
+--
+-- [ (show x, show y) | ... ; C x <- ...
+-- | ... ; C y <- ... ]
+--
+-- Then we need the LIE from (show x, show y) to be simplified against
+-- the bindings for x and y.
+--
+-- It's difficult to do this in parallel, so we rely on the renamer to
+-- ensure that g,h and x,y don't duplicate, and simply grow the environment.
+-- So the binders of the first parallel group will be in scope in the second
+-- group. But that's fine; there's no shadowing to worry about.
+
+tcLcStmt m_tc elt_ty ctxt (ParStmt bndr_stmts_s) thing_inside
+ = do { (pairs', thing) <- loop bndr_stmts_s
+ ; return (ParStmt pairs', thing) }
+ where
+ -- loop :: [([LStmt Name], [Name])] -> TcM ([([LStmt TcId], [TcId])], thing)
+ loop [] = do { thing <- thing_inside
+ ; return ([], thing) }
+
+ loop ((stmts, names) : pairs)
+ = do { (stmts', (ids, pairs', thing))
+ <- tcStmts ctxt (tcLcStmt m_tc elt_ty) stmts $
+ do { ids <- tcLookupLocalIds names
+ ; (pairs', thing) <- loop pairs
+ ; return (ids, pairs', thing) }
+ ; return ( (stmts', ids) : pairs', thing ) }
+
+tcLcStmt m_tc elt_ty ctxt stmt thing_inside
+ = pprPanic "tcLcStmt: unexpected Stmt" (ppr stmt)
+
+--------------------------------
+-- Do-notation
+-- The main excitement here is dealing with rebindable syntax
+
+tcDoStmt :: TcType -- Monad type, m
+ -> TcType -- Result type, m b
+ -> TcStmtChecker
+ -- BindStmt
+tcDoStmt m_ty res_ty ctxt (BindStmt pat rhs bind_op fail_op) thing_inside
+ = do { -- Deal with rebindable syntax; (>>=) :: m a -> (a -> m b) -> m b
+ ; (rhs', rhs_ty) <- tcInferRho rhs
+ -- We should use type *inference* for the RHS computations, becuase of GADTs.
+ -- do { pat <- rhs; <rest> }
+ -- is rather like
+ -- case rhs of { pat -> <rest> }
+ -- We do inference on rhs, so that information about its type can be refined
+ -- when type-checking the pattern.
+
+ ; (n_ty, pat_ty) <- unifyAppTy rhs_ty
+ ; unifyTauTy m_ty n_ty
+ ; let bind_ty = mkFunTys [rhs_ty, mkFunTy pat_ty res_ty] res_ty
+
+ ; (pat', thing) <- tcBindPat pat pat_ty res_ty thing_inside
+
+ -- Rebindable syntax stuff
+ ; bind_op' <- tcSyntaxOp DoOrigin bind_op bind_ty
+ -- If (but only if) the pattern can fail,
+ -- typecheck the 'fail' operator
+ ; fail_op' <- if isIrrefutableHsPat pat'
+ then return noSyntaxExpr
+ else tcSyntaxOp DoOrigin fail_op (mkFunTy stringTy res_ty)
+ ; return (BindStmt pat' rhs' bind_op' fail_op', thing) }
+
+
+tcDoStmt m_ty res_ty ctxt (ExprStmt rhs then_op _) thing_inside
+ = do { -- Deal with rebindable syntax; (>>) :: m a -> m b -> m b
+ a_ty <- newTyFlexiVarTy liftedTypeKind
+ ; let rhs_ty = mkAppTy m_ty a_ty
+ then_ty = mkFunTys [rhs_ty, res_ty] res_ty
+ ; then_op' <- tcSyntaxOp DoOrigin then_op then_ty
+ ; rhs' <- tcCheckSigma rhs rhs_ty
+ ; thing <- thing_inside
+ ; return (ExprStmt rhs' then_op' rhs_ty, thing) }
+
+tcDoStmt m_ty res_ty ctxt stmt thing_inside
+ = pprPanic "tcDoStmt: unexpected Stmt" (ppr stmt)
+
+--------------------------------
+-- Mdo-notation
+-- The distinctive features here are
+-- (a) RecStmts, and
+-- (b) no rebindable syntax
+
+tcMDoStmt :: TcType -- Result type, m b
+ -> (LHsExpr Name -> TcM (LHsExpr TcId, TcType)) -- RHS inference
+ -> TcStmtChecker
+tcMDoStmt res_ty tc_rhs ctxt (BindStmt pat rhs bind_op fail_op) thing_inside
+ = do { (rhs', pat_ty) <- tc_rhs rhs
+ ; (pat', thing) <- tcBindPat pat pat_ty res_ty thing_inside
+ ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
+
+tcMDoStmt res_ty tc_rhs ctxt (ExprStmt rhs then_op _) thing_inside
+ = do { (rhs', elt_ty) <- tc_rhs rhs
+ ; thing <- thing_inside
+ ; return (ExprStmt rhs' noSyntaxExpr elt_ty, thing) }
+
+tcMDoStmt res_ty tc_rhs ctxt (RecStmt stmts laterNames recNames _ _) thing_inside
+ = do { rec_tys <- newTyFlexiVarTys (length recNames) liftedTypeKind
+ ; let rec_ids = zipWith mkLocalId recNames rec_tys
+ ; tcExtendIdEnv rec_ids $ do
+ { (stmts', (later_ids, rec_rets))
+ <- tcStmts ctxt (tcMDoStmt res_ty tc_rhs) stmts $
+ -- ToDo: res_ty not really right
+ do { rec_rets <- zipWithM tc_ret recNames rec_tys
+ ; later_ids <- tcLookupLocalIds laterNames
+ ; return (later_ids, rec_rets) }
+
+ ; (thing,lie) <- tcExtendIdEnv later_ids (getLIE thing_inside)
+ -- NB: The rec_ids for the recursive things
+ -- already scope over this part. This binding may shadow
+ -- some of them with polymorphic things with the same Name
+ -- (see note [RecStmt] in HsExpr)
+ ; lie_binds <- bindInstsOfLocalFuns lie later_ids
- returnM (combine (L src_loc (RecStmt stmts' later_ids rec_ids rec_rets)) $
- combine (L src_loc (LetStmt [HsBindGroup lie_binds [] Recursive])) $
- thing)
+ ; return (RecStmt stmts' later_ids rec_ids rec_rets lie_binds, thing)
+ }}
where
- combine_rec stmt (stmts, thing) = (stmt:stmts, thing)
-
-- Unify the types of the "final" Ids with those of "knot-tied" Ids
tc_ret rec_name mono_ty
= tcLookupId rec_name `thenM` \ poly_id ->
-- poly_id may have a polymorphic type
-- but mono_ty is just a monomorphic type variable
tcSubExp (Check mono_ty) (idType poly_id) `thenM` \ co_fn ->
- returnM (L src_loc (co_fn <$> HsVar poly_id))
-
- -- Result statements
-tcStmtAndThen combine ctxt (L src_loc stmt@(ResultStmt exp)) thing_inside
- = addErrCtxt (stmtCtxt ctxt stmt) (sc_body ctxt exp) `thenM` \ exp' ->
- thing_inside `thenM` \ thing ->
- returnM (combine (L src_loc (ResultStmt exp')) thing)
-
-
-------------------------------
-glue_binds combine binds thing = combine (noLoc (LetStmt [binds])) thing
- -- ToDo: fix the noLoc
+ returnM (co_fn <$> HsVar poly_id)
+
+tcMDoStmt res_ty tc_rhs ctxt stmt thing_inside
+ = pprPanic "tcMDoStmt: unexpected Stmt" (ppr stmt)
+
+-----------------
+tcBindPat :: LPat Name -> TcType
+ -> TcType -- Result type; used only to check existential escape
+ -> TcM a
+ -> TcM (LPat TcId, a)
+tcBindPat pat pat_ty res_ty thing_inside
+ = do { ([pat'],thing) <- tcMatchPats [pat] [Check pat_ty]
+ (Check res_ty) thing_inside
+ ; return (pat', thing) }
\end{code}
varyingArgsErr name matches
= sep [ptext SLIT("Varying number of arguments for function"), quotes (ppr name)]
-matchCtxt ctxt match = hang (ptext SLIT("In") <+> pprMatchContext ctxt <> colon)
- 4 (pprMatch ctxt match)
+matchCtxt ctxt match = hang (ptext SLIT("In") <+> pprMatchContext ctxt <> colon)
+ 4 (pprMatch ctxt match)
+
+grhsCtxt ctxt rhs = hang (ptext SLIT("In") <+> pprMatchRhsContext ctxt <> colon)
+ 4 (ppr rhs)
+
+doBodyCtxt :: HsStmtContext Name -> LHsExpr Name -> SDoc
+doBodyCtxt ctxt body = hang (ptext SLIT("In the result of") <+> pprStmtContext ctxt <> colon)
+ 4 (ppr body)
-stmtCtxt ctxt stmt = hang (ptext SLIT("In") <+> pp_ctxt (sc_what ctxt) <> colon) 4 (ppr stmt)
- where
- pp_ctxt = case stmt of
- ResultStmt _ -> pprStmtResultContext
- other -> pprStmtContext
+stmtCtxt ctxt stmt = hang (ptext SLIT("In") <+> pprStmtContext ctxt <> colon)
+ 4 (ppr stmt)
sigPatCtxt bound_ids bound_tvs tys tidy_env
= -- tys is (body_ty : pat_tys)
#include "HsVersions.h"
-import HsSyn ( Pat(..), LPat, HsConDetails(..), HsLit(..), HsOverLit(..),
- HsExpr(..), LHsBinds, emptyLHsBinds, isEmptyLHsBinds )
-import HsUtils
+import {-# SOURCE #-} TcExpr( tcSyntaxOp )
+import HsSyn ( Pat(..), LPat, HsConDetails(..),
+ LHsBinds, emptyLHsBinds, isEmptyLHsBinds )
import TcHsSyn ( TcId, hsLitType )
import TcRnMonad
-import Inst ( InstOrigin(..),
- newMethodFromName, newOverloadedLit, newDicts,
- instToId, tcInstStupidTheta, tcSyntaxName
+import Inst ( InstOrigin(..), tcOverloadedLit,
+ newDicts, instToId, tcInstStupidTheta
)
import Id ( Id, idType, mkLocalId )
import Var ( tyVarName )
tcLookupClass, tcLookupDataCon, tcLookupId )
import TcMType ( newTyFlexiVarTy, arityErr, tcSkolTyVars, readMetaTyVar )
import TcType ( TcType, TcTyVar, TcSigmaType, TcTauType, zipTopTvSubst,
- SkolemInfo(PatSkol), isSkolemTyVar, isMetaTyVar, pprTcTyVar,
+ SkolemInfo(PatSkol), isMetaTyVar, pprTcTyVar,
TvSubst, mkOpenTvSubst, substTyVar, substTy, MetaDetails(..),
- mkTyVarTys, mkClassPred, mkTyConApp, isOverloadedTy )
+ mkTyVarTys, mkClassPred, mkTyConApp, isOverloadedTy,
+ mkFunTy, mkFunTys )
import VarEnv ( mkVarEnv ) -- ugly
import Kind ( argTypeKind, liftedTypeKind )
import TcUnify ( tcSubPat, Expected(..), zapExpectedType,
zapExpectedTo, zapToListTy, zapToTyConApp )
import TcHsType ( UserTypeCtxt(..), TcSigInfo( sig_tau ), TcSigFun, tcHsPatSigType )
-import TysWiredIn ( stringTy, parrTyCon, tupleTyCon )
+import TysWiredIn ( boolTy, parrTyCon, tupleTyCon )
import Unify ( MaybeErr(..), gadtRefineTys, BindFlag(..) )
import Type ( substTys, substTheta )
import StaticFlags ( opt_IrrefutableTuples )
import TyCon ( TyCon )
import DataCon ( DataCon, dataConTyCon, isVanillaDataCon, dataConInstOrigArgTys,
dataConFieldLabels, dataConSourceArity, dataConSig )
-import PrelNames ( eqStringName, eqName, geName, negateName, minusName,
- integralClassName )
+import PrelNames ( integralClassName )
import BasicTypes ( isBoxed )
import SrcLoc ( Located(..), SrcSpan, noLoc, unLoc )
import Maybes ( catMaybes )
; (pat', tvs, res) <- tcConPat ctxt con_span data_con tycon ty_args arg_pats thing_inside
; return (pat', tvs, res) }
-
------------------------
-- Literal patterns
-tc_pat ctxt pat@(LitPat lit@(HsString _)) pat_ty thing_inside
- = do { -- Strings are mapped to NPatOuts, which have a guard expression
- zapExpectedTo pat_ty stringTy
- ; eq_id <- tcLookupId eqStringName
- ; res <- thing_inside
- ; returnM (NPatOut lit stringTy (nlHsVar eq_id `HsApp` nlHsLit lit), [], res) }
-
tc_pat ctxt (LitPat simple_lit) pat_ty thing_inside
= do { -- All other simple lits
zapExpectedTo pat_ty (hsLitType simple_lit)
------------------------
-- Overloaded patterns: n, and n+k
-tc_pat ctxt pat@(NPatIn over_lit mb_neg) pat_ty thing_inside
+tc_pat ctxt pat@(NPat over_lit mb_neg eq _) pat_ty thing_inside
= do { pat_ty' <- zapExpectedType pat_ty liftedTypeKind
- ; let origin = LiteralOrigin over_lit
- ; pos_lit_expr <- newOverloadedLit origin over_lit pat_ty'
- ; eq <- newMethodFromName origin pat_ty' eqName
- ; lit_expr <- case mb_neg of
- Nothing -> returnM pos_lit_expr -- Positive literal
+ ; let orig = LiteralOrigin over_lit
+ ; lit' <- tcOverloadedLit orig over_lit pat_ty'
+ ; eq' <- tcSyntaxOp orig eq (mkFunTys [pat_ty', pat_ty'] boolTy)
+ ; mb_neg' <- case mb_neg of
+ Nothing -> return Nothing -- Positive literal
Just neg -> -- Negative literal
-- The 'negate' is re-mappable syntax
- do { (_, neg_expr) <- tcSyntaxName origin pat_ty'
- (negateName, HsVar neg)
- ; returnM (mkHsApp (noLoc neg_expr) pos_lit_expr) }
-
- ; let -- The literal in an NPatIn is always positive...
- -- But in NPatOut, the literal is used to find identical patterns
- -- so we must negate the literal when necessary!
- lit' = case (over_lit, mb_neg) of
- (HsIntegral i _, Nothing) -> HsInteger i pat_ty'
- (HsIntegral i _, Just _) -> HsInteger (-i) pat_ty'
- (HsFractional f _, Nothing) -> HsRat f pat_ty'
- (HsFractional f _, Just _) -> HsRat (-f) pat_ty'
-
+ do { neg' <- tcSyntaxOp orig neg (mkFunTy pat_ty' pat_ty')
+ ; return (Just neg') }
; res <- thing_inside
- ; returnM (NPatOut lit' pat_ty' (HsApp (nlHsVar eq) lit_expr), [], res) }
+ ; returnM (NPat lit' mb_neg' eq' pat_ty', [], res) }
-tc_pat ctxt pat@(NPlusKPatIn (L nm_loc name) lit@(HsIntegral i _) minus_name) pat_ty thing_inside
+tc_pat ctxt pat@(NPlusKPat (L nm_loc name) lit ge minus) pat_ty thing_inside
= do { bndr_id <- setSrcSpan nm_loc (tcPatBndr ctxt name pat_ty)
; let pat_ty' = idType bndr_id
- origin = LiteralOrigin lit
- ; over_lit_expr <- newOverloadedLit origin lit pat_ty'
- ; ge <- newMethodFromName origin pat_ty' geName
+ orig = LiteralOrigin lit
+ ; lit' <- tcOverloadedLit orig lit pat_ty'
- -- The '-' part is re-mappable syntax
- ; (_, minus_expr) <- tcSyntaxName origin pat_ty' (minusName, HsVar minus_name)
+ -- The '>=' and '-' parts are re-mappable syntax
+ ; ge' <- tcSyntaxOp orig ge (mkFunTys [pat_ty', pat_ty'] boolTy)
+ ; minus' <- tcSyntaxOp orig minus (mkFunTys [pat_ty', pat_ty'] pat_ty')
-- The Report says that n+k patterns must be in Integral
-- We may not want this when using re-mappable syntax, though (ToDo?)
; icls <- tcLookupClass integralClassName
- ; dicts <- newDicts origin [mkClassPred icls [pat_ty']]
+ ; dicts <- newDicts orig [mkClassPred icls [pat_ty']]
; extendLIEs dicts
; res <- tcExtendIdEnv1 name bndr_id thing_inside
- ; returnM (NPlusKPatOut (L nm_loc bndr_id) i
- (SectionR (nlHsVar ge) over_lit_expr)
- (SectionR (noLoc minus_expr) over_lit_expr),
- [], res) }
+ ; returnM (NPlusKPat (L nm_loc bndr_id) lit' ge' minus', [], res) }
\end{code}
import ErrUtils ( Messages, mkDumpDoc, showPass )
import Id ( mkExportedLocalId, isLocalId, idName, idType )
import Var ( Var )
-import VarEnv ( varEnvElts )
import Module ( Module, ModuleEnv, mkModule, moduleEnvElts, lookupModuleEnv )
import OccName ( mkVarOcc )
import Name ( Name, isExternalName, getSrcLoc, getOccName, isWiredInName )
import HsSyn ( HsStmtContext(..), Stmt(..), HsExpr(..), HsBindGroup(..),
LStmt, LHsExpr, LHsType, mkMatchGroup,
collectStmtsBinders, mkSimpleMatch,
- nlLetStmt, nlExprStmt, nlBindStmt, nlResultStmt, nlVarPat )
+ mkExprStmt, mkBindStmt, nlVarPat )
import RdrName ( GlobalRdrEnv, mkGlobalRdrEnv, GlobalRdrElt(..),
Provenance(..), ImportSpec(..),
lookupLocalRdrEnv, extendLocalRdrEnv )
isUnLiftedType, tyClsNamesOfDFunHead )
import TcEnv ( tcLookupTyCon, tcLookupId, tcLookupGlobal )
import RnTypes ( rnLHsType )
-import Inst ( tcStdSyntaxName, tcGetInstEnvs )
+import Inst ( tcGetInstEnvs )
import InstEnv ( DFunId, classInstances, instEnvElts )
import RnExpr ( rnStmts, rnLExpr )
import RnNames ( exportsToAvails )
\begin{code}
---------------------------
tcUserStmt :: LStmt Name -> TcM ([Id], LHsExpr Id)
-tcUserStmt (L _ (ExprStmt expr _))
+tcUserStmt (L loc (ExprStmt expr _))
= newUnique `thenM` \ uniq ->
let
fresh_it = itName uniq
in
tryTcLIE_ (do { -- Try this if the other fails
traceTc (text "tcs 1b") ;
- tc_stmts [
- nlLetStmt [HsBindGroup (unitBag the_bind) [] NonRecursive],
- nlExprStmt (nlHsApp (nlHsVar printName)
- (nlHsVar fresh_it))
- ] })
+ tc_stmts (map (L loc) [
+ LetStmt [HsBindGroup (unitBag the_bind) [] NonRecursive],
+ mkExprStmt (nlHsApp (nlHsVar printName) (nlHsVar fresh_it))
+ ]) })
(do { -- Try this first
traceTc (text "tcs 1a") ;
- tc_stmts [nlBindStmt (nlVarPat fresh_it) expr] })
+ tc_stmts [L loc (mkBindStmt (nlVarPat fresh_it) expr)] })
tcUserStmt stmt = tc_stmts [stmt]
---------------------------
+tc_stmts :: [Stmt RdrName] ->
tc_stmts stmts
= do { ioTyCon <- tcLookupTyCon ioTyConName ;
let {
names = map unLoc (collectStmtsBinders stmts) ;
stmt_ctxt = SC { sc_what = DoExpr,
- sc_rhs = infer_rhs,
+ sc_bind = infer_rhs,
+ sc_expr = infer_rhs,
sc_body = check_body,
sc_ty = ret_ty } ;
- infer_rhs rhs = do { (rhs', rhs_ty) <- tcInferRho rhs
- ; [pat_ty] <- unifyTyConApp ioTyCon rhs_ty
- ; return (rhs', pat_ty) } ;
+ infer_rhs _bind_op rhs
+ = do { (rhs', rhs_ty) <- tcInferRho rhs
+ ; [pat_ty] <- unifyTyConApp ioTyCon rhs_ty
+ ; return (noSyntaxExpr, rhs', pat_ty) } ;
+
check_body body = tcCheckRho body io_ret_ty ;
-- mk_return builds the expression
-- OK, we're ready to typecheck the stmts
traceTc (text "tcs 2") ;
((ids, tc_expr), lie) <- getLIE $ do {
- (ids, tc_stmts) <- tcStmtsAndThen combine stmt_ctxt stmts $
+ (tc_stmts, ids) <- tcStmtsAndThen combine stmt_ctxt stmts $
do {
-- Look up the names right in the middle,
-- where they will all be in scope
ids <- mappM tcLookupId names ;
- ret_id <- tcLookupId returnIOName ; -- return @ IO
- return (ids, [nlResultStmt (mk_return ret_id ids)]) } ;
+ return ids } ;
- io_ids <- mappM (tcStdSyntaxName DoOrigin io_ty) monadNames ;
- return (ids, noLoc (HsDo DoExpr tc_stmts io_ids io_ret_ty))
+ ret_id <- tcLookupId returnIOName ; -- return @ IO
+ return (ids, noLoc (HsDo DoExpr tc_stmts (mk_return ret_id ids) io_ret_ty))
} ;
-- Simplify the context right here, so that we fail
| LitInst
Name
- HsOverLit -- The literal from the occurrence site
- -- INVARIANT: never a rebindable-syntax literal
- -- Reason: tcSyntaxName does unification, and we
- -- don't want to deal with that during tcSimplify
+ (HsOverLit Name) -- The literal from the occurrence site
+ -- INVARIANT: never a rebindable-syntax literal
+ -- Reason: tcSyntaxName does unification, and we
+ -- don't want to deal with that during tcSimplify,
+ -- when resolving LitInsts
TcType -- The type at which the literal is used
InstLoc
\end{code}
| IPOccOrigin (IPName Name) -- Occurrence of an implicit parameter
- | LiteralOrigin HsOverLit -- Occurrence of a literal
+ | LiteralOrigin (HsOverLit Name) -- Occurrence of a literal
| ArithSeqOrigin (ArithSeqInfo Name) -- [x..], [x..y] etc
| PArrSeqOrigin (ArithSeqInfo Name) -- [:x..y:] and [:x,y..z:]
import Type ( predTypeRep )
import HscTypes ( TyThing(..) )
import TyCon ( TyCon, ArgVrcs, tyConArity, tyConDataCons, tyConTyVars,
- getSynTyConDefn, isSynTyCon, isAlgTyCon, isHiBootTyCon,
+ getSynTyConDefn, isSynTyCon, isAlgTyCon,
tyConName, isNewTyCon, isProductTyCon, tyConArgVrcs, newTyConRhs )
import Class ( classTyCon )
import DataCon ( dataConOrigArgTys )
-- Again, newtypes are opaque
tcEqType, tcEqTypes, tcEqPred, tcCmpType, tcCmpTypes, tcCmpPred, tcEqTypeX,
isSigmaTy, isOverloadedTy,
- isDoubleTy, isFloatTy, isIntTy,
+ isDoubleTy, isFloatTy, isIntTy, isStringTy,
isIntegerTy, isAddrTy, isBoolTy, isUnitTy,
isTauTy, tcIsTyVarTy, tcIsForAllTy,
\begin{code}
module TcUnify (
-- Full-blown subsumption
- tcSubPat, tcSubExp, tcGen,
+ tcSubPat, tcSubExp, tcSub, tcGen,
checkSigTyVars, checkSigTyVarsWrt, bleatEscapedTvs, sigCtxt,
-- Various unifications
tidyOpenType, tidyOpenTypes, tidyOpenTyVar, tidyOpenTyVars,
pprType, tidySkolemTyVar, isSkolemTyVar )
import Kind ( Kind(..), SimpleKind, KindVar, isArgTypeKind,
- openTypeKind, liftedTypeKind, mkArrowKind, kindFunResult,
+ openTypeKind, liftedTypeKind, mkArrowKind,
isOpenTypeKind, argTypeKind, isLiftedTypeKind, isUnliftedTypeKind,
isSubKind, pprKind, splitKindFunTys )
import Inst ( newDicts, instToId, tcInstCall )
unify_tc_app use_refinement tc ty = unify_tc_app_help tc ty
-----------
unify_tc_app_help tc ty -- Revert to ordinary unification
= do { (tc_app, arg_tys) <- newTyConApp tc
; if not (isTauTy ty) then -- Can happen if we call zapToTyConApp tc (forall a. ty)
----------------------
-unifyAppTy :: TcType -- Expected type function: m
- -> TcType -- Type to split: m a
- -> TcM TcType -- Type arg: a
-unifyAppTy tc ty = unify_app_ty True tc ty
+unifyAppTy :: TcType -- Type to split: m a
+ -> TcM (TcType, TcType) -- (m,a)
+-- Assumes (m:*->*)
+
+unifyAppTy ty = unify_app_ty True ty
-unify_app_ty use tc (NoteTy _ ty) = unify_app_ty use tc ty
+unify_app_ty use (NoteTy _ ty) = unify_app_ty use ty
-unify_app_ty use tc ty@(TyVarTy tyvar)
+unify_app_ty use ty@(TyVarTy tyvar)
= do { details <- condLookupTcTyVar use tyvar
; case details of
- IndirectTv use' ty' -> unify_app_ty use' tc ty'
- other -> unify_app_ty_help tc ty
+ IndirectTv use' ty' -> unify_app_ty use' ty'
+ other -> unify_app_ty_help ty
}
-unify_app_ty use tc ty
+unify_app_ty use ty
| Just (fun_ty, arg_ty) <- tcSplitAppTy_maybe ty
- = do { unifyTauTy tc fun_ty
- ; wobblify use arg_ty }
+ = do { fun' <- wobblify use fun_ty
+ ; arg' <- wobblify use arg_ty
+ ; return (fun', arg') }
- | otherwise = unify_app_ty_help tc ty
+ | otherwise = unify_app_ty_help ty
-unify_app_ty_help tc ty -- Revert to ordinary unification
- = do { arg_ty <- newTyFlexiVarTy (kindFunResult (typeKind tc))
- ; unifyTauTy (mkAppTy tc arg_ty) ty
- ; return arg_ty }
+unify_app_ty_help ty -- Revert to ordinary unification
+ = do { fun_ty <- newTyFlexiVarTy (mkArrowKind liftedTypeKind liftedTypeKind)
+ ; arg_ty <- newTyFlexiVarTy liftedTypeKind
+ ; unifyTauTy (mkAppTy fun_ty arg_ty) ty
+ ; return (fun_ty, arg_ty) }
----------------------
-- Standard combinators, specialised
returnM, thenM, thenM_, failM,
- mappM, mappM_, sequenceM, foldlM,
+ mappM, mappM_, mapSndM, sequenceM, foldlM,
mapAndUnzipM, mapAndUnzip3M,
checkM, ifM, zipWithM, zipWithM_,
mappM :: (a -> IOEnv env b) -> [a] -> IOEnv env [b]
mappM_ :: (a -> IOEnv env b) -> [a] -> IOEnv env ()
+mapSndM :: (b -> IOEnv env c) -> [(a,b)] -> IOEnv env [(a,c)]
-- Funny names to avoid clash with Prelude
sequenceM :: [IOEnv env a] -> IOEnv env [a]
foldlM :: (a -> b -> IOEnv env a) -> a -> [b] -> IOEnv env a
mappM f [] = return []
mappM f (x:xs) = do { r <- f x; rs <- mappM f xs; return (r:rs) }
+mapSndM f [] = return []
+mapSndM f ((a,b):xs) = do { c <- f b; rs <- mapSndM f xs; return ((a,c):rs) }
+
mappM_ f [] = return ()
mappM_ f (x:xs) = f x >> mappM_ f xs
-- general list processing
zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal,
zipLazy, stretchZipWith,
+ mapFst, mapSnd,
mapAndUnzip, mapAndUnzip3,
nOfThem, filterOut,
lengthExceeds, lengthIs, lengthAtLeast, listLengthCmp, atLength,
\begin{code}
+mapFst :: (a->c) -> [(a,b)] -> [(c,b)]
+mapSnd :: (b->c) -> [(a,b)] -> [(a,c)]
+
+mapFst f xys = [(f x, y) | (x,y) <- xys]
+mapSnd f xys = [(x, f y) | (x,y) <- xys]
+
mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c])
mapAndUnzip f [] = ([],[])
projects / ghc-hetmet.git / commitdiff