Commit f16166e4 authored by partain's avatar partain
Browse files

[project @ 1996-04-25 17:39:44 by partain]

Sansom 1.3 changes to 960426
parent a77abe6a
......@@ -31,7 +31,7 @@ import CoreUnfold ( UnfoldingDetails(..), UnfoldingGuidance(..),
import CoreUtils ( coreExprType, substCoreExpr, argToExpr,
mkCoreIfThenElse, unTagBinders )
import CostCentre ( mkUserCC )
import FieldLabel ( FieldLabel{-instance Eq/Outputable-} )
import FieldLabel ( fieldLabelType, FieldLabel )
import Id ( mkTupleCon, idType, nullIdEnv, addOneToIdEnv,
getIdUnfolding, dataConArgTys, dataConFieldLabels,
recordSelectorFieldLabel
......@@ -45,9 +45,7 @@ import PrelInfo ( mkTupleTy, unitTy, nilDataCon, consDataCon,
rEC_UPD_ERROR_ID
)
import Pretty ( ppShow, ppBesides, ppPStr, ppStr )
import Type ( splitSigmaTy, splitFunTy, typePrimRep,
getAppDataTyCon
)
import Type ( splitSigmaTy, splitFunTy, typePrimRep, getAppDataTyCon )
import TyVar ( nullTyVarEnv, addOneToTyVarEnv )
import Usage ( UVar(..) )
import Util ( zipEqual, pprError, panic, assertPanic )
......@@ -361,18 +359,18 @@ dsExpr (RecordCon con_expr rbinds)
= dsExpr con_expr `thenDs` \ con_expr' ->
let
con_id = get_con_id con_expr'
(arg_tys, data_ty) = splitFunTy (idType con_id)
mk_arg (arg_ty, lbl) = case [rhs | (sel_id,rhs,_) <- rbinds,
lbl == recordSelectorFieldLabel sel_id
] of
(rhs:rhss) -> ASSERT( null rhss )
dsExpr rhs
mk_arg lbl
= case [rhs | (sel_id,rhs,_) <- rbinds,
lbl == recordSelectorFieldLabel sel_id] of
(rhs:rhss) -> ASSERT( null rhss )
dsExpr rhs
[] -> mkErrorAppDs rEC_CON_ERROR_ID (fieldLabelType lbl) (showForErr lbl)
[] -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (showForErr lbl)
-- ToDo Bug: fieldLabelType lbl needs to be instantiated with appropriate type args
-- problem also arises if ty is extraced by splitting the type of the con_id
in
mapDs mk_arg (arg_tys `zip` dataConFieldLabels con_id) `thenDs` \ con_args ->
mapDs mk_arg (dataConFieldLabels con_id) `thenDs` \ con_args ->
mkAppDs con_expr' [] con_args
where
-- The "con_expr'" is simply an application of the constructor Id
......@@ -385,7 +383,7 @@ dsExpr (RecordCon con_expr rbinds)
Record update is a little harder. Suppose we have the decl:
data T = T1 {op1, op2, op3 :: Int}
| T2 {op4, op1 :: Int}
| T2 {op4, op2 :: Int}
| T3
Then we translate as follows:
......@@ -405,12 +403,11 @@ dictionaries.
\begin{code}
dsExpr (RecordUpdOut record_expr dicts rbinds)
= dsExpr record_expr `thenDs` \ record_expr' ->
= dsExpr record_expr `thenDs` \ record_expr' ->
-- Desugar the rbinds, and generate let-bindings if
-- necessary so that we don't lose sharing
-- dsRbinds rbinds $ \ rbinds' ->
let rbinds' = panic "dsExpr:RecordUpdOut:rbinds'" in
dsRbinds rbinds $ \ rbinds' ->
let
record_ty = coreExprType record_expr'
(tycon, inst_tys, cons) = _trace "getAppDataTyCon.DsExpr" $ getAppDataTyCon record_ty
......@@ -420,10 +417,11 @@ dsExpr (RecordUpdOut record_expr dicts rbinds)
initial_args = map TyArg inst_tys ++ map VarArg dicts
mk_val_arg (field, arg_id)
= case [arg | (f, arg) <- rbinds', f==field] of
(arg:args) -> ASSERT(null args)
arg
[] -> VarArg arg_id
= case [arg | (f, arg) <- rbinds',
field == recordSelectorFieldLabel f] of
(arg:args) -> ASSERT(null args)
arg
[] -> VarArg arg_id
mk_alt con
= newSysLocalsDs (dataConArgTys con inst_tys) `thenDs` \ arg_ids ->
......@@ -611,7 +609,7 @@ apply_to_args fun args
\begin{code}
dsRbinds :: TypecheckedRecordBinds -- The field bindings supplied
-> ([(Id, CoreArg)] -> DsM CoreExpr) -- A continuation taking the field
-- bindings with atomic rhss
-- bindings with atomic rhss
-> DsM CoreExpr -- The result of the continuation,
-- wrapped in suitable Lets
......@@ -622,7 +620,7 @@ dsRbinds ((sel_id, rhs, pun_flag) : rbinds) continue_with
= dsExpr rhs `thenDs` \ rhs' ->
dsExprToAtom rhs' $ \ rhs_atom ->
dsRbinds rbinds $ \ rbinds' ->
continue_with ((panic "dsRbinds:field_label?"{-sel_id-}, rhs_atom) : rbinds')
continue_with ((sel_id, rhs_atom) : rbinds')
\end{code}
\begin{code}
......
......@@ -15,18 +15,20 @@ import Class ( GenClass{-instance NamedThing-} )
import CmdLineOpts ( opt_ProduceHi )
import HsSyn
import Id ( GenId{-instance NamedThing/Outputable-} )
import Name ( nameOrigName, exportFlagOn, nameExportFlag, ExportFlag(..),
import Name ( nameOrigName, origName,
exportFlagOn, nameExportFlag, ExportFlag(..),
ltLexical, isExported,
RdrName{-instance Outputable-}
)
import PprStyle ( PprStyle(..) )
import PprType ( TyCon{-instance Outputable-}, GenClass{-ditto-} )
import PprType ( pprType, TyCon{-instance Outputable-}, GenClass{-ditto-} )
import Pretty -- quite a bit
import RnHsSyn ( RenamedHsModule(..), RnName{-instance NamedThing-} )
import RnIfaces ( VersionInfo(..) )
import TcModule ( TcIfaceInfo(..) )
import TcInstUtil ( InstInfo )
import TcInstUtil ( InstInfo(..) )
import TyCon ( TyCon{-instance NamedThing-} )
import Type ( mkSigmaTy, mkDictTy, getAppTyCon )
import Util ( sortLt, assertPanic )
ppSemid x = ppBeside (ppr PprInterface x) ppSemi -- micro util
......@@ -176,8 +178,7 @@ ifaceFixities (Just if_hdl) (HsModule _ _ _ _ fixities _ _ _ _ _ _ _ _ _)
ifaceDecls Nothing{-no iface handle-} _ = return ()
ifaceDecls (Just if_hdl) (vals, tycons, classes, _)
= ASSERT(not (null vals && null tycons && null classes))
let
= let
exported_classes = filter isExported classes
exported_tycons = filter isExported tycons
exported_vals = filter isExported vals
......@@ -186,6 +187,8 @@ ifaceDecls (Just if_hdl) (vals, tycons, classes, _)
sorted_tycons = sortLt ltLexical exported_tycons
sorted_vals = sortLt ltLexical exported_vals
in
ASSERT(not (null exported_classes && null exported_tycons && null exported_vals))
hPutStr if_hdl "\n__declarations__\n" >>
hPutStr if_hdl (ppShow 100 (ppAboves [
ppAboves (map ppSemid sorted_classes),
......@@ -197,23 +200,36 @@ ifaceDecls (Just if_hdl) (vals, tycons, classes, _)
ifaceInstances Nothing{-no iface handle-} _ = return ()
ifaceInstances (Just if_hdl) (_, _, _, insts)
= return ()
{-
let
exported_classes = filter isExported classes
exported_tycons = filter isExported tycons
exported_vals = filter isExported vals
= let
exported_insts = filter is_exported_inst (bagToList insts)
sorted_classes = sortLt ltLexical exported_classes
sorted_tycons = sortLt ltLexical exported_tycons
sorted_vals = sortLt ltLexical exported_vals
sorted_insts = sortLt lt_inst exported_insts
in
hPutStr if_hdl "\n__declarations__\n" >>
hPutStr if_hdl (ppShow 100 (ppAboves [
ppAboves (map ppSemid sorted_classes),
ppAboves (map ppSemid sorted_tycons),
ppAboves (map ppSemid sorted_vals)]))
-}
if null exported_insts then
return ()
else
hPutStr if_hdl "\n__instances__\n" >>
hPutStr if_hdl (ppShow 100 (ppAboves (map pp_inst sorted_insts)))
where
is_exported_inst (InstInfo clas _ ty _ _ _ _ _ from_here _ _ _)
= from_here -- && ...
-------
lt_inst (InstInfo clas1 _ ty1 _ _ _ _ _ _ _ _ _)
(InstInfo clas2 _ ty2 _ _ _ _ _ _ _ _ _)
= let
tycon1 = fst (getAppTyCon ty1)
tycon2 = fst (getAppTyCon ty2)
in
case (origName clas1 `cmp` origName clas2) of
LT_ -> True
GT_ -> False
EQ_ -> origName tycon1 < origName tycon2
-------
pp_inst (InstInfo clas tvs ty theta _ _ _ _ _ _ _ _)
= ppBeside (ppPStr SLIT("instance "))
(pprType PprInterface (mkSigmaTy tvs theta (mkDictTy clas ty)))
\end{code}
=== ALL OLD BELOW HERE ==============
......
......@@ -340,8 +340,9 @@ doImportDecls iface_cache g_info us src_imps
imp_warns `unionBags` warns)
where
(ok_imps, src_qprels) = partition not_qual_prel src_imps
all_imps = qprel_imp ++ prel_imp ++ ok_imps
the_imps = prel_imp ++ ok_imps
all_imps = qprel_imp ++ the_imps
not_qual_prel (ImportDecl mod qual _ _ _) = not (fromPrelude mod && qual)
explicit_prelude_import
......@@ -358,7 +359,7 @@ doImportDecls iface_cache g_info us src_imps
else
[ImportDecl pRELUDE False Nothing Nothing mkIfaceSrcLoc]
(uniq_imps, imp_dups) = removeDups cmp_mod all_imps
(uniq_imps, imp_dups) = removeDups cmp_mod the_imps
cmp_mod (ImportDecl m1 _ _ _ _) (ImportDecl m2 _ _ _ _) = cmpPString m1 m2
imp_mods = [ mod | ImportDecl mod _ _ _ _ <- uniq_imps ]
......
......@@ -192,7 +192,7 @@ We're going to build a constructor that looks like:
\d1::Data a, d2::C b ->
\p q r -> case p of { p ->
case q of { q ->
HsCon [a,b,c] [p,q,r]}}
HsCon T1 [a,b] [p,q,r]}}
Notice that
......@@ -220,12 +220,12 @@ mkConstructor con_id
(arg_tys, result_ty) = splitFunTy tau
n_args = length arg_tys
in
newLocalIds (take n_args (repeat SLIT("con"))) arg_tys `thenNF_Tc` {- \ pre_zonk_args ->
mapNF_Tc zonkId pre_zonk_args `thenNF_Tc` -} \ args ->
newLocalIds (take n_args (repeat SLIT("con"))) arg_tys
`thenNF_Tc` \ args ->
-- Check that all the types of all the strict
-- arguments are in Data. This is trivially true of everything except
-- type variables, for which we must check the context.
-- Check that all the types of all the strict arguments are in Data.
-- This is trivially true of everything except type variables, for
-- which we must check the context.
let
strict_marks = dataConStrictMarks con_id
strict_args = [arg | (arg, MarkedStrict) <- args `zipEqual` strict_marks]
......@@ -233,14 +233,13 @@ mkConstructor con_id
data_tyvars = -- The tyvars in the constructor's context that are arguments
-- to the Data class
[getTyVar "mkConstructor" ty
| (clas,ty) <- theta,
uniqueOf clas == evalClassKey]
| (clas,ty) <- theta, uniqueOf clas == evalClassKey]
check_data arg = case getTyVar_maybe (tcIdType arg) of
Nothing -> returnTc () -- Not a tyvar, so OK
Just tyvar -> checkTc (tyvar `elem` data_tyvars) (missingDataErr tyvar)
in
mapTc check_data strict_args `thenTc_`
mapTc check_data strict_args `thenTc_`
-- Build the data constructor
let
......@@ -248,7 +247,7 @@ mkConstructor con_id
mkHsDictLam dicts $
mk_pat_match args $
mk_case strict_args $
HsCon con_id arg_tys (map HsVar args)
HsCon con_id (mkTyVarTys tyvars) (map HsVar args)
mk_pat_match [] body = body
mk_pat_match (arg:args) body = HsLam (PatMatch (VarPat arg) (SimpleMatch (mk_pat_match args body)))
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment