From: partain Date: Thu, 25 Apr 1996 17:39:53 +0000 (+0000) Subject: [project @ 1996-04-25 17:39:44 by partain] X-Git-Tag: Approximately_1000_patches_recorded~920 X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=f16166e4bcab8ee3598df0cad35d33f1cf6b6cf1 [project @ 1996-04-25 17:39:44 by partain] Sansom 1.3 changes to 960426 --- diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs index 8f55239..4522b96 100644 --- a/ghc/compiler/deSugar/DsExpr.lhs +++ b/ghc/compiler/deSugar/DsExpr.lhs @@ -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} diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index 2ee4182..9128954 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -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 ============== diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index d4c997a..388b8c2 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -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 ] diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs index 38e25c9..71f0228 100644 --- a/ghc/compiler/typecheck/TcTyDecls.lhs +++ b/ghc/compiler/typecheck/TcTyDecls.lhs @@ -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)))