From 04dee6938d904365fdbc5ad44801f6dd17a63157 Mon Sep 17 00:00:00 2001 From: apt Date: Mon, 27 Aug 2001 14:29:16 +0000 Subject: [PATCH] [project @ 2001-08-27 14:29:16 by apt] use qualified names to indicate external status of values --- ghc/compiler/coreSyn/ExternalCore.lhs | 33 +++-------------- ghc/compiler/coreSyn/MkExternalCore.lhs | 57 ++++++------------------------ ghc/compiler/coreSyn/PprExternalCore.lhs | 19 ++++------ 3 files changed, 21 insertions(+), 88 deletions(-) diff --git a/ghc/compiler/coreSyn/ExternalCore.lhs b/ghc/compiler/coreSyn/ExternalCore.lhs index 9ed748f..8ddc7da 100644 --- a/ghc/compiler/coreSyn/ExternalCore.lhs +++ b/ghc/compiler/coreSyn/ExternalCore.lhs @@ -8,20 +8,20 @@ module ExternalCore where import List (elemIndex) data Module - = Module Mname [Tdef] [(Bool,Vdefg)] + = Module Mname [Tdef] [Vdefg] data Tdef - = Data Tcon [Tbind] [Cdef] - | Newtype Tcon [Tbind] (Maybe Ty) + = Data (Qual Tcon) [Tbind] [Cdef] + | Newtype (Qual Tcon) [Tbind] (Maybe Ty) data Cdef - = Constr Dcon [Tbind] [Ty] + = Constr (Qual Dcon) [Tbind] [Ty] data Vdefg = Rec [Vdef] | Nonrec Vdef -type Vdef = (Var,Ty,Exp) +type Vdef = (Qual Var,Ty,Exp) data Exp = Var (Qual Var) @@ -59,14 +59,12 @@ data Kind | Kunlifted | Kopen | Karrow Kind Kind - deriving (Eq) data Lit = Lint Integer Ty | Lrational Rational Ty | Lchar Char Ty | Lstring String Ty - deriving (Eq) type Mname = Id @@ -79,27 +77,6 @@ type Qual t = (Mname,t) type Id = String -equalTy t1 t2 = eqTy [] [] t1 t2 - where eqTy e1 e2 (Tvar v1) (Tvar v2) = - case (elemIndex v1 e1,elemIndex v2 e2) of - (Just i1, Just i2) -> i1 == i2 - (Nothing, Nothing) -> v1 == v2 - _ -> False - eqTy e1 e2 (Tcon c1) (Tcon c2) = c1 == c2 - eqTy e1 e2 (Tapp t1a t1b) (Tapp t2a t2b) = - eqTy e1 e2 t1a t2a && eqTy e1 e2 t1b t2b - eqTy e1 e2 (Tforall (tv1,tk1) t1) (Tforall (tv2,tk2) t2) = - tk1 == tk2 && eqTy (tv1:e1) (tv2:e2) t1 t2 - eqTy _ _ _ _ = False - -instance Eq Ty where (==) = equalTy - -subKindOf :: Kind -> Kind -> Bool -_ `subKindOf` Kopen = True -k1 `subKindOf` k2 = k1 == k2 -- don't worry about higher kinds - -instance Ord Kind where (<=) = subKindOf - primMname = "PrelGHC" tcArrow :: Qual Tcon diff --git a/ghc/compiler/coreSyn/MkExternalCore.lhs b/ghc/compiler/coreSyn/MkExternalCore.lhs index cb89c9a..f3622eb 100644 --- a/ghc/compiler/coreSyn/MkExternalCore.lhs +++ b/ghc/compiler/coreSyn/MkExternalCore.lhs @@ -47,52 +47,20 @@ emitExternalCore _ _ _ mkExternalCore :: ModIface -> ModDetails -> C.Module mkExternalCore (ModIface {mi_module=mi_module,mi_exports=mi_exports}) (ModDetails {md_types=md_types,md_binds=md_binds}) = - C.Module mname {- exports -} tdefs vdefs + C.Module mname tdefs vdefs where mname = make_mid mi_module -{- exports = foldr (collect_exports md_types) ([],[],[]) all_avails - all_avails = concat (map snd (filter ((== moduleName mi_module) . fst) mi_exports)) --} tdefs = foldr collect_tdefs [] (typeEnvTyCons md_types) vdefs = map make_vdef md_binds -{- -collect_exports :: TypeEnv -> AvailInfo -> ([C.Tcon],[C.Dcon],[C.Var]) -> ([C.Tcon],[C.Dcon],[C.Var]) -collect_exports tyenv (Avail n) (tcons,dcons,vars) = (tcons,dcons,make_var_id n:vars) -collect_exports tyenv (AvailTC n ns) (tcons,dcons,vars) = - case lookupNameEnv_NF tyenv n of - ATyCon tc | isAlgTyCon tc -> - (tcon ++ tcons,workers ++ dcons,wrappers ++ vars) - where - tcon = if elem n ns then [make_con_id n] else [] - workers = if isNewTyCon tc then [] - else map (make_con_id . idName . dataConId) exported_dcs - exported_dcs = filter (\dc -> elem ((idName . dataConWrapId) dc) ns') dcs - dcs = tyConDataConsIfAvailable tc - wrappers = map make_var_id ns' - ns' = filter (\n' -> n' /= n && not (elem n' recordSels)) ns - recordSels = map idName (tyConSelIds tc) - AClass cl -> {- maybe a little too free about exports -} - (tcon : tcons,workers ++ dcons,wrappers ++ vars) - where - tcon = make_con_id (tyConName tc) - workers = if isNewTyCon tc then [] - else map (make_con_id . idName . dataConId) dcs - wrappers = map (make_var_id . idName . dataConWrapId) dcs - dcs = tyConDataConsIfAvailable tc - tc = classTyCon cl - _ -> (tcons,dcons,vars) --} - - collect_tdefs :: TyCon -> [C.Tdef] -> [C.Tdef] collect_tdefs tcon tdefs | isAlgTyCon tcon = tdef: tdefs where tdef | isNewTyCon tcon = - C.Newtype (make_con_id (tyConName tcon)) (map make_tbind tyvars) repclause + C.Newtype (make_con_qid (tyConName tcon)) (map make_tbind tyvars) repclause | otherwise = - C.Data (make_con_id (tyConName tcon)) (map make_tbind tyvars) (map make_cdef (tyConDataCons tcon)) + C.Data (make_con_qid (tyConName tcon)) (map make_tbind tyvars) (map make_cdef (tyConDataCons tcon)) where repclause | isRecursiveTyCon tcon = Nothing | otherwise = Just (make_ty rep) where (_, rep) = newTyConRep tcon @@ -104,7 +72,7 @@ collect_tdefs _ tdefs = tdefs make_cdef :: DataCon -> C.Cdef make_cdef dcon = C.Constr dcon_name existentials tys where - dcon_name = make_con_id (idName (dataConId dcon)) + dcon_name = make_con_qid (idName (dataConId dcon)) existentials = map make_tbind ex_tyvars where (_,_,ex_tyvars,_,_,_) = dataConSig dcon tys = map make_ty (dataConRepArgTys dcon) @@ -115,14 +83,12 @@ make_tbind tv = (make_var_id (tyVarName tv), make_kind (tyVarKind tv)) make_vbind :: Var -> C.Vbind make_vbind v = (make_var_id (Var.varName v), make_ty (varType v)) -make_vdef :: CoreBind -> (Bool, C.Vdefg) +make_vdef :: CoreBind -> C.Vdefg make_vdef b = case b of - NonRec v e -> (isGlobalId v,C.Nonrec (f (v,e))) - Rec ves -> (or (map g ves),C.Rec (map f ves)) - where f (v,e) = (n,t,make_exp e) - where (n,t) = make_vbind v - g (v,e) = isGlobalId v + NonRec v e -> C.Nonrec (f (v,e)) + Rec ves -> C.Rec (map f ves) + where f (v,e) = (make_var_qid (Var.varName v), make_ty (varType v),make_exp e) make_exp :: CoreExpr -> C.Exp make_exp (Var v) = @@ -137,7 +103,7 @@ make_exp (App e (Type t)) = C.Appt (make_exp e) (make_ty t) make_exp (App e1 e2) = C.App (make_exp e1) (make_exp e2) make_exp (Lam v e) | isTyVar v = C.Lam (C.Tb (make_tbind v)) (make_exp e) make_exp (Lam v e) | otherwise = C.Lam (C.Vb (make_vbind v)) (make_exp e) -make_exp (Let b e) = C.Let (snd (make_vdef b)) (make_exp e) +make_exp (Let b e) = C.Let (make_vdef b) (make_exp e) make_exp (Case e v alts) = C.Case (make_exp e) (make_vbind v) (map make_alt alts) make_exp (Note (SCC cc) e) = C.Note "SCC" (make_exp e) -- temporary make_exp (Note (Coerce t_to t_from) e) = C.Coerce (make_ty t_to) (make_exp e) @@ -204,9 +170,6 @@ make_id is_var nm = make_var_id :: Name -> C.Id make_var_id = make_id True -make_con_id :: Name -> C.Id -make_con_id = make_id False - make_mid :: Module -> C.Id make_mid = moduleNameString . moduleName @@ -215,7 +178,7 @@ make_qid is_var n = (mname,make_id is_var n) where mname = case nameModule_maybe n of Just m -> make_mid m - Nothing -> "" -- for now! + Nothing -> "" make_var_qid :: Name -> C.Qual C.Id make_var_qid = make_qid True diff --git a/ghc/compiler/coreSyn/PprExternalCore.lhs b/ghc/compiler/coreSyn/PprExternalCore.lhs index 16acc68..73536fa 100644 --- a/ghc/compiler/coreSyn/PprExternalCore.lhs +++ b/ghc/compiler/coreSyn/PprExternalCore.lhs @@ -39,30 +39,23 @@ instance Show Lit where indent = nest 2 -pmodule (Module mname {- (texports,dexports,vexports) -} tdefs vdefs) = +pmodule (Module mname tdefs vdefgs) = (text "%module" <+> text mname) -{- $$ indent (parens (((fsep (map pname texports) <> char ',') - $$ (fsep (map pname dexports) <> char ',') - $$ (fsep (map pname vexports)))) --} $$ indent ((vcat (map ((<> char ';') . ptdef) tdefs)) - $$ (vcat (map ((<> char ';') . pgvdef) vdefs))) - -pgvdef (False,vdef) = text "%local" <+> pvdefg vdef -pgvdef (True,vdef) = pvdefg vdef + $$ (vcat (map ((<> char ';') . pvdefg) vdefgs))) ptdef (Data tcon tbinds cdefs) = - (text "%data" <+> pname tcon <+> (hsep (map ptbind tbinds)) <+> char '=') + (text "%data" <+> pqname tcon <+> (hsep (map ptbind tbinds)) <+> char '=') $$ indent (braces ((vcat (punctuate (char ';') (map pcdef cdefs))))) ptdef (Newtype tcon tbinds rep ) = - text "%newtype" <+> pname tcon <+> (hsep (map ptbind tbinds)) <+> repclause + text "%newtype" <+> pqname tcon <+> (hsep (map ptbind tbinds)) <+> repclause where repclause = case rep of Just ty -> char '=' <+> pty ty Nothing -> empty pcdef (Constr dcon tbinds tys) = - (pname dcon) <+> (sep [hsep (map pattbind tbinds),sep (map paty tys)]) + (pqname dcon) <+> (sep [hsep (map pattbind tbinds),sep (map paty tys)]) pname id = text id @@ -103,7 +96,7 @@ pforall tbs t = hsep (map ptbind tbs) <+> char '.' <+> pty t pvdefg (Rec vtes) = text "%rec" $$ braces (indent (vcat (punctuate (char ';') (map pvte vtes)))) pvdefg (Nonrec vte) = pvte vte -pvte (v,t,e) = sep [pname v <+> text "::" <+> pty t <+> char '=', +pvte (v,t,e) = sep [pqname v <+> text "::" <+> pty t <+> char '=', indent (pexp e)] paexp (Var x) = pqname x -- 1.7.10.4