import DsLoop -- break dsExpr-ish loop
import HsSyn -- lots of things
+ hiding ( collectBinders{-also in CoreSyn-} )
import CoreSyn -- lots of things
import TcHsSyn ( TypecheckedHsBinds(..), TypecheckedHsExpr(..),
- TypecheckedBind(..), TypecheckedMonoBinds(..) )
+ TypecheckedBind(..), TypecheckedMonoBinds(..),
+ TypecheckedPat(..)
+ )
import DsHsSyn ( collectTypedBinders, collectTypedPatBinders )
import DsMonad
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, GenTyVar )
+import PprType ( GenType )
import PprStyle ( PprStyle(..) )
import Pretty ( ppShow )
-import Type ( mkTyVarTy, splitSigmaTy )
-import TyVar ( GenTyVar )
-import Unique ( Unique )
-import Util ( isIn, panic )
+import Type ( mkTyVarTys, mkForAllTys, splitSigmaTy,
+ tyVarsOfType, tyVarsOfTypes
+ )
+import TyVar ( tyVarSetToList, GenTyVar{-instance Eq-} )
+import Util ( isIn, panic, pprTrace{-ToDo:rm-} )
+import PprCore--ToDo:rm
+import PprType ( GenTyVar ) --ToDo:rm
+import Usage--ToDo:rm
+import Unique--ToDo:rm
-extractTyVarsFromTy = panic "DsBinds.extractTyVarsFromTy"
-extractTyVarsFromTys = panic "DsBinds.extractTyVarsFromTys"
isDictTy = panic "DsBinds.isDictTy"
-quantifyTy = panic "DsBinds.quantifyTy"
\end{code}
%************************************************************************
-- 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 = map mkTyVarTy tyvars
+ tyvar_tys = mkTyVarTys tyvars
\end{code}
returnDs [ NonRec binder rhs | (binder,rhs) <- core_bind_prs ]
where
locals = [local | (local,global) <- local_global_prs]
- non_ov_tyvar_tys = map mkTyVarTy non_overloaded_tyvars
+ non_ov_tyvar_tys = mkTyVarTys non_overloaded_tyvars
- overloaded_tyvars = extractTyVarsFromTys (map idType dicts)
- non_overloaded_tyvars = all_tyvars `minusList` overloaded_tyvars
+ overloaded_tyvars = tyVarsOfTypes (map idType dicts)
+ 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).
= returnDs ty_app -- Common case
| otherwise
= newTyVarsDs (drop (length tys) tvs) `thenDs` \ tyvars ->
- returnDs (mkTyLam tyvars (mkTyApp ty_app (map mkTyVarTy tyvars)))
+ returnDs (mkTyLam tyvars (mkTyApp ty_app (mkTyVarTys tyvars)))
where
(tvs, theta, tau_ty) = splitSigmaTy (idType id)
ty_app = mkTyApp (Var id) tys
do_nothing = ([], []) -- out here to avoid dsInstBinds CAF (sigh)
prel_dicts_cc = preludeDictsCostCentre False{-not dupd-} -- ditto
-dsInstBinds tyvars []
- = returnDs do_nothing
-
-dsInstBinds _ _ = panic "DsBinds.dsInstBinds:maybe we want something different?"
-
-{- LATER
+dsInstBinds tyvars [] = returnDs do_nothing
dsInstBinds tyvars ((inst, expr@(HsVar _)) : bs)
- = dsExpr expr `thenDs` ( \ rhs ->
+ = dsExpr expr `thenDs` \ rhs ->
let -- Need to apply dsExpr to the variable in case it
-- has a substitution in the current environment
subst_item = (inst, rhs)
in
extendEnvDs [subst_item] (
dsInstBinds tyvars bs
- ) `thenDs` (\ (binds, subst_env) ->
+ ) `thenDs` \ (binds, subst_env) ->
returnDs (binds, subst_item : subst_env)
- ))
dsInstBinds tyvars ((inst, expr@(HsLit _)) : bs)
- = dsExpr expr `thenDs` ( \ core_lit ->
+ = dsExpr expr `thenDs` \ core_lit ->
let
subst_item = (inst, core_lit)
in
extendEnvDs [subst_item] (
dsInstBinds tyvars bs
- ) `thenDs` (\ (binds, subst_env) ->
+ ) `thenDs` \ (binds, subst_env) ->
returnDs (binds, subst_item : subst_env)
- ))
dsInstBinds tyvars ((inst, expr) : bs)
| null abs_tyvars
subst_item : subst_env)
where
inst_ty = idType inst
- abs_tyvars = extractTyVarsFromTy inst_ty `intersectLists` tyvars
- abs_tys = map mkTyVarTy abs_tyvars
- (_, poly_inst_ty) = quantifyTy abs_tyvars inst_ty
+ abs_tyvars = tyVarSetToList{-???sigh-} (tyVarsOfType inst_ty) `intersectLists` tyvars
+ abs_tys = mkTyVarTys abs_tyvars
+ poly_inst_ty = mkForAllTys abs_tyvars inst_ty
------------------------
-- Wrap a desugared expression in `_scc_ "DICT" <expr>' if
-- appropriate. Uses "inst"'s type.
+ -- if profiling, wrap the dict in "_scc_ DICT <dict>":
ds_dict_cc expr
- = -- if profiling, wrap the dict in "_scc_ DICT <dict>":
- let
- doing_profiling = opt_SccProfilingOn
- compiling_prelude = opt_CompilingPrelude
- in
- if not doing_profiling
- || not (isDictTy inst_ty) then -- that's easy: do nothing
- returnDs expr
- else if compiling_prelude then
- returnDs (SCC prel_dicts_cc expr)
- else
- getModuleAndGroupDs `thenDs` \ (mod_name, grp_name) ->
+ | not opt_SccProfilingOn ||
+ not (isDictTy inst_ty)
+ = returnDs expr -- that's easy: do nothing
+
+ | opt_CompilingPrelude
+ = returnDs (SCC prel_dicts_cc expr)
+
+ | otherwise
+ = getModuleAndGroupDs `thenDs` \ (mod_name, grp_name) ->
-- ToDo: do -dicts-all flag (mark dict things
-- with individual CCs)
- let
+ let
dict_cc = mkAllDictsCC mod_name grp_name False{-not dupd-}
- in
- returnDs (SCC dict_cc expr)
--}
+ in
+ returnDs (SCC dict_cc expr)
\end{code}
%************************************************************************
\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}
%==============================================
\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
-- we can just use the rhs directly
else
-}
+ pprTrace "dsMonoBinds:PatMonoBind:" (ppr PprDebug body_expr) $
+
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
projects / ghc-hetmet.git / blobdiff