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
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 )
= 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
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:
\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
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 ->
\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
= 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}
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
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
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),
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 ==============
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
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 ]
\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
(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]
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
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)))
projects / ghc-hetmet.git / commitdiff