Commit 04dee693 authored by apt's avatar apt
Browse files

[project @ 2001-08-27 14:29:16 by apt]

use qualified names to indicate external status of values
parent 3a244137
......@@ -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
......
......@@ -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
......
......@@ -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
......
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