{-# LANGUAGE MagicHash, TemplateHaskell #-}
module MagicHaskeller.ExprStaged where
import MagicHaskeller.CoreLang
import MagicHaskeller.MyDynamic
import Data.Array
import MagicHaskeller.Types as Types
import MagicHaskeller.Execute(unDeBruijn)
import Debug.Trace
import GHC.Exts(unsafeCoerce#)
import Language.Haskell.TH hiding (Con)
import MagicHaskeller.MHTH
import MagicHaskeller.TyConLib(defaultTCL, tuplename)
import MagicHaskeller.ReadTHType(typeToTHType)
import Data.Int
import Data.List(genericTake, genericSplitAt)
see :: Int8 -> Int8 -> String
see Int8
i Int8
j = Exp -> String
forall a. Ppr a => a -> String
pprint (Exp -> String) -> Exp -> String
forall a b. (a -> b) -> a -> b
$ CoreExpr -> Exp
e2THE (CoreExpr -> Exp) -> CoreExpr -> Exp
forall a b. (a -> b) -> a -> b
$ Int8 -> Int8 -> CoreExpr
mkCE Int8
i Int8
j
seeType :: Int8 -> Int8 -> CoreExpr
seeType Int8
i Int8
j = CoreExpr -> CoreExpr
unDeBruijn (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ Int8 -> Int8 -> CoreExpr
mkCE Int8
i Int8
j
sees :: Int8 -> Int8 -> Int8 -> String
sees Int8
i Int8
j Int8
k = Exp -> String
forall a. Ppr a => a -> String
pprint (Exp -> String) -> Exp -> String
forall a b. (a -> b) -> a -> b
$ CoreExpr -> Exp
e2THE (CoreExpr -> Exp) -> CoreExpr -> Exp
forall a b. (a -> b) -> a -> b
$ Int8 -> Int8 -> Int8 -> CoreExpr
mkCE_LambdaBoundHead Int8
i Int8
j Int8
k
seesType :: Int8 -> Int8 -> Int8 -> CoreExpr
seesType Int8
i Int8
j Int8
k = CoreExpr -> CoreExpr
unDeBruijn (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ Int8 -> Int8 -> Int8 -> CoreExpr
mkCE_LambdaBoundHead Int8
i Int8
j Int8
k
e2THE :: CoreExpr -> Exp
e2THE = VarLib -> CoreExpr -> Exp
exprToTHExp (String -> VarLib
forall a. HasCallStack => String -> a
error String
"exprToTHExp: vl required")
printTables :: IO ()
printTables = (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
putStrLn [ Int8 -> ShowS
forall a. Show a => a -> ShowS
shows Int8
i ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ (Char
' 'Char -> ShowS
forall a. a -> [a] -> [a]
:) ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Int8 -> ShowS
forall a. Show a => a -> ShowS
shows Int8
m ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ (Char
' 'Char -> ShowS
forall a. a -> [a] -> [a]
:) ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Int8 -> ShowS
forall a. Show a => a -> ShowS
shows Int8
n ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ (String
"\t("String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Exp -> String
forall a. Ppr a => a -> String
pprint (Int8 -> Int8 -> Int8 -> Exp
aimnTHE Int8
i Int8
m Int8
n) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
") :: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Type -> String
pprintType (TyConLib -> Type -> Type
MagicHaskeller.ReadTHType.typeToTHType TyConLib
MagicHaskeller.TyConLib.defaultTCL (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Int8 -> Int8 -> Int8 -> Type
aimnty Int8
i Int8
m Int8
n)
| Int8
i <- [Int8
0..Int8
2], Int8
m <- [Int8
0..Int8
2], Int8
n <- [Int8
iInt8 -> Int8 -> Int8
forall a. Num a => a -> a -> a
+Int8
1..Int8
3] ]
printTable :: IO ()
printTable = (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
putStrLn [ Int8 -> ShowS
forall a. Show a => a -> ShowS
shows Int8
m ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ (Char
' 'Char -> ShowS
forall a. a -> [a] -> [a]
:) ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Int8 -> ShowS
forall a. Show a => a -> ShowS
shows Int8
n ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ (String
"\t("String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Exp -> String
forall a. Ppr a => a -> String
pprint (Int8 -> Int8 -> Exp
hdmnTHE Int8
m Int8
n) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
") :: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Type -> String
pprintType (TyConLib -> Type -> Type
MagicHaskeller.ReadTHType.typeToTHType TyConLib
MagicHaskeller.TyConLib.defaultTCL (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Int8 -> Int8 -> Type
hdmnty Int8
m Int8
n)
| Int8
m <- [Int8
0..Int8
2], Int8
n <- [Int8
0..Int8
2] ]
pprintType :: Type -> String
pprintType (ForallT [TyVarBndr]
_ [] Type
ty) = Type -> String
pprintType Type
ty
pprintType (ForallT [TyVarBndr]
_ [Type]
_ Type
ty) = ShowS
forall a. HasCallStack => String -> a
error String
"Type classes are not supported yet. Sorry...."
pprintType (VarT Name
name) = Name -> String
forall a. Ppr a => a -> String
pprint Name
name
pprintType (ConT Name
name) = Name -> String
forall a. Ppr a => a -> String
pprint Name
name
pprintType (TupleT Int
n) = Int -> String
tuplename Int
n
pprintType Type
ArrowT = String
"(->)"
pprintType Type
ListT = String
"[]"
pprintType (AppT (AppT Type
ArrowT Type
t) Type
u) = Char
'(' Char -> ShowS
forall a. a -> [a] -> [a]
: Type -> String
pprintType Type
t String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" -> " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Type -> String
pprintType Type
u String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
pprintType (AppT Type
t Type
u) = Char
'(' Char -> ShowS
forall a. a -> [a] -> [a]
: Type -> String
pprintType Type
t String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
' ' Char -> ShowS
forall a. a -> [a] -> [a]
: Type -> String
pprintType Type
u String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
mkVName :: Char -> Int -> Q Language.Haskell.TH.Name
mkVName :: Char -> Int -> Q Name
mkVName Char
c Int
i = String -> Q Name
newName (Char
c Char -> ShowS
forall a. a -> [a] -> [a]
: Int -> String
forall a. Show a => a -> String
show Int
i)
mkVNames :: Char -> Int -> Q [Language.Haskell.TH.Name]
mkVNames :: Char -> Int -> Q [Name]
mkVNames Char
c Int
n = (Int -> Q Name) -> [Int] -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Char -> Int -> Q Name
mkVName Char
c) [Int
0..Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]
mkEs, mkAs, mkXs :: Int -> Q [Language.Haskell.TH.Name]
mkEs :: Int -> Q [Name]
mkEs = Char -> Int -> Q [Name]
mkVNames Char
'e'
mkAs :: Int -> Q [Name]
mkAs = Char -> Int -> Q [Name]
mkVNames Char
'a'
mkXs :: Int -> Q [Name]
mkXs = Char -> Int -> Q [Name]
mkVNames Char
'x'
mkHd :: Q Name
mkHd = String -> Q Name
newName String
"hd"
hdmnTHEQ :: Int8 -> Int8 -> ExpQ
hdmnTHEQ :: Int8 -> Int8 -> ExpQ
hdmnTHEQ Int8
m Int8
n = Exp -> ExpQ
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> ExpQ) -> Exp -> ExpQ
forall a b. (a -> b) -> a -> b
$ (Name -> Exp
VarE 'unsafeCoerce#) Exp -> Exp -> Exp
`AppE` Int8 -> Int8 -> Exp
hdmnTHE Int8
m Int8
n
aimnTHEQ :: Int8 -> Int8 -> Int8 -> ExpQ
aimnTHEQ :: Int8 -> Int8 -> Int8 -> ExpQ
aimnTHEQ Int8
i Int8
m Int8
n = Exp -> ExpQ
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> ExpQ) -> Exp -> ExpQ
forall a b. (a -> b) -> a -> b
$ (Name -> Exp
VarE 'unsafeCoerce#) Exp -> Exp -> Exp
`AppE` Int8 -> Int8 -> Int8 -> Exp
aimnTHE Int8
i Int8
m Int8
n
hdmnTHE :: Int8 -> Int8 -> Exp
hdmnTHE :: Int8 -> Int8 -> Exp
hdmnTHE Int8
m Int8
n = CoreExpr -> Exp
e2THE (Int8 -> Int8 -> CoreExpr
mkCE Int8
n Int8
m)
aimnTHE :: Int8 -> Int8 -> Int8 -> Exp
aimnTHE :: Int8 -> Int8 -> Int8 -> Exp
aimnTHE Int8
i Int8
m Int8
n = CoreExpr -> Exp
e2THE (Int8 -> Int8 -> Int8 -> CoreExpr
mkCE_LambdaBoundHead Int8
i Int8
n Int8
m)
hdmnty :: Int8 -> Int8 -> Types.Type
hdmnty :: Int8 -> Int8 -> Type
hdmnty Int8
m Int8
n = Type
hdty Type -> Type -> Type
Types.:-> (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Type -> Type -> Type
(Types.:->) ((Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Type -> Type -> Type
(Types.:->) Type
tvr [Type]
nas) ((Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (\Type
r -> (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Type -> Type -> Type
(Types.:->) Type
r [Type]
nas) [Type]
mrs)
where hdty :: Type
hdty = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Type -> Type -> Type
(Types.:->) Type
tvr [Type]
mrs
mrs :: [Type]
mrs = Int8 -> [Type] -> [Type]
forall i a. Integral i => i -> [a] -> [a]
genericTake Int8
m [Type]
tvrs
nas :: [Type]
nas = Int8 -> [Type] -> [Type]
forall i a. Integral i => i -> [a] -> [a]
genericTake Int8
n [Type]
tvas
aimnty :: Int8 -> Int8 -> Int8 -> Types.Type
aimnty :: Int8 -> Int8 -> Int8 -> Type
aimnty Int8
i Int8
m Int8
n = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Type -> Type -> Type
(Types.:->) ((Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Type -> Type -> Type
(Types.:->) Type
tvr [Type]
nas) ((Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (\Type
r -> (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Type -> Type -> Type
(Types.:->) Type
r [Type]
nas) [Type]
mrs)
where hdty :: Type
hdty = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Type -> Type -> Type
(Types.:->) Type
tvr [Type]
mrs
mrs :: [Type]
mrs = Int8 -> [Type] -> [Type]
forall i a. Integral i => i -> [a] -> [a]
genericTake Int8
m [Type]
tvrs
nas :: [Type]
nas = case Int8 -> [Type] -> ([Type], [Type])
forall i a. Integral i => i -> [a] -> ([a], [a])
genericSplitAt (Int8
nInt8 -> Int8 -> Int8
forall a. Num a => a -> a -> a
-Int8
iInt8 -> Int8 -> Int8
forall a. Num a => a -> a -> a
-Int8
1) [Type]
tvas of ([Type]
tk,Type
_:[Type]
dr) -> [Type]
tk [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ Type
hdty Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: Int8 -> [Type] -> [Type]
forall i a. Integral i => i -> [a] -> [a]
genericTake Int8
i [Type]
dr
mkTV :: Types.TyVar -> Types.Type
mkTV :: Int8 -> Type
mkTV = Int8 -> Type
Types.TV
tvrs :: [Type]
tvrs = (Int8 -> Type) -> [Int8] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Int8 -> Type
mkTV [Int8
1,Int8
3..]
tvas :: [Type]
tvas = (Int8 -> Type) -> [Int8] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Int8 -> Type
mkTV [Int8
2,Int8
4..]
tvr :: Type
tvr = Int8 -> Type
mkTV Int8
0
maxArity, maxLenavails :: Int8
maxArity :: Int8
maxArity = Int8
4
maxLenavails :: Int8
maxLenavails = Int8
8
maxDebindex :: Int8
maxDebindex = Int8
maxLenavailsInt8 -> Int8 -> Int8
forall a. Num a => a -> a -> a
-Int8
1
mkCE :: Int8
-> Int8
-> CoreExpr
mkCE :: Int8 -> Int8 -> CoreExpr
mkCE Int8
0 Int8
_ = CoreExpr -> CoreExpr
Lambda (Int8 -> CoreExpr
X Int8
0)
mkCE Int8
lenavail Int8
0 = Int8 -> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall i a. Integral i => i -> (a -> a) -> a -> a
napply (Int8
lenavailInt8 -> Int8 -> Int8
forall a. Num a => a -> a -> a
+Int8
1) CoreExpr -> CoreExpr
Lambda (Int8 -> CoreExpr
X Int8
lenavail)
mkCE Int8
lenavail Int8
arity
= let vs :: [CoreExpr]
vs = (Int8 -> CoreExpr) -> [Int8] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map Int8 -> CoreExpr
X ([Int8] -> [CoreExpr]) -> [Int8] -> [CoreExpr]
forall a b. (a -> b) -> a -> b
$ [Int8] -> [Int8]
forall a. [a] -> [a]
reverse [Int8
0..Int8
lenavailInt8 -> Int8 -> Int8
forall a. Num a => a -> a -> a
-Int8
1]
fs :: [CoreExpr]
fs = (Int8 -> CoreExpr) -> [Int8] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map Int8 -> CoreExpr
X ([Int8] -> [CoreExpr]) -> [Int8] -> [CoreExpr]
forall a b. (a -> b) -> a -> b
$ [Int8] -> [Int8]
forall a. [a] -> [a]
reverse [Int8
lenavail..Int8
lenavailInt8 -> Int8 -> Int8
forall a. Num a => a -> a -> a
+Int8
arityInt8 -> Int8 -> Int8
forall a. Num a => a -> a -> a
-Int8
1]
ce :: CoreExpr
ce = Int8 -> CoreExpr
X (Int8
lenavailInt8 -> Int8 -> Int8
forall a. Num a => a -> a -> a
+Int8
arity)
in Int8 -> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall i a. Integral i => i -> (a -> a) -> a -> a
napply (Int8
arityInt8 -> Int8 -> Int8
forall a. Num a => a -> a -> a
+Int8
1Int8 -> Int8 -> Int8
forall a. Num a => a -> a -> a
+Int8
lenavail) CoreExpr -> CoreExpr
Lambda ((CoreExpr -> CoreExpr -> CoreExpr)
-> CoreExpr -> [CoreExpr] -> CoreExpr
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl CoreExpr -> CoreExpr -> CoreExpr
(:$) CoreExpr
ce ([CoreExpr] -> CoreExpr) -> [CoreExpr] -> CoreExpr
forall a b. (a -> b) -> a -> b
$ (CoreExpr -> CoreExpr) -> [CoreExpr] -> [CoreExpr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\CoreExpr
f -> (CoreExpr -> CoreExpr -> CoreExpr)
-> CoreExpr -> [CoreExpr] -> CoreExpr
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl CoreExpr -> CoreExpr -> CoreExpr
(:$) CoreExpr
f [CoreExpr]
vs) [CoreExpr]
fs)
mkCE_LambdaBoundHead :: Int8 -> Int8 -> Int8 -> CoreExpr
mkCE_LambdaBoundHead Int8
debindex Int8
lenavails Int8
arity
= let vs :: [CoreExpr]
vs = (Int8 -> CoreExpr) -> [Int8] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map Int8 -> CoreExpr
X ([Int8] -> [CoreExpr]) -> [Int8] -> [CoreExpr]
forall a b. (a -> b) -> a -> b
$ [Int8] -> [Int8]
forall a. [a] -> [a]
reverse [Int8
0..Int8
lenavailsInt8 -> Int8 -> Int8
forall a. Num a => a -> a -> a
-Int8
1]
fs :: [CoreExpr]
fs = (Int8 -> CoreExpr) -> [Int8] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map Int8 -> CoreExpr
X ([Int8] -> [CoreExpr]) -> [Int8] -> [CoreExpr]
forall a b. (a -> b) -> a -> b
$ [Int8] -> [Int8]
forall a. [a] -> [a]
reverse [Int8
lenavails..Int8
lenavailsInt8 -> Int8 -> Int8
forall a. Num a => a -> a -> a
+Int8
arityInt8 -> Int8 -> Int8
forall a. Num a => a -> a -> a
-Int8
1]
ce :: CoreExpr
ce = Int8 -> CoreExpr
X Int8
debindex
in Int8 -> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall i a. Integral i => i -> (a -> a) -> a -> a
napply (Int8
arityInt8 -> Int8 -> Int8
forall a. Num a => a -> a -> a
+Int8
lenavails) CoreExpr -> CoreExpr
Lambda ((CoreExpr -> CoreExpr -> CoreExpr)
-> CoreExpr -> [CoreExpr] -> CoreExpr
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl CoreExpr -> CoreExpr -> CoreExpr
(:$) CoreExpr
ce ([CoreExpr] -> CoreExpr) -> [CoreExpr] -> CoreExpr
forall a b. (a -> b) -> a -> b
$ (CoreExpr -> CoreExpr) -> [CoreExpr] -> [CoreExpr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\CoreExpr
f -> (CoreExpr -> CoreExpr -> CoreExpr)
-> CoreExpr -> [CoreExpr] -> CoreExpr
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl CoreExpr -> CoreExpr -> CoreExpr
(:$) CoreExpr
f [CoreExpr]
vs) [CoreExpr]
fs)