-- 
-- (c) Susumu Katayama
--
{-# LANGUAGE MagicHash, TemplateHaskell #-}
module MagicHaskeller.ExprStaged where
import MagicHaskeller.CoreLang
import MagicHaskeller.MyDynamic
-- import ReadType
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

-- The following two are used only by printTable(s) for debugging.
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 is copied (and improved a little) from MagicHaskeller.lhs. I think I reported the bug and sent a patch to ghc-bugs, but it seems it is not fixed yet.... Here HEAD means the head of my copy.

-- 'pprintType' is a workaround for the problem that @Language.Haskell.TH.pprint :: Type -> String@ does not print parentheses correctly.
-- (try @Language.Haskell.TH.runQ [t| (Int->Int)->Int |] >>= \e -> putStrLn (pprint e)@ in your copy of GHCi.)
-- The implementation here is not so pretty, but that's OK for my purposes. Also note that 'pprintType' ignores foralls.
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
")"
-- The problem of @Language.Haskell.TH.pprint :: Type -> String@ is now fixed at the darcs HEAD.



{-
-- $B4pK\E*$K(BCoreExpr$B$+$i(BDynamic$B$rI=$9(BTH.Exp$B$r:n$k!%(B
-- unsafeExecute ce$B$H(B $(exprToExpDynamic ce)$B$H$N0c$$$O!$8e<T$O&K<0$r%W%m%0%i%`Cf$KE=$jIU$1$k$N$G!$B?$/$N(Bprimitive combinators$B$r=hM}$9$k%3%9%H$,$+$+$i$J$$$C$F$3$H!%(BSupercombinator$B$K$h$k<BAu$_$?$$$J$b$N!%(B
exprToExpDynamic :: Language.Haskell.TH.Type -> CoreExpr -> ExpQ
exprToExpDynamic ty ce
    = case -- trace ("ce = "++pprint (exprToTHExp ce)) $
           e2THE ce of
                       the ->
--        the -> case tiExpression tl (error ("exprToExpDynamic: tcl required. unDeBruijn ce = "++show (unDeBruijn ce)++",\n and the = "++pprint the)) $ unDeBruijn ce of
                            do thee <- expToExpExp the  -- $B<B$O$3$3$,0lHV;~4V$,$+$+$k5$$,$9$k$N$@$,!$%G%P%C%0>pJs$7$+$J$$$N$G!$(BREALDYNAMIC$B$G$J$$>l9g$O$J$s$H$+$G$-$k$+$b!%(B
                               thty <- MHTH.typeToExpType ty         $B$3$l$@$H!$(Bsplice$B$7$?7k2L$,(BTH.Type$B$K$J$C$F$7$^$&!%(B
                               return ((((VarE 'unsafeToDyn) `AppE` thty)
                                                             `AppE` the)
                                                             `AppE` thee)
-}
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
{-
hdmnTHEQ m n = do hd  <- mkHd
                  mes <- mkEs m
                  mxs <- mkXs m
                  nas <- mkAs n
                  let lambdas = LamE (map VarP (hd : mes ++ nas))
                      appa1an var = foldl AppE (VarE var) $ map VarE nas
                  return $ (VarE 'unsafeCoerce#) `AppE` lambdas (foldl AppE (VarE hd) (map appa1an mes))
-}
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
{-
aimnTHEQ i m n = do
                  mes <- mkEs m
                  nas <- mkAs n
                  let lambdas = LamE (map VarP (mes ++ nas))
                      appa1an var = foldl AppE (VarE var) $ map VarE nas
                  return $ (VarE 'unsafeCoerce#) `AppE` lambdas (foldl AppE (VarE (nas!!i)) (map appa1an mes))
-}

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)

-- copied from ExecuteAPI $B$F$f!<$+!$(BmkCE_LambdaBoundHead$B$G$O(Bde Bruijn index$B$r;H$C$F$$$k$,!$(BExecuteAPI.aimn$B$O5U8~$-$K(Bindex$B$r3d$jEv$F$F$$$k$N$G!$$=$N$^$^;}$C$F$-$F$O%@%a!%(B
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 -- hdmnty$B$H$N0c$$$O$3$3$@$1(B
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


-- $B0J2<$N?tCM$O!$$I$N%5%$%:$^$GD>@\(Bsupercombinator$B$rMQ0U$9$k$+$rI=$9!%(B
-- $B$3$NHO0O$K<}$^$i$J$$>l9g$G$b!$(Bprimitive combinators$B$G%;%3%;%3$7$J$1$l$P$J$i$J$$$H$$$&Lu$G$O$J$$(B
maxArity, maxLenavails :: Int8
maxArity :: Int8
maxArity = Int8
4
maxLenavails :: Int8
maxLenavails = Int8
8 -- $B4pK\E*$K2?2s4X?t9g@.$9$k$+$NLdBj$J$N$G!$$?$H$($P(B13$B$H$+$J$i(B8+5$B$H9M$($F(B2$B2s9g@.$7$F$b$=$s$J$K8zN($OMn$A$J$$!$$H;W$&!%(B
maxDebindex :: Int8
maxDebindex = Int8
maxLenavailsInt8 -> Int8 -> Int8
forall a. Num a => a -> a -> a
-Int8
1
-- maxArity = 0
-- maxLenavails = 0

mkCE :: Int8           -- ^ length of avails
        -> Int8          -- ^ arity of the head function
        -> 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)

{-
usage:   (dynss !! length avail !! (arity_of_head)) `dynApp` (dynamic_head_as_ce) `dynApp` (dynamic_as_result_of_recursive_call_as_f) `dynApp` ... `dynApp` (dynamic_as_result_of_recursive_call_as_h)

[ [ \ce ->         ce ,  \ce -> \f ->         ce  f,        \ce -> \f g ->         ce  f       g,        \ce -> \f g h ->         ce  f       g       h,       ... ],
  [ \ce ->   (\e-> ce),  \ce -> \f ->   (\e-> ce (f e)),    \ce -> \f g ->   (\e-> ce (f e)   (g e)),    \ce -> \f g h -> (\e  -> ce (f e)   (g e)   (h e)),   ... ],
  [ \ce -> (\e b-> ce),  \ce -> \f -> (\e b-> ce (f e b)),  \ce -> \f g -> (\e b-> ce (f e b) (g e b)),  \ce -> \f g h -> (\e b-> ce (f e b) (g e b) (h e b)), ... ],
  ... ]
-}

-- mkCE$B$G(B\ce->$B$r$H$C$F(Bce$B$r(BX debindex$B$K$9$k$@$1!%(B
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)
-- $B$F$f!<$+!$(Bce$B$r:G8e$K;}$C$F$/$k$h$&$K$9$l$PE}9g$G$-$kLu$M!%(B
-- mkCE_LambdaBoundHead debindex lenavails arity = (mkCE lenavails (arity+1) :$ (Lambda $ X 0)) :$ (napply lenavails Lambda $ X debindex)