projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
[project @ 1996-04-25 16:31:20 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
9726092
..
eeb8f26
100644
(file)
--- a/
ghc/compiler/deSugar/DsUtils.lhs
+++ b/
ghc/compiler/deSugar/DsUtils.lhs
@@
-43,18
+43,23
@@
import PprStyle ( PprStyle(..) )
import PrelInfo ( stringTy, iRREFUT_PAT_ERROR_ID )
import Pretty ( ppShow )
import Id ( idType, dataConArgTys, mkTupleCon,
import PrelInfo ( stringTy, iRREFUT_PAT_ERROR_ID )
import Pretty ( ppShow )
import Id ( idType, dataConArgTys, mkTupleCon,
+ pprId{-ToDo:rm-},
DataCon(..), DictVar(..), Id(..), GenId )
import Literal ( Literal(..) )
import TyCon ( mkTupleTyCon )
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 UniqSet ( mkUniqSet, minusUniqSet, uniqSetToList, UniqSet(..) )
-import Util ( panic, assertPanic )
+import Util ( panic, assertPanic, pprTrace{-ToDo:rm-} )
+import PprCore{-ToDo:rm-}
+import PprType--ToDo:rm
+import Pretty--ToDo:rm
+import TyVar--ToDo:rm
+import Unique--ToDo:rm
+import Usage--ToDo:rm
-quantifyTy = panic "DsUtils.quantifyTy"
splitDictType = panic "DsUtils.splitDictType"
splitDictType = panic "DsUtils.splitDictType"
-mkCoTyApps = panic "DsUtils.mkCoTyApps"
\end{code}
%************************************************************************
\end{code}
%************************************************************************
@@
-131,6
+136,7
@@
mkCoPrimCaseMatchResult var alts
mkCoAlgCaseMatchResult :: Id -- Scrutinee
-> [(DataCon, [Id], MatchResult)] -- Alternatives
-> DsM MatchResult
mkCoAlgCaseMatchResult :: Id -- Scrutinee
-> [(DataCon, [Id], MatchResult)] -- Alternatives
-> DsM MatchResult
+
mkCoAlgCaseMatchResult var alts
= -- Find all the constructors in the type which aren't
-- explicitly mentioned in the alternatives:
mkCoAlgCaseMatchResult var alts
= -- Find all the constructors in the type which aren't
-- explicitly mentioned in the alternatives:
@@
-166,7
+172,7
@@
mkCoAlgCaseMatchResult var alts
cxt1)
where
scrut_ty = idType var
cxt1)
where
scrut_ty = idType var
- (tycon, tycon_arg_tys, data_cons) = getAppDataTyCon scrut_ty
+ (tycon, tycon_arg_tys, data_cons) = pprTrace "CoAlgCase:" (pprType PprDebug scrut_ty) $ getAppDataTyCon scrut_ty
un_mentioned_constructors
= uniqSetToList (mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- alts] )
un_mentioned_constructors
= uniqSetToList (mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- alts] )
@@
-397,7
+403,9
@@
The general case:
\begin{code}
mkTupleBind tyvars dicts local_global_prs tuple_expr
\begin{code}
mkTupleBind tyvars dicts local_global_prs tuple_expr
- = newSysLocalDs tuple_var_ty `thenDs` \ tuple_var ->
+ = pprTrace "mkTupleBind:\n" (ppAboves [ppCat (map (pprId PprShowAll) locals), ppCat (map (pprId PprShowAll) globals), {-ppr PprDebug local_tuple, pprType PprDebug res_ty,-} ppr PprDebug tuple_expr]) $
+
+ newSysLocalDs tuple_var_ty `thenDs` \ tuple_var ->
zipWithDs (mk_selector (Var tuple_var))
local_global_prs
zipWithDs (mk_selector (Var tuple_var))
local_global_prs
@@
-417,10
+425,10
@@
mkTupleBind tyvars dicts local_global_prs tuple_expr
tuple_var_ty :: Type
tuple_var_ty
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
where
theta = map (splitDictType . idType) dicts
@@
-434,17
+442,14
@@
mkTupleBind tyvars dicts local_global_prs tuple_expr
returnDs (
global,
mkLam tyvars dicts (
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}
\end{code}
-
-
@mkTupleExpr@ builds a tuple; the inverse to @mkTupleSelector@. If it
has only one element, it is the identity function.
\begin{code}
@mkTupleExpr@ builds a tuple; the inverse to @mkTupleSelector@. If it
has only one element, it is the identity function.
\begin{code}