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

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

diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs
index 700db9e..e6b80f2 100644 (file)
--- a/ghc/compiler/deSugar/DsUtils.lhs
+++ b/ghc/compiler/deSugar/DsUtils.lhs
@@ -15,7 +15,7 @@ module DsUtils (
        combineMatchResults,
        dsExprToAtom,
        mkCoAlgCaseMatchResult,
-       mkAppDs, mkConDs, mkPrimDs,
+       mkAppDs, mkConDs, mkPrimDs, mkErrorAppDs,
        mkCoLetsMatchResult,
        mkCoPrimCaseMatchResult,
        mkFailurePair,
@@ -23,7 +23,8 @@ module DsUtils (
        mkSelectorBinds,
        mkTupleBind,
        mkTupleExpr,
-       selectMatchVars
+       selectMatchVars,
+       showForErr
     ) where
 
 import Ubiq
@@ -37,20 +38,21 @@ import CoreSyn
 
 import DsMonad
 
-import CoreUtils       ( coreExprType, escErrorMsg, mkCoreIfThenElse, mkErrorApp )
-import PrelInfo                ( stringTy )
-import Id              ( idType, getInstantiatedDataConSig, mkTupleCon,
+import CoreUtils       ( coreExprType, mkCoreIfThenElse )
+import PprStyle                ( PprStyle(..) )
+import PrelInfo                ( stringTy, iRREFUT_PAT_ERROR_ID )
+import Pretty          ( ppShow )
+import Id              ( idType, dataConArgTys, mkTupleCon,
                          DataCon(..), DictVar(..), Id(..), GenId )
+import Literal         ( Literal(..) )
 import TyCon           ( mkTupleTyCon )
-import Type            ( mkTyVarTys, mkRhoTy, mkFunTys, isUnboxedType,
-                         applyTyCon, getAppDataTyCon
+import Type            ( mkTyVarTys, mkRhoTy, mkForAllTys, mkFunTys,
+                         isUnboxedType, applyTyCon, getAppDataTyCon
                        )
 import UniqSet         ( mkUniqSet, minusUniqSet, uniqSetToList, UniqSet(..) )
 import Util            ( panic, assertPanic )
 
-quantifyTy = panic "DsUtils.quantifyTy"
 splitDictType = panic "DsUtils.splitDictType"
-mkCoTyApps = panic "DsUtils.mkCoTyApps"
 \end{code}
 
 %************************************************************************
@@ -141,7 +143,7 @@ mkCoAlgCaseMatchResult var alts
                     -- We need to build new locals for the args of the constructor,
                     -- and figuring out their types is somewhat tiresome.
                let
-                       (_,arg_tys,_) = getInstantiatedDataConSig con tycon_arg_tys
+                       arg_tys = dataConArgTys con tycon_arg_tys
                in
                newSysLocalsDs arg_tys  `thenDs` \ arg_ids ->
 
@@ -252,8 +254,6 @@ dsExprsToAtoms (arg:args) continue_with
 %*                                                                     *
 %************************************************************************
 
-Plumb the desugarer's @UniqueSupply@ in/out of the @UniqSupply@ monad
-world.
 \begin{code}
 mkAppDs  :: CoreExpr -> [Type] -> [CoreExpr] -> DsM CoreExpr
 mkConDs  :: Id       -> [Type] -> [CoreExpr] -> DsM CoreExpr
@@ -272,6 +272,24 @@ mkPrimDs op tys arg_exprs
     returnDs (mkPrim op [] tys vals)
 \end{code}
 
+\begin{code}
+showForErr :: Outputable a => a -> String              -- Boring but useful
+showForErr thing = ppShow 80 (ppr PprForUser thing)
+
+mkErrorAppDs :: Id             -- The error function
+            -> Type            -- Type to which it should be applied
+            -> String          -- The error message string to pass
+            -> DsM CoreExpr
+
+mkErrorAppDs err_id ty msg
+  = getSrcLocDs                        `thenDs` \ (file, line) ->
+    let
+       full_msg = file ++ "|" ++ line ++ "|" ++msg
+       msg_lit  = NoRepStr (_PK_ full_msg)
+    in
+    returnDs (mkApp (Var err_id) [] [ty] [LitArg msg_lit])
+\end{code}
+
 %************************************************************************
 %*                                                                     *
 \subsection[mkSelectorBind]{Make a selector bind}
@@ -303,17 +321,10 @@ mkSelectorBinds :: [TyVar]            -- Variables wrt which the pattern is polymorphic
                -> DsM [(Id,CoreExpr)]
 
 mkSelectorBinds tyvars pat locals_and_globals val_expr
-  = getSrcLocDs                `thenDs` \ (src_file, src_line) ->
-
-    if is_simple_tuple_pat pat then
+  = if is_simple_tuple_pat pat then
        mkTupleBind tyvars [] locals_and_globals val_expr
     else
-       newSysLocalDs stringTy  `thenDs` \ str_var -> -- to hold the string
-       let
-           src_loc_str   = escErrorMsg ('"' : src_file) ++ "%l" ++ src_line
-           error_string  = src_loc_str ++ "%~" --> ": pattern-match failed on an irrefutable pattern"
-           error_msg     = mkErrorApp res_ty str_var error_string
-       in
+       mkErrorAppDs iRREFUT_PAT_ERROR_ID res_ty ""     `thenDs` \ error_msg ->
        matchSimply val_expr pat res_ty local_tuple error_msg `thenDs` \ tuple_expr ->
        mkTupleBind tyvars [] locals_and_globals tuple_expr
   where
@@ -404,10 +415,10 @@ mkTupleBind tyvars dicts local_global_prs tuple_expr
 
     tuple_var_ty :: Type
     tuple_var_ty
-      = case (quantifyTy tyvars (mkRhoTy theta
-                                 (applyTyCon (mkTupleTyCon no_of_binders)
-                                             (map idType locals)))) of
-         (_{-tossed templates-}, ty) -> ty
+      = mkForAllTys tyvars $
+       mkRhoTy theta      $
+       applyTyCon (mkTupleTyCon no_of_binders)
+                  (map idType locals)
       where
        theta = map (splitDictType . idType) dicts
 
@@ -421,17 +432,14 @@ mkTupleBind tyvars dicts local_global_prs tuple_expr
        returnDs (
            global,
            mkLam tyvars dicts (
-               mkTupleSelector (mkApp_XX (mkCoTyApps tuple_var_expr tyvar_tys) dicts)
-                               binders selected)
+               mkTupleSelector
+                   (mkValApp (mkTyApp tuple_var_expr tyvar_tys)
+                             (map VarArg dicts))
+                   binders
+                   selected)
        )
-
-mkApp_XX :: CoreExpr -> [Id] -> CoreExpr
-mkApp_XX expr []        = expr
-mkApp_XX expr (id:ids) = mkApp_XX (App expr (VarArg id)) ids
 \end{code}
 
-
-
 @mkTupleExpr@ builds a tuple; the inverse to @mkTupleSelector@.  If it
 has only one element, it is the identity function.
 \begin{code}