{-| 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)