{-# LANGUAGE DeriveDataTypeable #-}
module Type where
import qualified Language.Haskell.TH as TH
import Language.Haskell.TH hiding (Con,Exp,Pat)
import qualified Language.Haskell.Exts as HSE
import Data.Data
type Var = String
type Con = String
data Exp = Case Exp [(Pat,Exp)]
| App Exp Exp
| Var Var
| Lam Var Exp
| Lit String
| Con Con [Exp]
deriving (Read,Show,Eq,Data,Typeable)
data Pat = Pat Con [Var]
deriving (Read,Show,Eq,Data,Typeable)
data Env = Env [(Var,Exp)]
deriving (Read,Show,Eq,Data,Typeable)
ppExp :: Exp -> String
ppExp x = HSE.prettyPrint (f x) ++ "\n"
where
-- f (Let a b c) = HSE.Let (HSE.BDecls [HSE.PatBind sl (pvar a) Nothing (HSE.UnGuardedRhs $ f b) (HSE.BDecls [])]) $ f c
f (Case a b) = HSE.Case (f a) (map g b)
f (App a b) = HSE.App (f a) (f b)
f (Var x) = HSE.Var $ HSE.UnQual $ HSE.Ident x
f (Lam v x) = HSE.Lambda sl [pvar v] (f x)
f (Con x xs) = f $ apps (Var x) xs
f (Lit x) = f $ Var x
-- g (Default, x) = HSE.Alt sl HSE.PWildCard (HSE.UnGuardedAlt $ f x) (HSE.BDecls [])
g (Pat c xs, x) = HSE.Alt sl (HSE.PApp (HSE.UnQual $ HSE.Ident c) $ map pvar xs) (HSE.UnGuardedAlt $ f x) (HSE.BDecls [])
pvar = HSE.PVar . HSE.Ident
sl = HSE.SrcLoc "" 0 0
apps x [] = x
apps x (y:ys) = apps (App x y) ys
lams [] x = x
lams (v:vs) x = Lam v (lams vs x)
fromLams (Lam v x) = let (a,b) = fromLams x in (v:a,b)
fromLams x = ([], x)
subst :: Var -> Exp -> Exp -> Exp
subst a b x = case x of
-- Let v x y | a /= v -> Let v (f x) (f y)
Case x xs -> Case (f x) (map g xs)
App x y -> App (f x) (f y)
Var x -> if x == a then b else Var x
Lam v x | a /= v -> Lam v $ f x
Con c xs -> Con c $ map f xs
_ -> x
where
f = subst a b
--g (Default, x) = (Default, f x)
g (Pat c vs, x) = (Pat c vs, if a `elem` vs then x else f x)
substs :: [(Var,Exp)] -> Exp -> Exp
substs [] x = x
substs ((a,b):vs) x = substs vs $ subst a b x
convert :: [TH.Dec] -> Env
convert xs = Env $ concatMap dec xs
where
dec (FunD name [x]) = [(show name, clause x)]
dec DataD{} = []
dec x = error $ "convert dec: " ++ show x
clause (Clause ps (NormalB x) []) = exp $ LamE ps x
clause x = error $ "convert clause: " ++ show x
exp (LamE [] x) = exp x
exp (LamE (v:vs) x) = Lam (varp v) $ exp $ LamE vs x
exp (CaseE x y) = Case (exp x) (map match y)
exp (VarE x) = Var $ fromName x
exp (ConE x) = lams as $ Con (fromName x) $ map Var as
where as = ["v" ++ show i | i <- [1 .. arity $ fromName x]]
exp (InfixE (Just x) y (Just z)) = exp y `App` exp x `App` exp z
exp (AppE x y) = App (exp x) (exp y)
exp (LitE x) = Lit $ show x
exp x = error $ "convert exp: " ++ show x
match (Match p (NormalB x) []) = (pat p, exp x)
match x = error $ "convert match: " ++ show x
pat (InfixP x y z) = pat $ ConP y [x,z]
pat (ConP x ys) = Pat (fromName x) (map varp ys)
pat x = error $ "convert pat: " ++ show x
varp (VarP x) = fromName x
varp x = error $ "convert varp: " ++ show x
arity x | x `elem` words "[] True False Z" = 0
arity x | x `elem` words "S" = 1
arity x | x `elem` words ":" = 2
arity x = error $ "Arity not known for: " ++ show x
unqualify :: String -> String
unqualify = reverse . takeWhile (/= '.') . reverse
fromName :: Name -> String
fromName = unqualify . show