[project @ 2002-05-23 15:37:32 by simonpj]
[ghc-hetmet.git] / ghc / compiler / typecheck / TcExpr.lhs
index a31eeb4..e6a3d85 100644 (file)
@@ -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,14 +60,15 @@ import PrelNames    ( cCallableClassName,
                          enumFromName, enumFromThenName, 
                          enumFromToName, enumFromThenToName,
                          enumFromToPName, enumFromThenToPName,
-                         thenMName, failMName, returnMName, ioTyConName
+                         thenMName, bindMName, failMName, returnMName, ioTyConName
                        )
-import Outputable
 import ListSetOps      ( minusList )
-import Util
 import CmdLineOpts
 import HscTypes                ( TyThing(..) )
 
+import Util
+import Outputable
+import FastString
 \end{code}
 
 %************************************************************************
@@ -146,6 +147,14 @@ tcMonoExpr in_expr@(ExprWithTySig expr poly_ty) res_ty
    tcSubExp res_ty inst_sig_ty         `thenTc` \ (co_fn, lie3) ->
 
    returnTc (co_fn <$> inst_fn expr', lie1 `plusLIE` lie2 `plusLIE` lie3)
+
+tcMonoExpr (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)
+       -- so it's not enabled yet.
+       -- Can't eliminate it altogether from the parser, because the
+       -- same parser parses *patterns*.
 \end{code}
 
 
@@ -239,11 +248,11 @@ tcMonoExpr e0@(HsCCall lbl args may_gc is_casm ignored_fake_result_ty) res_ty
     tcLookupTyCon ioTyConName          `thenNF_Tc` \ ioTyCon ->
     let
        new_arg_dict (arg, arg_ty)
-         = newDicts (CCallOrigin (_UNPK_ lbl) (Just arg))
+         = newDicts (CCallOrigin (unpackFS lbl) (Just arg))
                     [mkClassPred cCallableClass [arg_ty]]      `thenNF_Tc` \ arg_dicts ->
            returnNF_Tc arg_dicts       -- Actually a singleton bag
 
-       result_origin = CCallOrigin (_UNPK_ lbl) Nothing {- Not an arg -}
+       result_origin = CCallOrigin (unpackFS lbl) Nothing {- Not an arg -}
     in
 
        -- Arguments
@@ -373,7 +382,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 +397,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 +434,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 +531,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 +542,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 +554,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 +567,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 +579,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 +592,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'),
@@ -820,7 +828,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 +837,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 +874,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}
 
 
@@ -1000,7 +1002,7 @@ Overloaded literals.
 tcLit :: HsLit -> TcType -> TcM (TcExpr, LIE)
 tcLit (HsLitLit s _) res_ty
   = tcLookupClass cCallableClassName                   `thenNF_Tc` \ cCallableClass ->
-    newDicts (LitLitOrigin (_UNPK_ s))
+    newDicts (LitLitOrigin (unpackFS s))
             [mkClassPred cCallableClass [res_ty]]      `thenNF_Tc` \ dicts ->
     returnTc (HsLit (HsLitLit s res_ty), mkLIE dicts)