{-| Translating a Haskell core abstract syntax, which has gone through case-abstraction and lambda-lifting already, to Agda abstract syntax.
Authors: Patrik Jansson, Gregoire Hamon -}
module Core2Agda(core2agda) where
import Agda.Abs as A --^ Agda abstract syntax
import ExternalCore as C --^ GHC Core abstract syntax (from GHC suite)
import UnObfusc --^ name unmangling (from GHC suite)
-- for debugging
import PprExternalCore --^ pretty printer for core (form GHC suite)
import Debug.Trace
data Ctx = C { modName :: String } --^ name of the current module
undef :: String -> a
undef = error
core2agda :: C.Module -> A.Module
core2agda (C.Module mname tdefs vdefgs) = A.Module decls
where ctx = C { modName = mname }
decls = map (noattrdef ctx) defs
defs = typedefs : vdefs
typedefs = Mutual (map (c2a_tdef ctx) tdefs)
vdefs = map (c2a_vdefg ctx) vdefgs
noattrdef :: Ctx -> A.Def -> A.Decl
noattrdef ctx = DDef []
c2a_vdefg_decls :: Ctx -> C.Vdefg -> [A.Decl]
c2a_vdefg_decls ctx vdefg = [c2a_vdefg_decl ctx vdefg]
c2a_vdefg_decl :: Ctx -> C.Vdefg -> A.Decl
c2a_vdefg_decl ctx vdefg = noattrdef ctx (c2a_vdefg ctx vdefg)
c2a_vdefg :: Ctx -> C.Vdefg -> A.Def
c2a_vdefg ctx vdefg = case vdefg of
Rec [vdef] -> c2a_vdef ctx vdef
Rec vdefs -> Mutual (map (c2a_vdef ctx) vdefs)
Nonrec vdef -> c2a_vdef ctx vdef
c2a_vdef :: Ctx -> C.Vdef -> A.Def
c2a_vdef ctx ((mod, var), ty, exp) = Value id [] et ev
where id = c2a_qvar ctx (unObfusc mod, unObfusc var)
et = c2a_ty_exp ctx ty
ev = c2a_exp_exp ctx exp
c2a_tdef :: Ctx -> C.Tdef -> A.Def
c2a_tdef ctx tdef = case tdef of
C.Data qtcon tbinds cdefs -> A.Data aident typings constructors
where aident = c2a_qtcon ctx qtcon
typings = map (c2a_tbind_typing ctx) tbinds
constructors = map (c2a_cdef ctx) cdefs
Newtype qtcon tbinds (Just ty) -> A.Data aident typings constructors
where aident = c2a_qtcon ctx qtcon
typings = map (c2a_tbind_typing ctx) tbinds
constructors = [Cnstr con [dummy]]
con = c2a_qtcon ctx qtcon
dummy = c2a_ty_typing ctx "dummy" ty
Newtype qtcon tbinds Nothing -> Axiom aident typings exp
where aident = c2a_qtcon ctx qtcon
typings = map (c2a_tbind_typing ctx) tbinds
exp = ESet
c2a_cdef :: Ctx -> C.Cdef -> A.Constructor
c2a_cdef ctx (Constr qdcon [] tys) = Cnstr aident typings
where aident = c2a_qdcon ctx qdcon
typings = zipWith (c2a_ty_typing ctx) dummys tys
-- Wrong: perhaps corrected
dummys :: [Id]
dummys = map (('x':).show) [1..]
qualifyname :: Ctx -> Qual Id -> Id
qualifyname ctx (mname, id) = coreToPrelude fullName
where fullName = case mname of
"" -> unObfusc id
s | (modName ctx) == s -> unObfusc id
s -> (unObfusc s) ++ "." ++ (unObfusc id)
c2a_qtcon :: Ctx -> Qual Tcon -> AIdent
c2a_qtcon ctx = c2a_id . (qualifyTcon ctx)
c2a_qvar :: Ctx -> Qual Var -> AIdent
c2a_qvar ctx = c2a_id . (qualifyname ctx)
c2a_qdcon :: Ctx -> Qual Dcon -> AIdent
c2a_qdcon ctx = c2a_id . (qualifyname ctx)
c2a_var :: Ctx -> Var -> AIdent
c2a_var ctx = c2a_id
c2a_dcon :: Ctx -> Dcon -> AIdent
c2a_dcon ctx = c2a_id
c2a_ty_typing :: Ctx -> Id -> Ty -> Typing
c2a_ty_typing ctx name ty = TDecl (VDecl (c2a_id name) (c2a_ty_exp ctx ty))
c2a_ty_typing' :: Ctx -> Ty -> Typing
c2a_ty_typing' ctx ty = TExp (c2a_ty_exp ctx ty)
-- Embedd types as Agda expressions
c2a_ty_exp :: Ctx -> Ty -> A.Exp
c2a_ty_exp ctx ty = case ty of
Tvar tvar -> EVar (c2a_tvar ctx tvar)
Tcon qtcon -> EVar (c2a_qtcon ctx qtcon)
Tapp (Tapp (Tcon fun) ty1) ty2 | fun == tcArrow
-> EFun et ev
where et = c2a_ty_exp ctx ty1
ev = c2a_ty_exp ctx ty2
Tapp ty1 ty2 -> EApp (c2a_ty_exp ctx ty1) (c2a_ty_exp ctx ty2)
Tforall tbind ty -> EPi (c2a_tbind_vardecl ctx tbind) (c2a_ty_exp ctx ty)
c2a_tvar :: Ctx -> Tvar -> AIdent
c2a_tvar ctx = c2a_id . typeName
c2a_id :: Id -> AIdent
c2a_id id = F (Ident (unObfusc id))
c2a_tbind_typing :: Ctx -> Tbind -> Typing
c2a_tbind_typing ctx = TDecl . (c2a_tbind_vardecl ctx)
c2a_tbind_vardecl :: Ctx -> Tbind -> VarDecl
c2a_tbind_vardecl ctx (tvar,kind) = VDecl id e
where id = c2a_tvar ctx tvar
e = c2a_kind ctx kind
c2a_vbind_vardecl :: Ctx -> Vbind -> VarDecl
c2a_vbind_vardecl ctx (var,ty) = VDecl (c2a_var ctx var) (c2a_ty_exp ctx ty)
c2a_tbind_aident :: Ctx -> Tbind -> AIdent
c2a_tbind_aident ctx (tvar,_kind) = c2a_tvar ctx tvar
c2a_vbind_aident :: Ctx -> Vbind -> AIdent
c2a_vbind_aident ctx (var, _ty) = c2a_var ctx var
c2a_bind_vardecl :: Ctx -> Bind -> VarDecl
c2a_bind_vardecl ctx bind =
case bind of
Vb vbind -> c2a_vbind_vardecl ctx vbind
Tb tbind -> c2a_tbind_vardecl ctx tbind
c2a_kind :: Ctx -> Kind -> A.Exp
c2a_kind ctx kind = case kind of
Klifted -> ESet -- an approximation
Kunlifted -> ESet -- an approximation
Kopen -> ESet -- an approximation
Karrow kind1 kind2 -> EFun (c2a_kind ctx kind1) (c2a_kind ctx kind2)
wildcard :: A.Exp
wildcard = EMeta -- the placeholder comes in handy (;-)
--| Translate Core expression to Agda expression.
c2a_exp_exp :: Ctx -> C.Exp -> A.Exp
c2a_exp_exp ctx e = case e of
Var qvar -> EVar (c2a_qvar ctx qvar)
Dcon qdcon -> ECon (c2a_qdcon ctx qdcon)
Lit lit -> c2a_lit ctx lit
App exp1 exp2 -> case exp1' of
EVar (F (Ident "?")) -> exp1'
_ -> EApp exp1' (c2a_exp_exp ctx exp2)
where exp1' = c2a_exp_exp ctx exp1
Appt exp ty -> case exp' of
EVar (F (Ident "GHC.Err.patError")) -> EVar (F (Ident "?"))
ECon qd -> exp'
_ -> EApp exp' (c2a_ty_exp ctx ty)
where exp' = c2a_exp_exp ctx exp
Lam bind exp -> EAbs binder body
where binder = c2a_bind_vardecl ctx bind
body = c2a_exp_exp ctx exp
Let vdefg exp -> ELet locdef body
where locdef = c2a_vdefg_decls ctx vdefg
body = c2a_exp_exp ctx exp
Case exp vbind alts -> ECase (EVar var') branchs
where (var,ty) = vbind
var' = c2a_var ctx var
decl = noattrdef ctx (Value var' [] (c2a_ty_exp ctx ty)
(c2a_exp_exp ctx exp))
branchs = map (c2a_alt ctx) alts
Coerce ty exp -> c2a_exp_exp ctx exp
-- Coerce ty exp -> wildcard
Note string exp -> c2a_exp_exp ctx exp
External string ty -> wildcard
c2a_alt :: Ctx -> Alt -> Branch
c2a_alt ctx alt = case alt of
Acon qdcon tbinds vbinds exp -> BranchCon aident aidents exp'
where exp' = c2a_exp_exp ctx exp
aident = c2a_qdcon ctx qdcon
aidents = map (c2a_tbind_aident ctx) tbinds ++
map (c2a_vbind_aident ctx) vbinds
Alit lit exp -> BranchCon (undef "c2a_alt: Literals not implemented")
(undef "c2a_alt: Literals not implemented")
(c2a_exp_exp ctx exp)
Adefault exp -> BranchVar dummy (c2a_exp_exp ctx exp)
dummy :: AIdent
dummy = c2a_id "dummy1738"
-- There should (probably) be a type of literals in Agda
-- The type should be checked
c2a_lit :: Ctx -> C.Lit -> A.Exp
c2a_lit ctx lit = case lit of
Lint i _ty -> EInt i
Lrational r _ty -> EDouble (fromRational r)
-- should have a constructor in Agda
Lchar c _ty -> EChar c
Lstring s _ty -> EString s
is_internal_name ('z':'z':xs) = False
is_internal_name ('z':xs) = True
is_internal_name _ = False
typeName t = case t of
"Data.Maybe.Maybe" -> "Maybe"
"Data.Tuple.(,)" -> "Pair"
"Data.Tuple.(,,)" -> "Triple"
"GHC.Base.Bool" -> "Bool"
"GHC.Base.Char" -> "Char"
"GHC.Base.[]" -> "List"
"GHC.Num.Integer" -> "Integer"
s -> s
coreToPrelude v = case v of
"Data.Maybe.Just" -> "Just"
"Data.Maybe.Nothing" -> "Nothing"
"Data.Tuple.(,)" -> "Pair"
"Data.Tuple.(,,)" -> "Triple"
"GHC.Base.&&" -> "boolean_and"
"GHC.Base.++" -> "append"
"GHC.Base.:" -> "Cons"
"GHC.Base.False" -> "False"
"GHC.Base.True" -> "True"
"GHC.Base.[]" -> "Nil"
"GHC.Base.not" -> "not"
"GHC.Base.||" -> "or"
"GHC.List.null" -> "null"
"GHC.List.reverse" -> "reverse"
s -> s
-- **PJ: Cmp. with Core2Cl.qualifyname - what is the difference and why?
qualifyTcon ctx (mName, id) = typeName fullName
where fullName = case mName of
"" -> unObfusc id
s | modName ctx == s -> unObfusc id
s -> (unObfusc s) ++ "." ++ (unObfusc id)