{-|
This module translates a GHC core 'ExternalCore.Module' to a list of
'CL.Clause'.
The GHC core module is supposed to have been already lifted (all functions
declarations and case at toplevel
-}
-- #ignore-exports
module Core2Cl (core2cl) where
import Cl.Abs as Cl
import ExternalCore as C
import UnObfusc(unObfusc)
import Maybe
import Monad
import Control.Monad.State
import Text.PrettyPrint.HughesPJ
import IO
import PprExternalCore
core2cl :: C.Module -> Cl.Module
core2cl (Module mname tdefs vdefgs) = Cl.Mod lc lp
where (lc,lp) = foldl c2cDef ([],[]) vdefgs
c2cDef (lcode,lprop) x = (lcode++lcode',lprop++lprop')
where (lcode',lprop') = c2cTopLevelVdefg ctx x
ctx = ctxEmpty mname (lDef vdefgs)
-- * Translation contexts
-- ** CaseExp
{-| 'CaseExp' are unfinished clauses. They are build and extended
while going through the graph. -}
type CaseExp = ([Cl.Pat],[([Cl.Guard], Maybe Cl.Exp, [Cl.Local])])
csEmpty :: [CaseExp]
csEmpty = [([], [([], Nothing, [])])]
ceExtPat :: Cl.Pat -> CaseExp -> CaseExp
ceExtPat p (ps, ds) = ((ps++[p]), ds)
csExtPat :: [CaseExp] -> Cl.Pat -> [CaseExp]
csExtPat cs p = map (ceExtPat p) cs
ceAddGuard :: Cl.Guard -> CaseExp -> CaseExp
ceAddGuard g (ps,ds) = (ps, map (\ (gs, e, ls) -> (gs++[g], e, ls)) ds)
csReplExp :: [CaseExp] -> (Cl.Exp, [(Cl.Pat, Cl.Exp)]) -> [CaseExp]
csReplExp cs (e,pes) = cs'
where cs' = map (\ (ps,ds) -> (ps,map replExp ds)) cs
replExp (gs,ce,ls) = (gs, Just e,ls')
where ls' = case pes of
[] -> ls
_ -> (Loc (map (\ (p,e) -> Def p e) pes)):ls
csReplPat :: [CaseExp] -> Cl.Pat -> Cl.Pat -> [CaseExp]
csReplPat cs e p = cs'
where cs' = map (\ (ps,ds) -> (map replPat ps, ds)) cs
replPat pt = if pt == e then p else pt
{- | A 'CaseExp' translates to a list of clauses. Uncomplete 'CaseExp' are
discarded (maybe they should raise an error?). -}
ceToClauses :: Cl.Id -> CaseExp -> [Cl.Clause]
ceToClauses id (ps, ds) = case ds of
[] -> []
(gs, Nothing, ls):ds' -> ceToClauses id (ps,ds')
(gs, Just e, ls):ds' ->
(Cl id ps gs e ls):(ceToClauses id (ps,ds'))
csToClauses :: Cl.Id -> [CaseExp] -> [Cl.Clause]
csToClauses id cs = case cs of
[] -> []
ce:cs' -> (ceToClauses id ce) ++ (csToClauses id cs')
-- ** Substitution in expressions and patterns
{- | We need to substitute identifier with pattern and expressions.
We use a substitution environment made by an associate list and just
traverse the structures. -}
type SubstEnv = [(Cl.Id, Cl.Pat)]
{- | An empty substitution environment. -}
substEmpty :: SubstEnv
substEmpty = []
{- | @substPat env p@ returns a pattern build from @p@ and where all
substitutions defined by @env@ have been processed. -}
substPat :: SubstEnv -> Cl.Pat -> Cl.Pat
substPat env p = case p of
Pvar id -> fromMaybe p (lookup id env)
Pcon id ps -> Pcon id (map (substPat env) ps)
{- | @substAdd env id p@ adds a substitution of identifier @id@ by
pattern @pat@ in @env@. The substitution is propaged down into
@env@. -}
substAdd :: SubstEnv -> Cl.Id -> Cl.Pat -> SubstEnv
substAdd env id p = (id,p):(map (\ (ei,ep) -> (ei, substPat [(id,p)] ep)) env)
-- ** Contexts
{- | Contexts are simply records containing a list of 'CaseExp' and a
substitution environment. -}
data Context = C { modName :: String,
cexps :: [CaseExp],
subst :: SubstEnv,
erase :: [String],
funs :: [String]
}
{- | An empty context. -}
ctxEmpty :: String -> [String] -> Context
ctxEmpty m fs = C { modName = m, cexps = csEmpty, subst = substEmpty,
erase = [], funs = fs }
ctxErase :: Context -> String -> Bool
ctxErase ctx v = elem v (erase ctx)
ctxAddErase :: Context -> String -> Context
ctxAddErase ctx v = ctx { erase = v:(erase ctx) }
ctxReplExp :: Context -> (Cl.Exp, [(Cl.Pat, Cl.Exp)]) -> Context
ctxReplExp ctx e = ctx { cexps = csReplExp (cexps ctx) e }
ctxAddSubst :: Context -> Cl.Id -> Cl.Pat -> Context
ctxAddSubst ctx id p = ctx'
where ctx' = ctx { cexps = cexps', subst = subst' }
cexps' = map (\(ps,ds) -> (map (substPat subst') ps, ds)) (cexps ctx)
subst' = substAdd (subst ctx) id p
ctxAddGuard :: Context -> Cl.Exp -> Context
ctxAddGuard ctx e = ctx { cexps = cexps' }
where cexps' = map (ceAddGuard (Guard [e])) (cexps ctx)
ctxConcat :: [Context] -> Context -> Context
ctxConcat ctxs c0 =
foldl (\ c1 -> \c2 -> C { modName = modName c0,
cexps = (cexps c1) ++ (cexps c2),
subst = subst c0,
erase = erase c0,
funs = funs c0 })
(ctxEmpty (modName c0) (funs c0)) ctxs
-- * From Core to Cl
c2cTopLevelVdefg :: Context -> Vdefg -> ([Cl.Clause], [PropCl])
c2cTopLevelVdefg ctx vdefg =
case vdefg of
Rec vdefs -> foldl c2cOne ([],[]) vdefs
where c2cOne (l1,l2) x = (l1'++l1, l2'++l2)
where (l1',l2') = c2cTopLevelVdef ctx x
Nonrec vdef -> c2cTopLevelVdef ctx vdef
c2cTopLevelVdef :: Context -> Vdef -> ([Cl.Clause], [PropCl])
c2cTopLevelVdef ctx ((mname, v), ty, e) = clauses
where clauses = case v of
'p':'r':'o':'p':'z':'u':_ -> ([], [c2pVdef ctx v e])
_ -> (csToClauses (qualifyname (modName ctx) (mname,v)) (cexps ctx'), [])
ctx' = c2cLambda ctx e
{- | Lambdas should all be at toplevel. Processing a lambda consists in
adding a parameter in the parameter list of the current list of
'CaseExp', and calling ourselves recursively. When we have no more
lambdas, we start processing cases. -}
c2cLambda :: Context -> C.Exp -> Context
c2cLambda ctx e = case e of
Lam (Vb (v,Tapp (Tcon ("GHCziBase", "ZCTOrd")) _)) e ->
c2cLambda (ctxAddErase ctx v) e
Lam (Vb (v,t)) e -> c2cLambda ctx' e
where ctx' = ctx { cexps = csExtPat (cexps ctx) (Cl.Pvar (qualifyname (modName ctx) ("",v))) }
Lam (Tb _) e -> c2cLambda ctx e
_ -> c2cCaseExp ctx e
{- | Case expression should be directly following the lambdas. When
processing cases, we have two possibilities:
* we do case on a variable - we replace the variable by the binder
in the pattern arguments of the context and process the right
hand sides.
* we do case on a boolean expression, this boolean expression becomes
a guard.
Others cases (case on a non-trivial, non-boolean expression) are errors,
and should not occur.
/The second case (guard) is not implemented yet!/ -}
c2cCaseExp :: Context -> C.Exp -> Context
c2cCaseExp ctx e = case e of
Case e (v,Tapp (Tcon ("GHCziBase", "ZCTOrd")) _) [alt] -> ctx''
where ctx'' = c2cAlt ctx' (qualifyname (modName ctx) ("",v)) alt
ctx' = ctxAddClassOrd ctx
Case (Var (m,x)) (v,ty) alts -> ctx''
where ctx'' = ctxConcat (map (c2cAlt ctx' (qualifyname (modName ctx) ("",v))) alts) ctx
ctx' = ctxAddSubst ctx (qualifyname (modName ctx) ("",v)) pat
pat = Cl.Pvar (qualifyname (modName ctx) ("",v))
-- {-
Case e (v, Tcon ("GHCziBase", "Bool")) alts -> ctx'
where ctx' = ctxConcat (map (c2cAltGuard ctx ce) alts) ctx
ce = case c2cExp ctx e of (ce, []) -> ce
-- -}
_ -> ctxReplExp ctx (c2cExp ctx e)
c2cAlt :: Context -> Cl.Id -> Alt -> Context
c2cAlt ctx id alt = case alt of
Acon (m,c) tb vb (App (Appt (Var ("GHCziErr", "patError")) _) _) ->
ctxEmpty (modName ctx) (funs ctx)
Acon (m,c) tb vb e -> c2cCaseExp (ctxAddSubst ctx id pc) e
where pc = Cl.Pcon (qualifyname (modName ctx) (m,c)) binds
binds = map (\ (v,ty) -> Cl.Pvar (qualifyname (modName ctx) ("",v))) vb
Alit l e -> error ("Core2Cl.c2cAlf: No literals in CL yet. Case branch was: " ++ show alt)
Adefault e -> error ("Core2Cl.c2cAlf: No defaults in CL. Case branch was: " ++ show alt)
c2cAltGuard :: Context -> Cl.Exp -> Alt -> Context
c2cAltGuard ctx ce alt = case alt of
Acon ("GHCziBase",b) tb vb e -> c2cCaseExp ctx' e
where ctx' = ctxAddGuard ctx ce'
ce' = if b == "True" then ce else (clNot ce)
{- | The convertion functions -}
c2cVdefg :: Context -> Vdefg -> [(Cl.Pat, Cl.Exp)]
c2cVdefg ctx vdefg = case vdefg of
Rec vdefs -> foldl (\l -> \x -> (c2cVdef ctx x)++l) [] vdefs
Nonrec vdef -> c2cVdef ctx vdef
c2cVdef :: Context -> Vdef -> [(Cl.Pat, Cl.Exp)]
c2cVdef ctx ((mname, v), ty, e) = (Cl.Pvar (qualifyname (modName ctx) ("",v)),e'):l
where (e',l) = c2cExp ctx e
c2cExp :: Context -> C.Exp -> (Cl.Exp, [(Cl.Pat, Cl.Exp)])
c2cExp ctx e = case e of
Var (m,v) -> (e', [])
where e' =
if ((m /= modName ctx) && (m /= ""))
then Efun (qualifyname "" (m,v))
else if (elem v (funs ctx))
then Efun (qualifyname (modName ctx) (m,v))
else expOfPat Evar (substPat (subst ctx) pat)
pat = Pvar (qualifyname (modName ctx) (m,v))
Dcon (m,c) -> (e', [])
where e' = expOfPat Evar (substPat (subst ctx) pat)
pat = Pcon (qualifyname (modName ctx) (m,c)) []
App (Var (m,v)) e2 -> (Eapp e1' e2', l2)
where e1' = expOfPat Efun (substPat (subst ctx) pat)
pat = Pvar (qualifyname (modName ctx) (m,v))
(e2', l2) = c2cExp ctx e2
App e1 (Var (m,v)) | ctxErase ctx v -> c2cExp ctx e1
App e1 e2 -> (Eapp e1' e2', l1 ++ l2)
where (e1', l1) = c2cExp ctx e1
(e2', l2) = c2cExp ctx e2
Appt e ty -> c2cExp ctx e
Let v e -> (e', l2)
where (e', l) = c2cExp ctx e
l1 = c2cVdefg ctx v
l2 = l ++ l1
Coerce t e -> c2cExp ctx e
Note s e -> c2cExp ctx e
Lit l -> (Econ (c2cLit l), [])
External s ty -> error "External not supported"
Lam b e -> error "Lambda - should be at toplevel"
Case e vb alts -> error "Case - should be at toplevel"
c2cBind b = case b of
Vb (v, t) -> Pvar (qualifyname "" ("",v))
Tb _ -> error "No type binding"
c2cId :: C.Id -> String
c2cId ident = unObfusc ident
-- **PJ: Cmp. with Core2Agda.qualifyTcon - what is the difference and why?
qualifyname modName (mname, id) = coreToPrelude fullName
where fullName = case mname of
"" -> qname (unObfusc modName) (unObfusc id)
s -> qname (unObfusc mname) (unObfusc id)
qname :: String -> String -> Cl.Id
qname modul name = Qname (Ident modul) (Ident name)
c2cLit :: C.Lit -> Cl.Id
c2cLit l = case l of
Lint i t -> qname "" "0"
Lrational r t -> qname "" "0."
Lchar c t -> qname "" "c"
Lstring s t -> qname "" s
c2cPatExp :: C.Exp -> [Cl.Pat] -> Cl.Pat
c2cPatExp e ps = case e of
Var (m,v) -> Pvar (qualifyname "" ("", v))
Dcon (m,c) -> Pcon (qualifyname "" ("", c)) ps
coreToPrelude :: Cl.Id -> Cl.Id
coreToPrelude v = case v of
Qname (Ident "Data.Tuple") (Ident "(,)" ) -> qname "" "Pair"
Qname (Ident "GHC.Base" ) (Ident "&&" ) -> qname "" "boolean_and"
Qname (Ident "GHC.Base" ) (Ident "++" ) -> qname "" "append"
Qname (Ident "GHC.Base" ) (Ident ":" ) -> qname "" "Cons"
Qname (Ident "GHC.Base" ) (Ident "False" ) -> qname "" "false"
Qname (Ident "GHC.Base" ) (Ident "True" ) -> qname "" "true"
Qname (Ident "GHC.Base" ) (Ident "[]" ) -> qname "" "Nil"
Qname (Ident "GHC.Base" ) (Ident "not" ) -> qname "" "not"
Qname (Ident "GHC.Base" ) (Ident "||" ) -> qname "" "or"
Qname (Ident "GHC.List" ) (Ident "null" ) -> qname "" "null"
Qname (Ident "GHC.List" ) (Ident "reverse") -> qname "" "reverse"
s -> s
clNot :: Cl.Exp -> Cl.Exp
clNot e = Eapp (Evar (qname "" "not")) e
expOfPat :: (Cl.Id -> Cl.Exp) -> Cl.Pat -> Cl.Exp
expOfPat con p = case p of
Pvar id -> con id
Pcon id ps -> foldl (\ e -> \ p -> Eapp e (expOfPat con p)) (Econ id) ps
ctxAddClassOrd :: Context -> Context
ctxAddClassOrd ctx = ctx { subst = subst1 }
where subst1 = substAdd subst0 (qname "" "tpl3") (Pvar (qname "" "leq"))
subst0 = subst ctx
lDef :: [Vdefg] -> [String]
lDef vdefgs = foldl lDefVdefg [] vdefgs
where lDefVdefg l vdefg = case vdefg of
Rec vdefs -> foldl lDefVdef l vdefs
Nonrec vdef -> lDefVdef l vdef
lDefVdef l ((mname, v), ty, e) = v:l
-- Converting properties
data Prop
= ForAll (Cl.Exp -> Prop)
| Exists (Cl.Exp -> Prop)
| And Prop Prop
| Or Prop Prop
| Not Prop
| Equal Cl.Exp Cl.Exp
| Using [Cl.Id] Prop
| Inline Cl.Id
| Ninline Cl.Id
type Disj = [Cl.Lit]
type Conj = [Disj]
c2pVdef :: Context -> String -> C.Exp -> PropCl
c2pVdef ctx v e = Cl.Property (qualifyname (modName ctx) ("",v)) cs pclt pclf
where pclt = map PCl clt
pclf = map PCl clf
(cst,clt) = evalState (clausify [] p) 0
(cs,clf) = evalState (clausify [] (Not p)) 0
p = toProp ctx e
c2pReduce e = case e of
Appt e t -> c2pReduce e
_ -> e
toProp :: Context -> C.Exp -> Prop
toProp ctx e =
case c2pReduce e of
App e1 e2 ->
case c2pReduce e1 of
App e3 e4 ->
case c2pReduce e3 of
Var (m,v) ->
case qualifyname (modName ctx) (m,v) of
Qname (Ident "Property") (Ident "===") -> Equal (toPropExp ctx e4) (toPropExp ctx e2)
Qname (Ident "Property") (Ident "/\\") -> And (toProp ctx e4) (toProp ctx e2)
Qname (Ident "Property") (Ident "\\/") -> Or (toProp ctx e4) (toProp ctx e2)
Qname (Ident "Property") (Ident "<=>") -> Or (And a b) (And (Not a) (Not b))
where a = toProp ctx e4
b = toProp ctx e2
Qname (Ident "Property") (Ident "==>") -> Or (Not a) b
where a = toProp ctx e4
b = toProp ctx e2
Qname (Ident "Property") (Ident "using") -> Using (toPropList ctx e4) (toProp ctx e2)
Qname (Ident "GHC.Base") (Ident "$" ) -> toProp ctx (App e4 e2)
_ -> error ("Unrecognized name: " ++ m ++ "." ++ v)
Var (m,v) ->
case qualifyname (modName ctx) (m,v) of
Qname (Ident "Property") (Ident "forAll") -> ForAll (toPropFun ctx e2)
Qname (Ident "Property") (Ident "exists") -> Exists (toPropFun ctx e2)
Qname (Ident "Property") (Ident "nt" ) -> Not (toProp ctx e2)
_ -> error "Not a valid property (1)"
_ -> error "Not a valid property (2)"
Var (m,v) -> Inline (qualifyname (modName ctx) (m,v))
_ -> error ("Not a valid property: " ++ (render (pexp e)))
toPropExp :: Context -> C.Exp -> Cl.Exp
toPropExp ctx e = e'
where (e', l) = c2cExp ctx e
toPropList :: Context -> C.Exp -> [Cl.Id]
toPropList ctx e =
case c2pReduce e of
App e1 e2 ->
case c2pReduce e1 of
App e3 e4 ->
case c2pReduce e3 of
Dcon (m,v) ->
case qualifyname (modName ctx) (m,v) of
Qname (Ident "") (Ident "Cons") -> (toQname ctx e4):(toPropList ctx e2)
_ -> error ("using: not a recognized constructor - " ++
m ++ "." ++ v)
_ -> error ("Using: not a valid list of properties (1): " ++
(render (pexp (c2pReduce e3))))
_ -> error "Using: not a valid list of properties (2)"
Dcon (m,v) ->
case qualifyname (modName ctx) (m,v) of
Qname (Ident "") (Ident "Nil") -> []
_ -> error "Using: not a valid list of properties (3)"
toQname :: Context -> C.Exp -> Cl.Id
toQname ctx e =
case c2pReduce e of
Var (m,v) -> qualifyname (modName ctx) (m,v)
_ -> error "Using: not a var"
substProp :: String -> Cl.Exp -> Prop -> Prop
substProp v e p = case p of
ForAll f -> ForAll (\ x -> substProp v e (f x))
Exists f -> Exists (\ x -> substProp v e (f x))
And p1 p2 -> And (substProp v e p1) (substProp v e p2)
Or p1 p2 -> Or (substProp v e p1) (substProp v e p2)
Not p -> Not (substProp v e p)
Equal e1 e2 -> Equal (substExp v e e1) (substExp v e e2)
Using pl p -> Using pl (substProp v e p)
Inline id -> Inline id
Ninline id -> Ninline id
substExp :: String -> Cl.Exp -> Cl.Exp -> Cl.Exp
substExp v e exp = case exp of
Evar (Qname _m (Ident i)) | i == v -> e
Eapp e1 e2 -> Eapp (substExp v e e1) (substExp v e e2)
e -> e
toPropFun :: Context -> C.Exp -> (Cl.Exp -> Prop)
toPropFun ctx e = case e of
Lam (Vb (v,t)) e' -> \ x -> substProp v x (toProp ctx e')
Let vg e ->
case e of
Var (m,v) ->
case vg of
Nonrec ((m,v'), t, e') ->
if v == v'
then toPropFun ctx e'
else error ("Not a var: " ++ (render (pexp e)))
_ -> error ("Recursive def: " ++ (render (pexp e)))
_ -> error ("Not a var: " ++ (render (pexp e)))
_ -> error ("Not a lambda: " ++ (render (pexp e)))
clausify :: [Cl.Exp] -> Prop -> State Int ([Cl.Id],[Disj])
clausify vs p = case positive p of
ForAll f ->
do id <- get
put (id+1)
let v = Cl.Evar (Qname (Ident "") (Ident ("_univ_" ++ show id)))
clausify (v:vs) (positive (f v))
Exists f ->
do id <- get
put (id+1)
let skol = Efun (Qname (Ident "") (Ident ("_skol_" ++ show id)))
clausify vs (positive (f (foldl (\ g -> \ x -> Eapp g x) skol vs)))
And p1 p2 ->
do (xu,xs) <- clausify vs p1
(yu,ys) <- clausify vs p2
return (xu++yu, xs++ys)
Or p1 p2 ->
do (xu,xs) <- clausify vs p1
(yu,ys) <- clausify vs p2
return (xu++yu,xs `cross` ys)
where xs `cross` ys = [ x ++ y | x <- xs, y <- ys ]
Not (Equal e1 e2) -> return ([],[[Lneg e1 e2]])
Equal e1 e2 -> return ([],[[Lpos e1 e2]])
Using pl p ->
do (yu,ys) <- clausify vs p
return (pl++yu, ys)
Inline id -> return ([],[[Cl.Linline id]])
Ninline id -> return ([],[[Cl.Lninline id]])
positive :: Prop -> Prop
positive p = case p of
Not (ForAll f) -> Exists (nt . f)
Not (Exists f) -> ForAll (nt . f)
Not (And p1 p2) -> Or (positive (nt p1)) (positive (nt p2))
Not (Or p1 p2) -> And (positive (nt p1)) (positive (nt p2))
Not (Not p) -> positive p
Not (Using pl p) -> Using pl (positive (nt p))
Not (Inline id) -> Ninline id
Not (Ninline id) -> Inline id
ForAll f -> ForAll f
Exists f -> Exists f
And p1 p2 -> And (positive p1) (positive p2)
Or p1 p2 -> Or (positive p1) (positive p2)
Using pl p -> Using pl (positive p)
p -> p
nt :: Prop -> Prop
nt (Not p) = p
nt p = Not p