[project @ 2003-04-10 15:46:11 by simonpj]

[ghc-hetmet.git] / ghc / compiler / typecheck / TcHsSyn.lhs

diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs
index 251c7ad..24dc515 100644 (file)
--- a/ghc/compiler/typecheck/TcHsSyn.lhs
+++ b/ghc/compiler/typecheck/TcHsSyn.lhs
@@ -27,6 +27,11 @@ module TcHsSyn (
        mkHsTyLam, mkHsDictLam, mkHsLet,
        hsLitType, hsPatType, 
 
        mkHsTyLam, mkHsDictLam, mkHsLet,
        hsLitType, hsPatType, 
 

+       -- Coercions
+       Coercion, ExprCoFn, PatCoFn, 
+       (<$>), (<.>), mkCoercion, 
+       idCoercion, isIdCoercion,
+

        -- re-exported from TcMonad
        TcId, TcIdSet,
 
        -- re-exported from TcMonad
        TcId, TcIdSet,
 

@@ -65,6 +70,7 @@ import VarSet
 import VarEnv
 import BasicTypes ( RecFlag(..), Boxity(..), IPName(..), ipNameName, mapIPName )
 import Maybes    ( orElse )
 import VarEnv
 import BasicTypes ( RecFlag(..), Boxity(..), IPName(..), ipNameName, mapIPName )
 import Maybes    ( orElse )

+import Maybe     ( isNothing )

 import Unique    ( Uniquable(..) )
 import SrcLoc    ( noSrcLoc )
 import Bag
 import Unique    ( Uniquable(..) )
 import SrcLoc    ( noSrcLoc )
 import Bag

@@ -182,12 +188,37 @@ hsLitType (HsDoublePrim d) = doublePrimTy
 hsLitType (HsLitLit _ ty)  = ty
 \end{code}
 
 hsLitType (HsLitLit _ ty)  = ty
 \end{code}
 

+%************************************************************************
+%*                                                                     *
+\subsection{Coercion functions}
+%*                                                                     *
+%************************************************************************
+

 \begin{code}
 \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}
 
 
 \end{code}
 
 

@@ -197,7 +228,16 @@ zonkId id
 %*                                                                     *
 %************************************************************************
 
 %*                                                                     *
 %************************************************************************
 

-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
 
  a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc
  b) convert unbound TcTyVar to Void

@@ -315,7 +355,20 @@ zonkBinds env (MonoBind bind sigs is_rec)
        zonkMonoBinds env1 bind `thenM` \ (new_bind, new_ids) ->
        returnM (env1, new_bind, new_ids)
     )                          `thenM` \ (env1, new_bind, _) ->
        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
 
 ---------------------------------------------
 zonkMonoBinds :: ZonkEnv -> TcMonoBinds

@@ -413,7 +466,11 @@ zonkGRHSs env (GRHSs grhss binds ty)
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \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))
 
 zonkExpr env (HsVar id)
   = returnM (HsVar (zonkIdOcc env id))

@@ -450,8 +507,10 @@ zonkExpr env (HsBracketOut body bs)
     zonk_b (n,e) = zonkExpr env e      `thenM` \ e' ->
                   returnM (n,e')
 
     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 env (OpApp e1 op fixity e2)
   = zonkExpr env e1    `thenM` \ new_e1 ->

@@ -491,19 +550,6 @@ zonkExpr env (HsLet binds expr)
     zonkExpr new_env expr      `thenM` \ new_expr ->
     returnM (HsLet new_binds new_expr)
 
     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   ->
 zonkExpr env (HsDo do_or_lc stmts ids ty src_loc)
   = zonkStmts env stmts        `thenM` \ new_stmts ->
     zonkTcTypeToType env ty    `thenM` \ new_ty   ->

@@ -513,16 +559,16 @@ zonkExpr env (HsDo do_or_lc stmts ids ty src_loc)
 
 zonkExpr env (ExplicitList ty exprs)
   = zonkTcTypeToType env ty    `thenM` \ new_ty ->
 
 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 ->
     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)
     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 (ExplicitTuple new_exprs boxed)
 
 zonkExpr env (RecordConOut data_con con_expr rbinds)

@@ -554,7 +600,7 @@ zonkExpr env (PArrSeqOut expr info)
     returnM (PArrSeqOut new_expr new_info)
 
 zonkExpr env (HsCCall fun args may_gc is_casm result_ty)
     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)
 
     zonkTcTypeToType env result_ty     `thenM` \ new_result_ty ->
     returnM (HsCCall fun new_args may_gc is_casm new_result_ty)
 

@@ -562,6 +608,11 @@ zonkExpr env (HsSCC lbl expr)
   = zonkExpr env expr  `thenM` \ new_expr ->
     returnM (HsSCC lbl new_expr)
 
   = 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 (TyLam tyvars expr)
   = mappM zonkTcTyVarToTyVar tyvars    `thenM` \ new_tyvars ->
        -- No need to extend tyvar env; see AbsBinds

@@ -613,55 +664,63 @@ zonkArithSeq env (FromThenTo e1 e2 e3)
 
 
 -------------------------------------------------------------------------
 
 
 -------------------------------------------------------------------------

-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)
+zonk_stmts env [] = returnM (env, [])
+
+zonk_stmts env (ParStmtOut bndrstmtss : stmts)

   = mappM (mappM zonkId) bndrss                `thenM` \ new_bndrss ->
     mappM (zonkStmts env) stmtss       `thenM` \ new_stmtss ->
     let 
        new_binders = concat new_bndrss
        env1 = extendZonkEnv env new_binders
     in
   = mappM (mappM zonkId) bndrss                `thenM` \ new_bndrss ->
     mappM (zonkStmts env) stmtss       `thenM` \ new_stmtss ->
     let 
        new_binders = concat new_bndrss
        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, ParStmtOut (zip new_bndrss new_stmtss) : new_stmts)

   where
     (bndrss, stmtss) = unzip bndrstmtss
 
   where
     (bndrss, stmtss) = unzip bndrstmtss
 

-zonkStmts env (RecStmt vs segStmts : stmts)
+zonk_stmts env (RecStmt vs segStmts rets : stmts)

   = mappM zonkId vs            `thenM` \ new_vs ->
     let
        env1 = extendZonkEnv env new_vs
     in
   = mappM zonkId vs            `thenM` \ new_vs ->
     let
        env1 = extendZonkEnv env new_vs
     in

-    zonkStmts env1 segStmts    `thenM` \ new_segStmts ->
-    zonkStmts env1 stmts       `thenM` \ new_stmts ->
-    returnM (RecStmt new_vs new_segStmts : new_stmts)
-
-zonkStmts env (ResultStmt expr locn : stmts)
-  = zonkExpr env expr  `thenM` \ new_expr ->
-    zonkStmts env stmts        `thenM` \ new_stmts ->
-    returnM (ResultStmt new_expr locn : new_stmts)
+    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 ->
+    zonk_stmts env1 stmts      `thenM` \ (env3, new_stmts) ->
+    returnM (env3, RecStmt new_vs new_segStmts new_rets : 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 ->
   = 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
   = 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)

 
 
 
 
 
 

@@ -804,6 +863,8 @@ zonkForeignExports env ls = mappM (zonkForeignExport env) ls
 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 :: 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}
 \end{code}
 
 \begin{code}