TcStmt, TcArithSeqInfo, TcRecordBinds,
TcHsModule, TcDictBinds,
TcForeignDecl,
+ TcCmd, TcCmdTop,
TypecheckedHsBinds, TypecheckedRuleDecl,
TypecheckedMonoBinds, TypecheckedPat,
TypecheckedGRHSs, TypecheckedGRHS,
TypecheckedRecordBinds, TypecheckedDictBinds,
TypecheckedMatchContext, TypecheckedCoreBind,
+ TypecheckedHsCmd, TypecheckedHsCmdTop,
mkHsTyApp, mkHsDictApp, mkHsConApp,
mkHsTyLam, mkHsDictLam, mkHsLet,
hsLitType, hsPatType,
+ -- Coercions
+ Coercion, ExprCoFn, PatCoFn,
+ (<$>), (<.>), mkCoercion,
+ idCoercion, isIdCoercion,
+
-- re-exported from TcMonad
TcId, TcIdSet,
import TyCon ( mkPrimTyCon, tyConKind )
import PrimRep ( PrimRep(VoidRep) )
import CoreSyn ( CoreExpr )
-import Name ( getOccName, mkInternalName, mkDerivedTyConOcc )
+import Name ( Name, getOccName, mkInternalName, mkDerivedTyConOcc )
import Var ( isId, isLocalVar, tyVarKind )
import VarSet
import VarEnv
import BasicTypes ( RecFlag(..), Boxity(..), IPName(..), ipNameName, mapIPName )
import Maybes ( orElse )
+import Maybe ( isNothing )
import Unique ( Uniquable(..) )
import SrcLoc ( noSrcLoc )
import Bag
type TcHsModule = HsModule TcId
type TcForeignDecl = ForeignDecl TcId
type TcRuleDecl = RuleDecl TcId
+type TcCmd = HsCmd TcId
+type TcCmdTop = HsCmdTop TcId
type TypecheckedPat = OutPat Id
type TypecheckedMonoBinds = MonoBinds Id
type TypecheckedArithSeqInfo = ArithSeqInfo Id
type TypecheckedStmt = Stmt Id
type TypecheckedMatch = Match Id
-type TypecheckedMatchContext = HsMatchContext Id
type TypecheckedGRHSs = GRHSs Id
type TypecheckedGRHS = GRHS Id
type TypecheckedRecordBinds = HsRecordBinds Id
type TypecheckedForeignDecl = ForeignDecl Id
type TypecheckedRuleDecl = RuleDecl Id
type TypecheckedCoreBind = (Id, CoreExpr)
+type TypecheckedHsCmd = HsCmd Id
+type TypecheckedHsCmdTop = HsCmdTop Id
+
+type TypecheckedMatchContext = HsMatchContext Name -- Keeps consistency with
+ -- HsDo arg StmtContext
\end{code}
\begin{code}
hsLitType (HsLitLit _ ty) = ty
\end{code}
+%************************************************************************
+%* *
+\subsection{Coercion functions}
+%* *
+%************************************************************************
+
\begin{code}
--- zonkId is used *during* typechecking just to zonk the Id's type
-zonkId :: TcId -> TcM TcId
-zonkId id
- = zonkTcType (idType id) `thenM` \ ty' ->
- returnM (setIdType id ty')
+type Coercion a = Maybe (a -> a)
+ -- Nothing => identity fn
+
+type ExprCoFn = Coercion TypecheckedHsExpr
+type PatCoFn = Coercion TcPat
+
+(<.>) :: Coercion a -> Coercion a -> Coercion a -- Composition
+Nothing <.> Nothing = Nothing
+Nothing <.> Just f = Just f
+Just f <.> Nothing = Just f
+Just f1 <.> Just f2 = Just (f1 . f2)
+
+(<$>) :: Coercion a -> a -> a
+Just f <$> e = f e
+Nothing <$> e = e
+
+mkCoercion :: (a -> a) -> Coercion a
+mkCoercion f = Just f
+
+idCoercion :: Coercion a
+idCoercion = Nothing
+
+isIdCoercion :: Coercion a -> Bool
+isIdCoercion = isNothing
\end{code}
%* *
%************************************************************************
-This zonking pass runs over the bindings
+\begin{code}
+-- zonkId is used *during* typechecking just to zonk the Id's type
+zonkId :: TcId -> TcM TcId
+zonkId id
+ = zonkTcType (idType id) `thenM` \ ty' ->
+ returnM (setIdType id ty')
+\end{code}
+
+The rest of the zonking is done *after* typechecking.
+The main zonking pass runs over the bindings
a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc
b) convert unbound TcTyVar to Void
zonkMonoBinds env1 bind `thenM` \ (new_bind, new_ids) ->
returnM (env1, new_bind, new_ids)
) `thenM` \ (env1, new_bind, _) ->
- returnM (env1, mkMonoBind new_bind [] is_rec)
+ returnM (env1, mkMonoBind is_rec new_bind)
+
+zonkBinds env (IPBinds binds is_with)
+ = mappM zonk_ip_bind binds `thenM` \ new_binds ->
+ let
+ env1 = extendZonkEnv env (map (ipNameName . fst) new_binds)
+ in
+ returnM (env1, IPBinds new_binds is_with)
+ where
+ zonk_ip_bind (n, e)
+ = mapIPNameTc (zonkIdBndr env) n `thenM` \ n' ->
+ zonkExpr env e `thenM` \ e' ->
+ returnM (n', e')
+
---------------------------------------------
zonkMonoBinds :: ZonkEnv -> TcMonoBinds
zonkExpr env expr `thenM` \ new_expr ->
returnM (VarMonoBind new_var new_expr, unitBag new_var)
-zonkMonoBinds env (CoreMonoBind var core_expr)
- = zonkIdBndr env var `thenM` \ new_var ->
- returnM (CoreMonoBind new_var core_expr, unitBag new_var)
-
zonkMonoBinds env (FunMonoBind var inf ms locn)
= zonkIdBndr env var `thenM` \ new_var ->
mappM (zonkMatch env) ms `thenM` \ new_ms ->
%************************************************************************
\begin{code}
-zonkExpr :: ZonkEnv -> TcExpr -> TcM TypecheckedHsExpr
+zonkExprs :: ZonkEnv -> [TcExpr] -> TcM [TypecheckedHsExpr]
+zonkExpr :: ZonkEnv -> TcExpr -> TcM TypecheckedHsExpr
+
+zonkExprs env exprs = mappM (zonkExpr env) exprs
+
zonkExpr env (HsVar id)
= returnM (HsVar (zonkIdOcc env id))
zonk_b (n,e) = zonkExpr env e `thenM` \ e' ->
returnM (n,e')
-zonkExpr env (HsSplice n e) = WARN( True, ppr e ) -- Should not happen
- returnM (HsSplice n e)
+zonkExpr env (HsReify r) = returnM (HsReify r) -- Nothing to zonk; only top
+ -- level things can be reified (for now)
+zonkExpr env (HsSplice n e loc) = WARN( True, ppr e ) -- Should not happen
+ returnM (HsSplice n e loc)
zonkExpr env (OpApp e1 op fixity e2)
= zonkExpr env e1 `thenM` \ new_e1 ->
zonkExpr new_env expr `thenM` \ new_expr ->
returnM (HsLet new_binds new_expr)
-zonkExpr env (HsWith expr binds is_with)
- = mappM zonk_ip_bind binds `thenM` \ new_binds ->
- let
- env1 = extendZonkEnv env (map (ipNameName . fst) new_binds)
- in
- zonkExpr env1 expr `thenM` \ new_expr ->
- returnM (HsWith new_expr new_binds is_with)
- where
- zonk_ip_bind (n, e)
- = mapIPNameTc (zonkIdBndr env) n `thenM` \ n' ->
- zonkExpr env e `thenM` \ e' ->
- returnM (n', e')
-
zonkExpr env (HsDo do_or_lc stmts ids ty src_loc)
= zonkStmts env stmts `thenM` \ new_stmts ->
zonkTcTypeToType env ty `thenM` \ new_ty ->
- returnM (HsDo do_or_lc new_stmts
- (zonkIdOccs env ids)
- new_ty src_loc)
+ zonkReboundNames env ids `thenM` \ new_ids ->
+ returnM (HsDo do_or_lc new_stmts new_ids
+ new_ty src_loc)
zonkExpr env (ExplicitList ty exprs)
= zonkTcTypeToType env ty `thenM` \ new_ty ->
- mappM (zonkExpr env) exprs `thenM` \ new_exprs ->
+ zonkExprs env exprs `thenM` \ new_exprs ->
returnM (ExplicitList new_ty new_exprs)
zonkExpr env (ExplicitPArr ty exprs)
= zonkTcTypeToType env ty `thenM` \ new_ty ->
- mappM (zonkExpr env) exprs `thenM` \ new_exprs ->
+ zonkExprs env exprs `thenM` \ new_exprs ->
returnM (ExplicitPArr new_ty new_exprs)
zonkExpr env (ExplicitTuple exprs boxed)
- = mappM (zonkExpr env) exprs `thenM` \ new_exprs ->
+ = zonkExprs env exprs `thenM` \ new_exprs ->
returnM (ExplicitTuple new_exprs boxed)
zonkExpr env (RecordConOut data_con con_expr rbinds)
returnM (PArrSeqOut new_expr new_info)
zonkExpr env (HsCCall fun args may_gc is_casm result_ty)
- = mappM (zonkExpr env) args `thenM` \ new_args ->
+ = zonkExprs env args `thenM` \ new_args ->
zonkTcTypeToType env result_ty `thenM` \ new_result_ty ->
returnM (HsCCall fun new_args may_gc is_casm new_result_ty)
= zonkExpr env expr `thenM` \ new_expr ->
returnM (HsSCC lbl new_expr)
+-- hdaume: core annotations
+zonkExpr env (HsCoreAnn lbl expr)
+ = zonkExpr env expr `thenM` \ new_expr ->
+ returnM (HsCoreAnn lbl new_expr)
+
zonkExpr env (TyLam tyvars expr)
= mappM zonkTcTyVarToTyVar tyvars `thenM` \ new_tyvars ->
-- No need to extend tyvar env; see AbsBinds
= zonkExpr env expr `thenM` \ new_expr ->
returnM (DictApp new_expr (zonkIdOccs env dicts))
+-- arrow notation extensions
+zonkExpr env (HsProc pat body src_loc)
+ = zonkPat env pat `thenM` \ (new_pat, new_ids) ->
+ let
+ env1 = extendZonkEnv env (bagToList new_ids)
+ in
+ zonkCmdTop env1 body `thenM` \ new_body ->
+ returnM (HsProc new_pat new_body src_loc)
+
+zonkExpr env (HsArrApp e1 e2 ty ho rl src_loc)
+ = zonkExpr env e1 `thenM` \ new_e1 ->
+ zonkExpr env e2 `thenM` \ new_e2 ->
+ zonkTcTypeToType env ty `thenM` \ new_ty ->
+ returnM (HsArrApp new_e1 new_e2 new_ty ho rl src_loc)
+
+zonkExpr env (HsArrForm op fixity args src_loc)
+ = zonkExpr env op `thenM` \ new_op ->
+ mappM (zonkCmdTop env) args `thenM` \ new_args ->
+ returnM (HsArrForm new_op fixity new_args src_loc)
+
+zonkCmdTop :: ZonkEnv -> TcCmdTop -> TcM TypecheckedHsCmdTop
+zonkCmdTop env (HsCmdTop cmd stack_tys ty ids)
+ = zonkExpr env cmd `thenM` \ new_cmd ->
+ mappM (zonkTcTypeToType env) stack_tys
+ `thenM` \ new_stack_tys ->
+ zonkTcTypeToType env ty `thenM` \ new_ty ->
+ zonkReboundNames 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)
-------------------------------------------------------------------------
-------------------------------------------------------------------------
-zonkStmts :: ZonkEnv -> [TcStmt] -> TcM [TypecheckedStmt]
+zonkStmts :: ZonkEnv -> [TcStmt] -> TcM [TypecheckedStmt]
+
+zonkStmts env stmts = zonk_stmts env stmts `thenM` \ (_, stmts) ->
+ returnM stmts
-zonkStmts env [] = returnM []
+zonk_stmts :: ZonkEnv -> [TcStmt] -> TcM (ZonkEnv, [TypecheckedStmt])
-zonkStmts env (ParStmtOut bndrstmtss : stmts)
- = mappM (mappM zonkId) bndrss `thenM` \ new_bndrss ->
- mappM (zonkStmts env) stmtss `thenM` \ new_stmtss ->
+zonk_stmts env [] = returnM (env, [])
+
+zonk_stmts env (ParStmt stmts_w_bndrs : stmts)
+ = mappM zonk_branch stmts_w_bndrs `thenM` \ new_stmts_w_bndrs ->
let
- new_binders = concat new_bndrss
+ new_binders = concat (map snd new_stmts_w_bndrs)
env1 = extendZonkEnv env new_binders
in
- zonkStmts env1 stmts `thenM` \ new_stmts ->
- returnM (ParStmtOut (zip new_bndrss new_stmtss) : new_stmts)
+ zonk_stmts env1 stmts `thenM` \ (env2, new_stmts) ->
+ returnM (env2, ParStmt new_stmts_w_bndrs : new_stmts)
where
- (bndrss, stmtss) = unzip bndrstmtss
+ zonk_branch (stmts, bndrs) = zonk_stmts env stmts `thenM` \ (env1, new_stmts) ->
+ returnM (new_stmts, zonkIdOccs env1 bndrs)
-zonkStmts env (RecStmt vs segStmts : stmts)
- = mappM zonkId vs `thenM` \ new_vs ->
+zonk_stmts env (RecStmt segStmts lvs rvs rets : stmts)
+ = zonkIdBndrs env rvs `thenM` \ new_rvs ->
+ let
+ env1 = extendZonkEnv env new_rvs
+ in
+ zonk_stmts env1 segStmts `thenM` \ (env2, new_segStmts) ->
+ -- Zonk the ret-expressions in an envt that
+ -- has the polymorphic bindings in the envt
+ zonkExprs env2 rets `thenM` \ new_rets ->
let
- env1 = extendZonkEnv env new_vs
+ new_lvs = zonkIdOccs env2 lvs
+ env3 = extendZonkEnv env new_lvs -- Only the lvs are needed
in
- zonkStmts env1 segStmts `thenM` \ new_segStmts ->
- zonkStmts env1 stmts `thenM` \ new_stmts ->
- returnM (RecStmt new_vs new_segStmts : new_stmts)
+ zonk_stmts env3 stmts `thenM` \ (env4, new_stmts) ->
+ returnM (env4, RecStmt new_segStmts new_lvs new_rvs new_rets : new_stmts)
-zonkStmts env (ResultStmt expr locn : stmts)
- = zonkExpr env expr `thenM` \ new_expr ->
- zonkStmts env stmts `thenM` \ new_stmts ->
- returnM (ResultStmt new_expr locn : new_stmts)
+zonk_stmts env (ResultStmt expr locn : stmts)
+ = ASSERT( null stmts )
+ zonkExpr env expr `thenM` \ new_expr ->
+ returnM (env, [ResultStmt new_expr locn])
-zonkStmts env (ExprStmt expr ty locn : stmts)
+zonk_stmts env (ExprStmt expr ty locn : stmts)
= zonkExpr env expr `thenM` \ new_expr ->
zonkTcTypeToType env ty `thenM` \ new_ty ->
- zonkStmts env stmts `thenM` \ new_stmts ->
- returnM (ExprStmt new_expr new_ty locn : new_stmts)
+ zonk_stmts env stmts `thenM` \ (env1, new_stmts) ->
+ returnM (env1, ExprStmt new_expr new_ty locn : new_stmts)
-zonkStmts env (LetStmt binds : stmts)
- = zonkBinds env binds `thenM` \ (new_env, new_binds) ->
- zonkStmts new_env stmts `thenM` \ new_stmts ->
- returnM (LetStmt new_binds : new_stmts)
+zonk_stmts env (LetStmt binds : stmts)
+ = zonkBinds env binds `thenM` \ (env1, new_binds) ->
+ zonk_stmts env1 stmts `thenM` \ (env2, new_stmts) ->
+ returnM (env2, LetStmt new_binds : new_stmts)
-zonkStmts env (BindStmt pat expr locn : stmts)
+zonk_stmts env (BindStmt pat expr locn : stmts)
= zonkExpr env expr `thenM` \ new_expr ->
zonkPat env pat `thenM` \ (new_pat, new_ids) ->
let
env1 = extendZonkEnv env (bagToList new_ids)
in
- zonkStmts env1 stmts `thenM` \ new_stmts ->
- returnM (BindStmt new_pat new_expr locn : new_stmts)
+ zonk_stmts env1 stmts `thenM` \ (env2, new_stmts) ->
+ returnM (env2, BindStmt new_pat new_expr locn : new_stmts)
zonkForeignExport :: ZonkEnv -> TcForeignDecl -> TcM (TypecheckedForeignDecl)
zonkForeignExport env (ForeignExport i hs_ty spec isDeprec src_loc) =
returnM (ForeignExport (zonkIdOcc env i) undefined spec isDeprec src_loc)
+zonkForeignExport env for_imp
+ = returnM for_imp -- Foreign imports don't need zonking
\end{code}
\begin{code}
projects / ghc-hetmet.git / blobdiff