projects / ghc-hetmet.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
[project @ 2002-04-11 12:03:29 by simonpj]
[ghc-hetmet.git] / ghc / compiler / typecheck / TcExpr.lhs
diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs
index 32f687f..1da69ec 100644 (file)
--- a/ghc/compiler/typecheck/TcExpr.lhs
+++ b/ghc/compiler/typecheck/TcExpr.lhs
@@ -22,7 +22,7 @@ import TcUnify                ( tcSubExp, tcGen, (<$>),
 import BasicTypes      ( RecFlag(..),  isMarkedStrict )
 import Inst            ( InstOrigin(..), 
                          LIE, mkLIE, emptyLIE, unitLIE, plusLIE, plusLIEs,
-                         newOverloadedLit, newMethod, newIPDict,
+                         newOverloadedLit, newMethodFromName, newIPDict,
                          newDicts, newMethodWithGivenTy,
                          instToId, tcInstCall, tcInstDataCon
                        )
@@ -60,7 +60,7 @@ import PrelNames      ( cCallableClassName,
                          enumFromName, enumFromThenName, 
                          enumFromToName, enumFromThenToName,
                          enumFromToPName, enumFromThenToPName,
-                         thenMName, failMName, returnMName, ioTyConName
+                         thenMName, bindMName, failMName, returnMName, ioTyConName
                        )
 import Outputable
 import ListSetOps      ( minusList )
@@ -373,7 +373,7 @@ tcMonoExpr expr@(RecordCon con_name rbinds) res_ty
     let
        bad_fields = badFields rbinds data_con
     in
-    if not (null bad_fields) then
+    if notNull bad_fields then
        mapNF_Tc (addErrTc . badFieldCon con_name) bad_fields   `thenNF_Tc_`
        failTc  -- Fail now, because tcRecordBinds will crash on a bad field
     else
@@ -388,7 +388,7 @@ tcMonoExpr expr@(RecordCon con_name rbinds) res_ty
        (mapNF_Tc (addErrTc . missingStrictFieldCon con_name) missing_s_fields `thenNF_Tc_`
         returnNF_Tc ())  `thenNF_Tc_`
     doptsTc Opt_WarnMissingFields `thenNF_Tc` \ warn ->
-    checkTcM (not (warn && not (null missing_fields)))
+    checkTcM (not (warn && notNull missing_fields))
        (mapNF_Tc ((warnTc True) . missingFieldCon con_name) missing_fields `thenNF_Tc_`
         returnNF_Tc ())  `thenNF_Tc_`
 
@@ -425,7 +425,7 @@ tcMonoExpr expr@(RecordUpd record_expr rbinds) res_ty
 
        -- STEP 0
        -- Check that the field names are really field names
-    ASSERT( not (null rbinds) )
+    ASSERT( notNull rbinds )
     let 
        field_names = [field_name | (field_name, _, _) <- rbinds]
     in
@@ -522,9 +522,8 @@ tcMonoExpr (ArithSeqIn seq@(From expr)) res_ty
   = unifyListTy res_ty                                 `thenTc` \ elt_ty ->  
     tcMonoExpr expr elt_ty                     `thenTc` \ (expr', lie1) ->
 
-    tcLookupGlobalId enumFromName              `thenNF_Tc` \ sel_id ->
-    newMethod (ArithSeqOrigin seq)
-             sel_id [elt_ty]                   `thenNF_Tc` \ enum_from ->
+    newMethodFromName (ArithSeqOrigin seq) 
+                     elt_ty enumFromName       `thenNF_Tc` \ enum_from ->
 
     returnTc (ArithSeqOut (HsVar (instToId enum_from)) (From expr'),
              lie1 `plusLIE` unitLIE enum_from)
@@ -534,8 +533,8 @@ tcMonoExpr in_expr@(ArithSeqIn seq@(FromThen expr1 expr2)) res_ty
     unifyListTy  res_ty                                `thenTc`    \ elt_ty ->  
     tcMonoExpr expr1 elt_ty                            `thenTc`    \ (expr1',lie1) ->
     tcMonoExpr expr2 elt_ty                            `thenTc`    \ (expr2',lie2) ->
-    tcLookupGlobalId enumFromThenName                  `thenNF_Tc` \ sel_id ->
-    newMethod (ArithSeqOrigin seq) sel_id [elt_ty]     `thenNF_Tc` \ enum_from_then ->
+    newMethodFromName (ArithSeqOrigin seq) 
+                     elt_ty enumFromThenName           `thenNF_Tc` \ enum_from_then ->
 
     returnTc (ArithSeqOut (HsVar (instToId enum_from_then))
                          (FromThen expr1' expr2'),
@@ -546,8 +545,8 @@ tcMonoExpr in_expr@(ArithSeqIn seq@(FromTo expr1 expr2)) res_ty
     unifyListTy  res_ty                                `thenTc`    \ elt_ty ->  
     tcMonoExpr expr1 elt_ty                            `thenTc`    \ (expr1',lie1) ->
     tcMonoExpr expr2 elt_ty                            `thenTc`    \ (expr2',lie2) ->
-    tcLookupGlobalId enumFromToName                    `thenNF_Tc` \ sel_id ->
-    newMethod (ArithSeqOrigin seq) sel_id [elt_ty]     `thenNF_Tc` \ enum_from_to ->
+    newMethodFromName (ArithSeqOrigin seq) 
+                     elt_ty enumFromToName             `thenNF_Tc` \ enum_from_to ->
 
     returnTc (ArithSeqOut (HsVar (instToId enum_from_to))
                          (FromTo expr1' expr2'),
@@ -559,8 +558,8 @@ tcMonoExpr in_expr@(ArithSeqIn seq@(FromThenTo expr1 expr2 expr3)) res_ty
     tcMonoExpr expr1 elt_ty                            `thenTc`    \ (expr1',lie1) ->
     tcMonoExpr expr2 elt_ty                            `thenTc`    \ (expr2',lie2) ->
     tcMonoExpr expr3 elt_ty                            `thenTc`    \ (expr3',lie3) ->
-    tcLookupGlobalId enumFromThenToName                        `thenNF_Tc` \ sel_id ->
-    newMethod (ArithSeqOrigin seq) sel_id [elt_ty]     `thenNF_Tc` \ eft ->
+    newMethodFromName (ArithSeqOrigin seq) 
+                     elt_ty enumFromThenToName         `thenNF_Tc` \ eft ->
 
     returnTc (ArithSeqOut (HsVar (instToId eft))
                          (FromThenTo expr1' expr2' expr3'),
@@ -571,8 +570,8 @@ tcMonoExpr in_expr@(PArrSeqIn seq@(FromTo expr1 expr2)) res_ty
     unifyPArrTy  res_ty                                `thenTc`    \ elt_ty ->  
     tcMonoExpr expr1 elt_ty                            `thenTc`    \ (expr1',lie1) ->
     tcMonoExpr expr2 elt_ty                            `thenTc`    \ (expr2',lie2) ->
-    tcLookupGlobalId enumFromToPName                   `thenNF_Tc` \ sel_id ->
-    newMethod (PArrSeqOrigin seq) sel_id [elt_ty]      `thenNF_Tc` \ enum_from_to ->
+    newMethodFromName (PArrSeqOrigin seq) 
+                     elt_ty enumFromToPName            `thenNF_Tc` \ enum_from_to ->
 
     returnTc (PArrSeqOut (HsVar (instToId enum_from_to))
                         (FromTo expr1' expr2'),
@@ -584,8 +583,8 @@ tcMonoExpr in_expr@(PArrSeqIn seq@(FromThenTo expr1 expr2 expr3)) res_ty
     tcMonoExpr expr1 elt_ty                            `thenTc`    \ (expr1',lie1) ->
     tcMonoExpr expr2 elt_ty                            `thenTc`    \ (expr2',lie2) ->
     tcMonoExpr expr3 elt_ty                            `thenTc`    \ (expr3',lie3) ->
-    tcLookupGlobalId enumFromThenToPName               `thenNF_Tc` \ sel_id ->
-    newMethod (PArrSeqOrigin seq) sel_id [elt_ty]      `thenNF_Tc` \ eft ->
+    newMethodFromName (PArrSeqOrigin seq)
+                     elt_ty enumFromThenToPName        `thenNF_Tc` \ eft ->
 
     returnTc (PArrSeqOut (HsVar (instToId eft))
                         (FromThenTo expr1' expr2' expr3'),
@@ -604,7 +603,7 @@ tcMonoExpr (PArrSeqIn _) _
 %************************************************************************
 
 \begin{code}
-tcMonoExpr (HsWith expr binds) res_ty
+tcMonoExpr (HsWith expr binds is_with) res_ty
   = tcMonoExpr expr res_ty                     `thenTc` \ (expr', expr_lie) ->
     mapAndUnzip3Tc tcIPBind binds              `thenTc` \ (avail_ips, binds', bind_lies) ->
 
@@ -614,7 +613,7 @@ tcMonoExpr (HsWith expr binds) res_ty
     let
        expr'' = HsLet (mkMonoBind dict_binds [] Recursive) expr'
     in
-    returnTc (HsWith expr'' binds', expr_lie' `plusLIE` plusLIEs bind_lies)
+    returnTc (HsWith expr'' binds' is_with, expr_lie' `plusLIE` plusLIEs bind_lies)
 
 tcIPBind (ip, expr)
   = newTyVarTy openTypeKind            `thenTc` \ ty ->
@@ -820,7 +819,7 @@ tcExpr_id expr         = newHoleTyVarTy                     `thenNF_Tc` \ id_ty ->
 --
 tcDoStmts PArrComp stmts src_loc res_ty
   =
-    ASSERT( not (null stmts) )
+    ASSERT( notNull stmts )
     tcAddSrcLoc src_loc        $
 
     unifyPArrTy res_ty                       `thenTc` \elt_ty              ->
@@ -829,14 +828,14 @@ tcDoStmts PArrComp stmts src_loc res_ty
     in
     tcStmts (DoCtxt PArrComp) m_ty stmts      `thenTc` \(stmts', stmts_lie) ->
     returnTc (HsDoOut PArrComp stmts'
-                     undefined undefined undefined  -- don't touch!
+                     undefined         -- don't touch!
                      res_ty src_loc,
              stmts_lie)
 
 tcDoStmts do_or_lc stmts src_loc res_ty
   =    -- get the Monad and MonadZero classes
        -- create type consisting of a fresh monad tyvar
-    ASSERT( not (null stmts) )
+    ASSERT( notNull stmts )
     tcAddSrcLoc src_loc        $
 
        -- If it's a comprehension we're dealing with, 
@@ -866,19 +865,13 @@ tcDoStmts do_or_lc stmts src_loc res_ty
        --      then = then
        -- where the second "then" sees that it already exists in the "available" stuff.
        --
-    tcLookupGlobalId returnMName               `thenNF_Tc` \ return_sel_id ->
-    tcLookupGlobalId thenMName                 `thenNF_Tc` \ then_sel_id ->
-    tcLookupGlobalId failMName                 `thenNF_Tc` \ fail_sel_id ->
-    newMethod DoOrigin return_sel_id [tc_ty]   `thenNF_Tc` \ return_inst ->
-    newMethod DoOrigin then_sel_id   [tc_ty]   `thenNF_Tc` \ then_inst ->
-    newMethod DoOrigin fail_sel_id   [tc_ty]   `thenNF_Tc` \ fail_inst ->
-    let
-       monad_lie = mkLIE [return_inst, then_inst, fail_inst]
-    in
+    mapNF_Tc (newMethodFromName DoOrigin tc_ty)
+            [returnMName, failMName, bindMName, thenMName]     `thenNF_Tc` \ insts ->
+
     returnTc (HsDoOut do_or_lc stmts'
-                     (instToId return_inst) (instToId then_inst) (instToId fail_inst)
+                     (map instToId insts)
                      res_ty src_loc,
-             stmts_lie `plusLIE` monad_lie)
+             stmts_lie `plusLIE` mkLIE insts)
 \end{code}
 
 
Glasgow Haskell Compiler with heterogeneous metaprogramming (generalized arrows and modal types)