[project @ 1996-04-10 18:10:47 by partain]

[ghc-hetmet.git] / ghc / compiler / deSugar / DsBinds.lhs

diff --git a/ghc/compiler/deSugar/DsBinds.lhs b/ghc/compiler/deSugar/DsBinds.lhs
index ec1bdd4..b744e0e 100644 (file)
--- a/ghc/compiler/deSugar/DsBinds.lhs
+++ b/ghc/compiler/deSugar/DsBinds.lhs
@@ -27,21 +27,19 @@ import DsUtils
 import Match           ( matchWrapper )
 
 import CmdLineOpts     ( opt_SccProfilingOn, opt_CompilingPrelude )
-import CoreUtils       ( escErrorMsg )
 import CostCentre      ( mkAllDictsCC, preludeDictsCostCentre )
 import Id              ( idType, DictVar(..), GenId )
 import ListSetOps      ( minusList, intersectLists )
 import PprType         ( GenType )
 import PprStyle                ( PprStyle(..) )
 import Pretty          ( ppShow )
-import Type            ( mkTyVarTys, splitSigmaTy,
+import Type            ( mkTyVarTys, mkForAllTys, splitSigmaTy,
                          tyVarsOfType, tyVarsOfTypes
                        )
 import TyVar           ( tyVarSetToList, GenTyVar{-instance Eq-} )
 import Util            ( isIn, panic )
 
 isDictTy = panic "DsBinds.isDictTy"
-quantifyTy = panic "DsBinds.quantifyTy"
 \end{code}
 
 %************************************************************************
@@ -155,7 +153,7 @@ dsBinds (AbsBinds tyvars [] local_global_prs inst_binds val_binds)
        -- local_global_prs.
     private_binders = binders `minusList` [local | (local,_) <- local_global_prs]
     binders        = collectTypedBinders val_binds
-    mk_poly_private_binder id = newSysLocalDs (snd (quantifyTy tyvars (idType id)))
+    mk_poly_private_binder id = newSysLocalDs (mkForAllTys tyvars (idType id))
 
     tyvar_tys = mkTyVarTys tyvars
 \end{code}
@@ -245,7 +243,7 @@ dsBinds (AbsBinds all_tyvars dicts local_global_prs dict_binds val_binds)
     non_overloaded_tyvars = all_tyvars `minusList` (tyVarSetToList{-????-} overloaded_tyvars)
 
     binders      = collectTypedBinders val_binds
-    mk_binder id = newSysLocalDs (snd (quantifyTy non_overloaded_tyvars (idType id)))
+    mk_binder id = newSysLocalDs (mkForAllTys non_overloaded_tyvars (idType id))
 \end{code}
 
 @mkSatTyApp id tys@ constructs an expression whose value is (id tys).
@@ -344,8 +342,8 @@ dsInstBinds tyvars ((inst, expr) : bs)
   where
     inst_ty    = idType inst
     abs_tyvars = tyVarSetToList{-???sigh-} (tyVarsOfType inst_ty) `intersectLists` tyvars
-    abs_tys    = mkTyVarTys abs_tyvars
-    (_, poly_inst_ty) = quantifyTy abs_tyvars inst_ty
+    abs_tys      = mkTyVarTys  abs_tyvars
+    poly_inst_ty = mkForAllTys abs_tyvars inst_ty
 
     ------------------------
     -- Wrap a desugared expression in `_scc_ "DICT" <expr>' if
@@ -471,24 +469,20 @@ dsMonoBinds is_rec tyvars dicts binder_subst (VarMonoBind var expr)
 \end{code}
 
 \begin{code}
-dsMonoBinds is_rec tyvars dicts binder_subst (FunMonoBind fun matches locn)
-  = putSrcLocDs locn   (
+dsMonoBinds is_rec tyvars dicts binder_subst (FunMonoBind fun _ matches locn)
+  = putSrcLocDs locn   $
     let
-       new_fun = binder_subst fun
+       new_fun      = binder_subst fun
+       error_string = "function " ++ showForErr fun
     in
-    matchWrapper (FunMatch fun) matches (error_msg new_fun) `thenDs` \ (args, body) ->
+    matchWrapper (FunMatch fun) matches error_string   `thenDs` \ (args, body) ->
     returnDs [(new_fun,
               mkLam tyvars (dicts ++ args) body)]
-    )
-  where
-    error_msg fun = "%F" -- "incomplete pattern(s) to match in function \""
-               ++ (escErrorMsg (ppShow 80 (ppr PprForUser fun))) ++ "\""
 
 dsMonoBinds is_rec tyvars dicts binder_subst (PatMonoBind (VarPat v) grhss_and_binds locn)
-  = putSrcLocDs locn   (
-    dsGuarded grhss_and_binds locn `thenDs` \ body_expr ->
+  = putSrcLocDs locn   $
+    dsGuarded grhss_and_binds          `thenDs` \ body_expr ->
     returnDs [(binder_subst v, mkLam tyvars dicts body_expr)]
-    )
 \end{code}
 
 %==============================================
@@ -531,9 +525,9 @@ Then we transform to:
 
 \begin{code}
 dsMonoBinds is_rec tyvars [] binder_subst (PatMonoBind pat grhss_and_binds locn)
-  = putSrcLocDs locn (
+  = putSrcLocDs locn $
 
-    dsGuarded grhss_and_binds locn `thenDs` \ body_expr ->
+    dsGuarded grhss_and_binds          `thenDs` \ body_expr ->
 
 {- KILLED by Sansom. 95/05
        -- make *sure* there are no primitive types in the pattern
@@ -549,7 +543,6 @@ dsMonoBinds is_rec tyvars [] binder_subst (PatMonoBind pat grhss_and_binds locn)
     mkSelectorBinds tyvars pat
        [(binder, binder_subst binder) | binder <- pat_binders]
        body_expr
-    )
   where
     pat_binders = collectTypedPatBinders pat
        -- NB For a simple tuple pattern, these binders