Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
jberryman
GHC
Commits
04dee693
Commit
04dee693
authored
Aug 27, 2001
by
apt
Browse files
[project @ 2001-08-27 14:29:16 by apt]
use qualified names to indicate external status of values
parent
3a244137
Changes
3
Hide whitespace changes
Inline
Side-by-side
ghc/compiler/coreSyn/ExternalCore.lhs
View file @
04dee693
...
...
@@ -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
...
...
ghc/compiler/coreSyn/MkExternalCore.lhs
View file @
04dee693
...
...
@@ -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_
q
id (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_
q
id (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_
q
id (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
...
...
ghc/compiler/coreSyn/PprExternalCore.lhs
View file @
04dee693
...
...
@@ -39,30 +39,23 @@ instance Show Lit where
indent = nest 2
pmodule (Module mname
{- (texports,dexports,vexports) -}
tdefs vdefs) =
pmodule (Module mname tdefs vdef
g
s) =
(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" <+> p
q
name 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" <+> p
q
name 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)])
(p
q
name 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 [p
q
name v <+> text "::" <+> pty t <+> char '=',
indent (pexp e)]
paexp (Var x) = pqname x
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment