-- 
-- (c) Susumu Katayama
--
CoreLang.lhs
extracted haskell-src-free stuff that can be used with Hat.
(This looks like Bindging.hs....)

\begin{code}
{-# LANGUAGE CPP, ExistentialQuantification, RankNTypes, TemplateHaskell #-}
-- workaround Haddock invoked from Cabal unnecessarily chasing imports. (If cpp fails, haddock ignores the remaining part of the module.)
#ifndef __GLASGOW_HASKELL__
-- x #hoge
#endif


module MagicHaskeller.CoreLang where
import Language.Haskell.TH
import Data.Array

import Debug.Trace

import qualified MagicHaskeller.PolyDynamic as PD
-- import MagicHaskeller.MyDynamic

import Data.Char(chr,ord,isDigit)
import MagicHaskeller.TyConLib
import MagicHaskeller.ReadTHType(thTypeToType)
#ifdef FORCE
import Control.Parallel.Strategies
#endif
-- required to make sure expressions are ready, so we can measure the exact time consumed to execute the expressions before time out.

import Data.Bits

import Data.Function(fix)

import Data.Int
import Data.Word
import Data.List(genericLength, genericIndex)

infixl :$

type Var = Int16

data CoreExpr = S | K | I | B | C | S' | B' | C' | Y
                | Lambda CoreExpr | X {-# UNPACK #-} !Int8 -- de Bruijn notation
--                | Lambda CoreExpr | X Int8 -- de Bruijn notation
                | FunLambda CoreExpr | FunX Int8 -- different system of de Bruijn notation for functions, used by IOPairs.hs
                | Tuple {-# UNPACK #-} !Int8
--                | Tuple Int8
{-                
                | Primitive Int 
                            Bool   -- True if the primitive is a constructor expression
-}
                | Primitive {CoreExpr -> Var
primId :: {-# UNPACK #-} !Var}  -- (This should be Var instead of Int8 because the number space is being exhausted!)
                | PrimCon   {primId :: {-# UNPACK #-} !Var}  -- the primitive is a constructor expression
--                | Primitive {primId :: Var}  -- (This should be Var instead of Int8 because the number space is being exhausted!)
--                | PrimCon   {primId :: Var}  -- the primitive is a constructor expression
                | Context Dictionary
                | CoreExpr :$ CoreExpr
                | Case CoreExpr [(Var,Int8,CoreExpr)] -- the case expression. [(primitive ID of the constructor, arity of the constructor, rhs of ->)]
                | Fix  CoreExpr Int8 [Int8]            -- Fix expr n is === foldl (:$) (Y :$ FunLambda (napply n Lambda expr)) (map X is)
{-
                | FixCase       [(Int,Int,CoreExpr)] -- FixCase ts === (Y :$ Lambda (Lambda (Case (X 0) ts)))
                                                     -- See notes on July 3, 2010
-}
                | VarName String -- This is only used for pretty printing IOPairs.Expr. Use de Bruijn variables for other purposes.
                  deriving (CoreExpr -> CoreExpr -> Bool
(CoreExpr -> CoreExpr -> Bool)
-> (CoreExpr -> CoreExpr -> Bool) -> Eq CoreExpr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CoreExpr -> CoreExpr -> Bool
$c/= :: CoreExpr -> CoreExpr -> Bool
== :: CoreExpr -> CoreExpr -> Bool
$c== :: CoreExpr -> CoreExpr -> Bool
Eq, Int -> CoreExpr -> ShowS
[CoreExpr] -> ShowS
CoreExpr -> String
(Int -> CoreExpr -> ShowS)
-> (CoreExpr -> String) -> ([CoreExpr] -> ShowS) -> Show CoreExpr
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CoreExpr] -> ShowS
$cshowList :: [CoreExpr] -> ShowS
show :: CoreExpr -> String
$cshow :: CoreExpr -> String
showsPrec :: Int -> CoreExpr -> ShowS
$cshowsPrec :: Int -> CoreExpr -> ShowS
Show, Eq CoreExpr
Eq CoreExpr
-> (CoreExpr -> CoreExpr -> Ordering)
-> (CoreExpr -> CoreExpr -> Bool)
-> (CoreExpr -> CoreExpr -> Bool)
-> (CoreExpr -> CoreExpr -> Bool)
-> (CoreExpr -> CoreExpr -> Bool)
-> (CoreExpr -> CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr -> CoreExpr)
-> Ord CoreExpr
CoreExpr -> CoreExpr -> Bool
CoreExpr -> CoreExpr -> Ordering
CoreExpr -> CoreExpr -> CoreExpr
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: CoreExpr -> CoreExpr -> CoreExpr
$cmin :: CoreExpr -> CoreExpr -> CoreExpr
max :: CoreExpr -> CoreExpr -> CoreExpr
$cmax :: CoreExpr -> CoreExpr -> CoreExpr
>= :: CoreExpr -> CoreExpr -> Bool
$c>= :: CoreExpr -> CoreExpr -> Bool
> :: CoreExpr -> CoreExpr -> Bool
$c> :: CoreExpr -> CoreExpr -> Bool
<= :: CoreExpr -> CoreExpr -> Bool
$c<= :: CoreExpr -> CoreExpr -> Bool
< :: CoreExpr -> CoreExpr -> Bool
$c< :: CoreExpr -> CoreExpr -> Bool
compare :: CoreExpr -> CoreExpr -> Ordering
$ccompare :: CoreExpr -> CoreExpr -> Ordering
$cp1Ord :: Eq CoreExpr
Ord)
newtype Dictionary = Dict {Dictionary -> Dynamic
undict :: PD.Dynamic} deriving (Int -> Dictionary -> ShowS
[Dictionary] -> ShowS
Dictionary -> String
(Int -> Dictionary -> ShowS)
-> (Dictionary -> String)
-> ([Dictionary] -> ShowS)
-> Show Dictionary
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Dictionary] -> ShowS
$cshowList :: [Dictionary] -> ShowS
show :: Dictionary -> String
$cshow :: Dictionary -> String
showsPrec :: Int -> Dictionary -> ShowS
$cshowsPrec :: Int -> Dictionary -> ShowS
Show)
instance Ord Dictionary where
    compare :: Dictionary -> Dictionary -> Ordering
compare Dictionary
_ Dictionary
_ = Ordering
EQ -- This should work for the current purposes, but can cause a bug.
instance Eq Dictionary where
    Dictionary
_ == :: Dictionary -> Dictionary -> Bool
== Dictionary
_ = Bool
True -- This should work for the current purposes, but can cause a bug.

-- required to make sure expressions are ready, so we can measure the exact time consumed to execute the expressions before time out.
#ifdef FORCE
instance NFData CoreExpr where
    rnf (Lambda e) = rnf e
    rnf (X i)      = rnf i
    rnf (Tuple i)  = rnf i
    rnf (Primitive _) = () -- 最後のパターンにマッチするのでこれは要らなかったか．
    rnf (c :$ d)         = rnf c `seq` rnf d
    rnf e                = ()
#endif

arityCE :: CoreExpr -> Int
arityCE :: CoreExpr -> Int
arityCE (Lambda CoreExpr
e)    = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ CoreExpr -> Int
arityCE CoreExpr
e
arityCE (FunLambda CoreExpr
e) = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ CoreExpr -> Int
arityCE CoreExpr
e
arityCE CoreExpr
_             = Int
0

isAbsent :: Int -> CoreExpr -> Bool
isAbsent :: Int -> CoreExpr -> Bool
isAbsent Int
numArgs CoreExpr
expr = Integer -> CoreExpr -> Integer
isa (Integer
2Integer -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^Int
numArgs Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1) CoreExpr
expr Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
0
isa :: Integer -> CoreExpr -> Integer
isa :: Integer -> CoreExpr -> Integer
isa Integer
bits (X Int8
n) = Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
clearBit Integer
bits (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ Int8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int8
n
isa Integer
bits (Lambda CoreExpr
e) = Integer -> CoreExpr -> Integer
isa (Integer
bits Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
1) CoreExpr
e Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
1
isa Integer
bits (CoreExpr
f :$ CoreExpr
e )  = Integer -> CoreExpr -> Integer
isa (Integer -> CoreExpr -> Integer
isa Integer
bits CoreExpr
f) CoreExpr
e
isa Integer
bits Primitive{} = Integer
bits
isa Integer
bits PrimCon{}   = Integer
bits
isa Integer
bits Context{}   = Integer
bits
{- unused due to inefficiency
ceToInteger (Lambda e)    = ceToInteger e -- 型が変わっちゃうのでLambdaは無視できるはず．...  といいつつ自信無．July 24, 2008のnotesを参照. ま，hashには使えるという程度のつもり．
ceToInteger (f :$ e)      = 3 * (ceToInteger f `interleave` ceToInteger e)
ceToInteger (X n)         = 3 * toInteger n + 1
ceToInteger (Primitive n _) = 3 * toInteger n + 2

0 `interleave` 0 = 0
i `interleave` j = (j `interleave` (i `shiftR` 1)) * 2 + (i `mod` 2)
-- IntegerでなくIntを使う場合，算術右シフトshiftRでなく論理右シフトを使う必要がある...のはいいけど，なぜライブラリに論理右シフトがない?
logShiftR1 n = (n `clearBit` 0) `rotateR` 1 
-}
#if __GLASGOW_HASKELL__ < 710
instance Ord Exp where
    compare (VarE n0) (VarE n1) = n0 `compare` n1
    compare (VarE n0) _         = LT
    compare (ConE n0) (VarE n1) = GT
    compare (ConE n0) (ConE n1) = n0 `compare` n1
    compare (ConE n0) _         = LT
    compare (AppE _ _) (VarE _) = GT
    compare (AppE _ _) (ConE _) = GT
    compare (AppE e0 f0) (AppE e1 f1) = case compare e0 e1 of EQ -> compare f0 f1
                                                              c  -> c
    compare (AppE _ _) _        = LT

    compare a b = show a `compare` show b -- 超遅そう....
#endif
instance Read Exp where
    readsPrec :: Int -> ReadS Exp
readsPrec Int
_ String
str = [(String -> Exp
forall a. HasCallStack => String -> a
error String
"ReadS Exp is not implemented yet", String
str)]


type VarLib = Array Var PD.Dynamic
type VarPriorityLib = Array Var Int

actualVarName :: String -> Exp
actualVarName :: String -> Exp
actualVarName = Name -> Exp
VarE (Name -> Exp) -> (String -> Name) -> String -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName (String -> Name) -> ShowS -> String -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
stripByd_
stripByd_ :: ShowS
stripByd_ (Char
'b':Char
'y':Char
d:Char
'_':String
name) | Char -> Bool
isDigit Char
d = String
name
stripByd_ (Char
'-':Char
'-':Char
'#':String
name) = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'#') String
name
stripByd_ String
name = String
name

headIsX :: CoreExpr -> Bool
headIsX :: CoreExpr -> Bool
headIsX (Lambda CoreExpr
e)    = CoreExpr -> Bool
headIsX CoreExpr
e
headIsX (FunLambda CoreExpr
e) = CoreExpr -> Bool
headIsX CoreExpr
e
headIsX (CoreExpr
f :$ CoreExpr
e)      = CoreExpr -> Bool
headIsX CoreExpr
f
headIsX (X Int8
_)         = Bool
True
headIsX (FunX Int8
_)      = Bool
True
headIsX CoreExpr
_             = Bool
False

isAPrimitiveCombinator :: CoreExpr -> Bool
isAPrimitiveCombinator :: CoreExpr -> Bool
isAPrimitiveCombinator (Lambda CoreExpr
e) = CoreExpr -> Bool
isAPrimitiveCombinator CoreExpr
e
isAPrimitiveCombinator (FunLambda CoreExpr
e) = CoreExpr -> Bool
isAPrimitiveCombinator CoreExpr
e
isAPrimitiveCombinator (X Int8
_)      = Bool
True
isAPrimitiveCombinator (FunX Int8
_)   = Bool
True
isAPrimitiveCombinator (Primitive Var
_) = Bool
False -- The meaning of "primitive" is different!
isAPrimitiveCombinator (PrimCon   Var
_) = Bool
False
isAPrimitiveCombinator (Context   Dictionary
_) = Bool
False
isAPrimitiveCombinator (CoreExpr
f :$ CoreExpr
e)      = CoreExpr -> Bool
isAPrimitiveCombinator CoreExpr
f Bool -> Bool -> Bool
&& CoreExpr -> Bool
isAPrimitiveCombinator CoreExpr
e
isAPrimitiveCombinator (Fix CoreExpr
_ Int8
_ [Int8]
_)   = Bool
True
isAPrimitiveCombinator CoreExpr
_             = Bool
True -- bothered. Anyway, there is no plan of using this function for analytical synthesis.

-- removeAbsents removes absent arguments.
removeAbsents :: CoreExpr -> CoreExpr
removeAbsents :: CoreExpr -> CoreExpr
removeAbsents (Lambda CoreExpr
e) = CoreExpr -> CoreExpr
removeAbsents CoreExpr
e
removeAbsents CoreExpr
e
    = let args :: Int
args     = Int8 -> CoreExpr -> Int
forall a. (Bits a, Num a) => Int8 -> CoreExpr -> a
unboundXs Int8
0 CoreExpr
e :: Int
          newArity :: Int
newArity = Int -> Int
forall a. Bits a => a -> Int
popCount Int
args
      in Int -> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall i a. Integral i => i -> (a -> a) -> a -> a
napply Int
newArity CoreExpr -> CoreExpr
Lambda (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ Int -> Int8 -> CoreExpr -> CoreExpr
forall a. (Bits a, Num a) => a -> Int8 -> CoreExpr -> CoreExpr
adjustXs Int
args Int8
0 CoreExpr
e
adjustXs :: a -> Int8 -> CoreExpr -> CoreExpr
adjustXs a
args Int8
dep (Lambda CoreExpr
e) = CoreExpr -> CoreExpr
Lambda (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ a -> Int8 -> CoreExpr -> CoreExpr
adjustXs a
args (Int8
depInt8 -> Int8 -> Int8
forall a. Num a => a -> a -> a
+Int8
1) CoreExpr
e
adjustXs a
args Int8
dep (X Int8
n) | Int8
diff Int8 -> Int8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Int8
0 = Int8 -> CoreExpr
X (Int8 -> CoreExpr) -> Int8 -> CoreExpr
forall a b. (a -> b) -> a -> b
$ Int -> Int8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a -> Int
forall a. Bits a => a -> Int
popCount ((Int -> a
forall a. Bits a => Int -> a
bit (Int8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int8
diff) a -> a -> a
forall a. Num a => a -> a -> a
- a
1) a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
args)) Int8 -> Int8 -> Int8
forall a. Num a => a -> a -> a
+ Int8
dep
                          where diff :: Int8
diff = Int8
n Int8 -> Int8 -> Int8
forall a. Num a => a -> a -> a
- Int8
dep
adjustXs a
args Int8
dep (CoreExpr
f :$ CoreExpr
x)   = a -> Int8 -> CoreExpr -> CoreExpr
adjustXs a
args Int8
dep CoreExpr
f CoreExpr -> CoreExpr -> CoreExpr
:$ a -> Int8 -> CoreExpr -> CoreExpr
adjustXs a
args Int8
dep CoreExpr
x
adjustXs a
_    Int8
_   CoreExpr
e          = CoreExpr
e

-- This is similar to isAbsent.
unboundXs :: Int8 -> CoreExpr -> a
unboundXs Int8
dep (Lambda CoreExpr
e)      = Int8 -> CoreExpr -> a
unboundXs (Int8
depInt8 -> Int8 -> Int8
forall a. Num a => a -> a -> a
+Int8
1) CoreExpr
e
unboundXs Int8
dep (X Int8
n) | Int8
diffInt8 -> Int8 -> Bool
forall a. Ord a => a -> a -> Bool
>=Int8
0 = Int -> a
forall a. Bits a => Int -> a
bit (Int8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int8
diff) where diff :: Int8
diff = Int8
nInt8 -> Int8 -> Int8
forall a. Num a => a -> a -> a
-Int8
dep
unboundXs Int8
dep (CoreExpr
f :$ CoreExpr
e)        = Int8 -> CoreExpr -> a
unboundXs Int8
dep CoreExpr
f a -> a -> a
forall a. Bits a => a -> a -> a
.|. Int8 -> CoreExpr -> a
unboundXs Int8
dep CoreExpr
e
unboundXs Int8
dep CoreExpr
_               = a
0


subexprs :: CoreExpr -> [CoreExpr]
subexprs :: CoreExpr -> [CoreExpr]
subexprs CoreExpr
e = Integer -> CoreExpr -> [CoreExpr]
forall i. Integral i => i -> CoreExpr -> [CoreExpr]
sub Integer
0 CoreExpr
e
sub :: i -> CoreExpr -> [CoreExpr]
sub i
dep (Lambda CoreExpr
e) = i -> CoreExpr -> [CoreExpr]
sub (i -> i
forall a. Enum a => a -> a
succ i
dep) CoreExpr
e
sub i
dep CoreExpr
e          = i -> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall i a. Integral i => i -> (a -> a) -> a -> a
napply i
dep CoreExpr -> CoreExpr
Lambda CoreExpr
e CoreExpr -> [CoreExpr] -> [CoreExpr]
forall a. a -> [a] -> [a]
: (CoreExpr -> [CoreExpr]) -> [CoreExpr] -> [CoreExpr]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (i -> CoreExpr -> [CoreExpr]
sub i
dep) (CoreExpr -> [CoreExpr]
args CoreExpr
e)

branches :: CoreExpr -> [CoreExpr]
branches :: CoreExpr -> [CoreExpr]
branches CoreExpr
e = Integer -> CoreExpr -> [CoreExpr]
forall i. Integral i => i -> CoreExpr -> [CoreExpr]
bra Integer
0 CoreExpr
e
bra :: i -> CoreExpr -> [CoreExpr]
bra i
dep (Lambda CoreExpr
e) = i -> CoreExpr -> [CoreExpr]
bra (i -> i
forall a. Enum a => a -> a
succ i
dep) CoreExpr
e
bra i
dep e :: CoreExpr
e@(CoreExpr
_:$CoreExpr
_)   = i -> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall i a. Integral i => i -> (a -> a) -> a -> a
napply i
dep CoreExpr -> CoreExpr
Lambda CoreExpr
e CoreExpr -> [CoreExpr] -> [CoreExpr]
forall a. a -> [a] -> [a]
: (CoreExpr -> [CoreExpr]) -> [CoreExpr] -> [CoreExpr]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (i -> CoreExpr -> [CoreExpr]
bra i
dep) (CoreExpr -> [CoreExpr]
args CoreExpr
e)
bra i
_   CoreExpr
_          = []

-- | 'parentsOfLeaves' collects branch nodes whose children are leaf nodes. This can be used for incremental learning.
parentsOfLeaves :: CoreExpr -> [CoreExpr]
parentsOfLeaves :: CoreExpr -> [CoreExpr]
parentsOfLeaves CoreExpr
e | CoreExpr -> Bool
isALeaf CoreExpr
e = []
                  | Bool
otherwise = Integer -> CoreExpr -> [CoreExpr]
forall i. Integral i => i -> CoreExpr -> [CoreExpr]
pol Integer
0 CoreExpr
e
pol :: i -> CoreExpr -> [CoreExpr]
pol i
dep (Lambda CoreExpr
e) = i -> CoreExpr -> [CoreExpr]
pol (i -> i
forall a. Enum a => a -> a
succ i
dep) CoreExpr
e
pol i
dep CoreExpr
e = case (CoreExpr -> Bool) -> [CoreExpr] -> [CoreExpr]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (CoreExpr -> Bool) -> CoreExpr -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreExpr -> Bool
isALeaf) ([CoreExpr] -> [CoreExpr]) -> [CoreExpr] -> [CoreExpr]
forall a b. (a -> b) -> a -> b
$ CoreExpr -> [CoreExpr]
args CoreExpr
e of []       -> [i -> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall i a. Integral i => i -> (a -> a) -> a -> a
napply i
dep CoreExpr -> CoreExpr
Lambda CoreExpr
e]
                                                    [CoreExpr]
branches -> (CoreExpr -> [CoreExpr]) -> [CoreExpr] -> [CoreExpr]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (i -> CoreExpr -> [CoreExpr]
pol i
dep) [CoreExpr]
branches
args :: CoreExpr -> [CoreExpr]
args (CoreExpr
f :$ CoreExpr
e) = CoreExpr
e CoreExpr -> [CoreExpr] -> [CoreExpr]
forall a. a -> [a] -> [a]
: CoreExpr -> [CoreExpr]
args CoreExpr
f
args CoreExpr
_        = []

{-
-- \a b c -> f (\d e -> E) を \a b c -> f ((\a b c d e -> E) a b c)に．
mkRedundant :: CoreExpr -> CoreExpr
mkRedundant = mR 0 0
mR :: Int8 -> Int8 -> CoreExpr -> CoreExpr
mR dep fdep (Lambda e)    = Lambda $ mR (succ dep) fdep e
mR dep fdep (FunLambda e) = FunLambda $ mR dep (succ fdep) e
mR dep fdep (f :$ x)      = mR dep fdep f :$ foldl (:$) (napply dep Lambda $ napply fdep FunLambda $ mR dep fdep x) (map X [dep+fdep-1,dep+fdep-2..fdep] ++ map FunX [fdep-1,fdep-2..0])
--mR dep fdep (f :$ x)      = mR dep fdep f :$ foldl (:$) (napply dep Lambda $ napply fdep FunLambda $ mR dep fdep x) (map X [0..dep-1] ++ map FunX [dep..dep+fdep-1])
mR _   _    e             = e
-}

isALeaf :: CoreExpr -> Bool
isALeaf :: CoreExpr -> Bool
isALeaf (Lambda CoreExpr
e) = CoreExpr -> Bool
isALeaf CoreExpr
e
isALeaf (CoreExpr
_ :$ CoreExpr
_)   = Bool
False
isALeaf CoreExpr
_          = Bool
True

{-
skipLambdas dep (Lambda e)    = skipLambdas (dep+1) e
skipLambdas dep (FunLambda e) = skipLambdas (dep+1) e
skipLambdas dep e             = (dep,e)
-}


ceToPriority :: VarPriorityLib -> CoreExpr -> Int
ceToPriority :: VarPriorityLib -> CoreExpr -> Int
ceToPriority VarPriorityLib
vpl (Lambda CoreExpr
e)    = VarPriorityLib -> CoreExpr -> Int
ceToPriority VarPriorityLib
vpl CoreExpr
e
ceToPriority VarPriorityLib
vpl (FunLambda CoreExpr
e) = VarPriorityLib -> CoreExpr -> Int
ceToPriority VarPriorityLib
vpl CoreExpr
e
ceToPriority VarPriorityLib
vpl (CoreExpr
f :$ CoreExpr
x)      = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ VarPriorityLib -> CoreExpr -> Int
ceToPriority VarPriorityLib
vpl CoreExpr
f Int -> Int -> Int
forall a. Num a => a -> a -> a
+ VarPriorityLib -> CoreExpr -> Int
ceToPriority VarPriorityLib
vpl CoreExpr
x
ceToPriority VarPriorityLib
_   (X Int8
_)         = Int
0
ceToPriority VarPriorityLib
_   (FunX Int8
_)      = Int
0
ceToPriority VarPriorityLib
vpl (Primitive Var
i) = VarPriorityLib
vpl VarPriorityLib -> Var -> Int
forall i e. Ix i => Array i e -> i -> e
! Var
i
ceToPriority VarPriorityLib
vpl (PrimCon Var
i)   = VarPriorityLib
vpl VarPriorityLib -> Var -> Int
forall i e. Ix i => Array i e -> i -> e
! Var
i
ceToPriority VarPriorityLib
vpl (Context Dictionary
dict)= Int
0



-- x 第1引数のplはArray Con Stringなんだけど，もう全部Primitiveを使うことになったので不要．
-- exprToTHExp converts CoreLang.CoreExpr into Language.Haskell.TH.Exp
exprToTHExp, exprToTHExpLite :: VarLib -> CoreExpr -> Exp
exprToTHExp :: VarLib -> CoreExpr -> Exp
exprToTHExp VarLib
vl CoreExpr
e = Bool -> VarLib -> CoreExpr -> Exp
exprToTHExp' Bool
True VarLib
vl (CoreExpr -> Exp) -> CoreExpr -> Exp
forall a b. (a -> b) -> a -> b
$ CoreExpr -> CoreExpr
lightBeta CoreExpr
e
exprToTHExpLite :: VarLib -> CoreExpr -> Exp
exprToTHExpLite VarLib
vl CoreExpr
e = Bool -> VarLib -> CoreExpr -> Exp
exprToTHExp' Bool
False VarLib
vl (CoreExpr -> Exp) -> CoreExpr -> Exp
forall a b. (a -> b) -> a -> b
$ CoreExpr -> CoreExpr
lightBeta CoreExpr
e
exprToTHExp' :: Bool -> VarLib -> CoreExpr -> Exp
exprToTHExp' Bool
pretty VarLib
vl CoreExpr
e = Int8 -> Int8 -> CoreExpr -> Exp
x2hsx (Int -> Int8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int8) -> Int -> Int8
forall a b. (a -> b) -> a -> b
$ Char -> Int
ord Char
'a'Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1 :: Int8) (Int -> Int8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int8) -> Int -> Int8
forall a b. (a -> b) -> a -> b
$ Char -> Int
ord Char
'a' Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) CoreExpr
e
    where x2hsx :: Int8 -> Int8 -> CoreExpr -> Exp
          x2hsx :: Int8 -> Int8 -> CoreExpr -> Exp
x2hsx Int8
dep Int8
fdep (Lambda CoreExpr
e) = 
                       case Int8 -> Int8 -> CoreExpr -> Exp
x2hsx (Int8
depInt8 -> Int8 -> Int8
forall a. Num a => a -> a -> a
+Int8
1) Int8
fdep CoreExpr
e of LamE [Pat]
pvars Exp
expr -> [Pat] -> Exp -> Exp
LamE (Pat
pvarPat -> [Pat] -> [Pat]
forall a. a -> [a] -> [a]
:[Pat]
pvars) Exp
expr
                                                    Exp
expr            -> [Pat] -> Exp -> Exp
LamE [Pat
pvar] Exp
expr
              where var :: Name
var  = String -> Name
mkName [Int -> Char
chr (Int -> Char) -> Int -> Char
forall a b. (a -> b) -> a -> b
$ Int8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int8
depInt8 -> Int8 -> Int8
forall a. Num a => a -> a -> a
+Int8
1)]
                    pvar :: Pat
pvar | Bool -> Bool
not Bool
pretty Bool -> Bool -> Bool
|| Int8
0 Int8 -> CoreExpr -> Bool
`occursIn` CoreExpr
e = Name -> Pat
VarP Name
var
                         | Bool
otherwise                     = Pat
WildP
          x2hsx Int8
dep Int8
fdep (FunLambda CoreExpr
e) = 
                       case Int8 -> Int8 -> CoreExpr -> Exp
x2hsx Int8
dep (Int8
fdepInt8 -> Int8 -> Int8
forall a. Num a => a -> a -> a
+Int8
1) CoreExpr
e of LamE [Pat]
pvars Exp
expr -> [Pat] -> Exp -> Exp
LamE (Pat
pvarPat -> [Pat] -> [Pat]
forall a. a -> [a] -> [a]
:[Pat]
pvars) Exp
expr
                                                    Exp
expr            -> [Pat] -> Exp -> Exp
LamE [Pat
pvar] Exp
expr
              where var :: Name
var  = String -> Name
mkName [Char
'f', Int -> Char
chr (Int -> Char) -> Int -> Char
forall a b. (a -> b) -> a -> b
$ Int8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int8
fdepInt8 -> Int8 -> Int8
forall a. Num a => a -> a -> a
+Int8
1)]
                    pvar :: Pat
pvar | Bool -> Bool
not Bool
pretty Bool -> Bool -> Bool
|| Int8
0 Int8 -> CoreExpr -> Bool
`funOccursIn` CoreExpr
e = Name -> Pat
VarP Name
var
                         | Bool
otherwise                        = Pat
WildP
          x2hsx Int8
dep Int8
fdep (X Int8
n)            = Name -> Exp
VarE (String -> Name
mkName [Int -> Char
chr (Int -> Char) -> Int -> Char
forall a b. (a -> b) -> a -> b
$ Int8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int8
dep Int8 -> Int8 -> Int8
forall a. Num a => a -> a -> a
- Int8
n :: Int8)])         -- X nはX 0, X 1, ....
          x2hsx Int8
dep Int8
fdep (FunX Int8
n)            = Name -> Exp
VarE (String -> Name
mkName [Char
'f', Int -> Char
chr (Int -> Char) -> Int -> Char
forall a b. (a -> b) -> a -> b
$ Int8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int8
fdep Int8 -> Int8 -> Int8
forall a. Num a => a -> a -> a
- Int8
n)])         -- X nはX 0, X 1, ....
--          x2hsx _   (Qualified con)  = VarE (mkName (pl ! con))
          x2hsx Int8
_   Int8
_    (Primitive Var
n)  = Var -> Exp
x2hsxPrim Var
n
          x2hsx Int8
_   Int8
_    (PrimCon   Var
n)  = Var -> Exp
x2hsxPrim Var
n
          x2hsx Int8
dep Int8
fdep (p :: CoreExpr
p@(Primitive Var
_) :$ CoreExpr
e :$ CoreExpr
e0 :$ CoreExpr
e1) | CoreExpr -> Bool
hdIsCxt CoreExpr
e = Int8 -> Int8 -> CoreExpr -> CoreExpr -> CoreExpr -> Exp
x2hsxPrim3 Int8
dep Int8
fdep CoreExpr
p CoreExpr
e0 CoreExpr
e1
          x2hsx Int8
dep Int8
fdep (p :: CoreExpr
p@(PrimCon   Var
_) :$ CoreExpr
e :$ CoreExpr
e0 :$ CoreExpr
e1) | CoreExpr -> Bool
hdIsCxt CoreExpr
e = Int8 -> Int8 -> CoreExpr -> CoreExpr -> CoreExpr -> Exp
x2hsxPrim3 Int8
dep Int8
fdep CoreExpr
p CoreExpr
e0 CoreExpr
e1 -- cannot happen currently, but maybe in future if negate and succ will become polymorphic and regarded as constructors.
          x2hsx Int8
dep Int8
fdep (p :: CoreExpr
p@(Primitive Var
_) :$ CoreExpr
e0 :$ CoreExpr
e1) = Int8 -> Int8 -> CoreExpr -> CoreExpr -> CoreExpr -> Exp
x2hsxPrim3 Int8
dep Int8
fdep CoreExpr
p CoreExpr
e0 CoreExpr
e1
          x2hsx Int8
dep Int8
fdep (p :: CoreExpr
p@(PrimCon   Var
_) :$ CoreExpr
e0 :$ CoreExpr
e1) = Int8 -> Int8 -> CoreExpr -> CoreExpr -> CoreExpr -> Exp
x2hsxPrim3 Int8
dep Int8
fdep CoreExpr
p CoreExpr
e0 CoreExpr
e1
          x2hsx Int8
dep Int8
fdep (CoreExpr
Y :$ FunLambda CoreExpr
e) = case Int8 -> Int8 -> CoreExpr -> Exp
x2hsx Int8
dep Int8
fdep (CoreExpr -> CoreExpr
FunLambda CoreExpr
e) of LamE [Pat
WildP]     Exp
expr -> Exp
expr
                                                                                   LamE (Pat
WildP:[Pat]
pvs) Exp
expr -> [Pat] -> Exp -> Exp
LamE [Pat]
pvs Exp
expr
                                                                                   Exp
expr                  -> Name -> Exp
VarE 'fix Exp -> Exp -> Exp
`AppE` Exp
expr
          -- This is still necessary because systematic synthesizer still uses Lambda and X even for functions.
          x2hsx Int8
dep Int8
fdep (CoreExpr
Y :$ Lambda CoreExpr
e) = case Int8 -> Int8 -> CoreExpr -> Exp
x2hsx Int8
dep Int8
fdep (CoreExpr -> CoreExpr
Lambda CoreExpr
e) of LamE [Pat
WildP]     Exp
expr -> Exp
expr
                                                                             LamE (Pat
WildP:[Pat]
pvs) Exp
expr -> [Pat] -> Exp -> Exp
LamE [Pat]
pvs Exp
expr
                                                                             Exp
expr                  -> Name -> Exp
VarE 'fix Exp -> Exp -> Exp
`AppE` Exp
expr
          x2hsx Int8
dep Int8
fdep (CoreExpr
e0 :$ CoreExpr
e1) | CoreExpr -> Bool
hdIsCxt CoreExpr
e1 = Int8 -> Int8 -> CoreExpr -> Exp
x2hsx Int8
dep Int8
fdep CoreExpr
e0
                                    | Bool
otherwise  = Int8 -> Int8 -> CoreExpr -> Exp
x2hsx Int8
dep Int8
fdep CoreExpr
e0 Exp -> Exp -> Exp
`AppE` Int8 -> Int8 -> CoreExpr -> Exp
x2hsx Int8
dep Int8
fdep CoreExpr
e1
          x2hsx Int8
dep Int8
fdep (Case CoreExpr
ce [(Var, Int8, CoreExpr)]
ts)     = Exp -> [Match] -> Exp
CaseE (Int8 -> Int8 -> CoreExpr -> Exp
x2hsx Int8
dep Int8
fdep CoreExpr
ce) (((Var, Int8, CoreExpr) -> Match)
-> [(Var, Int8, CoreExpr)] -> [Match]
forall a b. (a -> b) -> [a] -> [b]
map (Int8 -> Int8 -> (Var, Int8, CoreExpr) -> Match
forall b. Integral b => Int8 -> Int8 -> (Var, b, CoreExpr) -> Match
tsToMatch Int8
dep Int8
fdep) [(Var, Int8, CoreExpr)]
ts)
--          x2hsx dep fdep (Fix ce n is)    = x2hsx dep fdep $ foldl (:$) (Y :$ FunLambda (napply n Lambda ce)) (map X is)          -- letを使って書いた方がいい感じになる．
          x2hsx Int8
dep Int8
fdep (Fix CoreExpr
ce Int8
n [Int8]
is)
              = case Int8 -> Int8 -> CoreExpr -> Exp
x2hsx Int8
dep Int8
fdep (CoreExpr -> CoreExpr
FunLambda (Integer -> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall i a. Integral i => i -> (a -> a) -> a -> a
napply (Int8 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int8
n) CoreExpr -> CoreExpr
Lambda CoreExpr
ce)) of
                  LamE (Pat
WildP:[Pat]
ps) Exp
e -> (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Exp -> Exp -> Exp
AppE ([Pat] -> Exp -> Exp
LamE [Pat]
ps Exp
e) ([Exp] -> Exp) -> [Exp] -> Exp
forall a b. (a -> b) -> a -> b
$ (Int8 -> Exp) -> [Int8] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map (Int8 -> Int8 -> CoreExpr -> Exp
x2hsx Int8
dep Int8
fdep (CoreExpr -> Exp) -> (Int8 -> CoreExpr) -> Int8 -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int8 -> CoreExpr
X) [Int8]
is


-- let のあと caseがある場合にさらにrefactorしてたのだが，
-- \a -> let fa (b@0) = 0
--           fa (b@succc) | succc > 0 = GHC.Enum.succ (GHC.Enum.succ (GHC.Enum.succ (fa c)))
--                  where c = succc - 1
--        in fa a
-- みたいなのができてめんどくさい．

-- てゆーか，pretty printしすぎると，ExecuteAPIするとき逆に遅そう．
                  LamE (VarP Name
name : [Pat]
ps) (CaseE (VarE Name
n) [Match]
ms)
                      | Name -> Pat
VarP Name
n Pat -> [Pat] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Pat]
ps -> [Dec] -> Exp -> Exp
LetE [Name -> [Clause] -> Dec
FunD Name
name ((Match -> Clause) -> [Match] -> [Clause]
forall a b. (a -> b) -> [a] -> [b]
map (\(Match Pat
p Body
b [Dec]
decls) -> [Pat] -> Body -> [Dec] -> Clause
Clause ((Pat -> Pat) -> [Pat] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Pat -> Pat -> Pat
replacePat Name
n Pat
p) [Pat]
ps) Body
b [Dec]
decls) [Match]
ms)]
                                                  ((Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Exp -> Exp -> Exp
AppE (Name -> Exp
VarE Name
name) ([Exp] -> Exp) -> [Exp] -> Exp
forall a b. (a -> b) -> a -> b
$ (Int8 -> Exp) -> [Int8] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map (Int8 -> Int8 -> CoreExpr -> Exp
x2hsx Int8
dep Int8
fdep (CoreExpr -> Exp) -> (Int8 -> CoreExpr) -> Int8 -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int8 -> CoreExpr
X) [Int8]
is)
                  LamE (VarP Name
name : [Pat]
ps) Exp
e -> [Dec] -> Exp -> Exp
LetE [Name -> [Clause] -> Dec
FunD Name
name [[Pat] -> Body -> [Dec] -> Clause
Clause [Pat]
ps (Exp -> Body
NormalB Exp
e) []]]
                                                  ((Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Exp -> Exp -> Exp
AppE (Name -> Exp
VarE Name
name) ([Exp] -> Exp) -> [Exp] -> Exp
forall a b. (a -> b) -> a -> b
$ (Int8 -> Exp) -> [Int8] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map (Int8 -> Int8 -> CoreExpr -> Exp
x2hsx Int8
dep Int8
fdep (CoreExpr -> Exp) -> (Int8 -> CoreExpr) -> Int8 -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int8 -> CoreExpr
X) [Int8]
is)
--          x2hsx dep (FixCase ts)     = x2hsx dep (Y :$ Lambda (Lambda (Case (X 0) ts)))
          x2hsx Int8
dep Int8
_ (VarName String
str) = Name -> Exp
VarE (String -> Name
mkName String
str)
          x2hsx Int8
_   Int8
_ CoreExpr
Y                = Name -> Exp
VarE 'fix
          x2hsx Int8
_   Int8
_ CoreExpr
K                = Name -> Exp
VarE 'const
          x2hsx Int8
_   Int8
_ CoreExpr
B                = Name -> Exp
VarE '(.)
          x2hsx Int8
_   Int8
_ CoreExpr
C                = Name -> Exp
VarE 'flip
          x2hsx Int8
_   Int8
_ CoreExpr
S                = Name -> Exp
VarE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"ap"
          x2hsx Int8
_   Int8
_ CoreExpr
I                = Name -> Exp
VarE 'id
          x2hsx Int8
_   Int8
_ CoreExpr
S'               = Name -> Exp
VarE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"sprime"
          x2hsx Int8
_   Int8
_ CoreExpr
B'               = Name -> Exp
VarE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"bprime"
          x2hsx Int8
_   Int8
_ CoreExpr
C'               = Name -> Exp
VarE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"cprime"
          x2hsx Int8
_   Int8
_ CoreExpr
e                = String -> Exp
forall a. HasCallStack => String -> a
error (String
"exprToTHExp: converting " String -> ShowS
forall a. [a] -> [a] -> [a]
++ CoreExpr -> String
forall a. Show a => a -> String
show CoreExpr
e)
          x2hsxPrim :: Var -> Exp
x2hsxPrim Var
n = case Dynamic -> Exp
PD.dynExp (VarLib
vl VarLib -> Var -> Dynamic
forall i e. Ix i => Array i e -> i -> e
! Var
n) of 
                                         ConE Name
name -> Name -> Exp
ConE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase Name
name
                                         VarE Name
name -> String -> Exp
actualVarName (String -> Exp) -> String -> Exp
forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase Name
name
                                         Exp
e -> Exp
e
          x2hsxPrim3 :: Int8 -> Int8 -> CoreExpr -> CoreExpr -> CoreExpr -> Exp
x2hsxPrim3 Int8
dep Int8
fdep CoreExpr
p CoreExpr
e0 CoreExpr
e1
            | CoreExpr -> Bool
hdIsCxt CoreExpr
e0 = Int8 -> Int8 -> CoreExpr -> Exp
x2hsx Int8
dep Int8
fdep (CoreExpr
p CoreExpr -> CoreExpr -> CoreExpr
:$ CoreExpr
e1)
            | Bool
otherwise
              = let hsx0 :: Exp
hsx0 = Int8 -> Int8 -> CoreExpr -> Exp
x2hsx Int8
dep Int8
fdep CoreExpr
e0
                    hsx1 :: Exp
hsx1 = Int8 -> Int8 -> CoreExpr -> Exp
x2hsx Int8
dep Int8
fdep CoreExpr
e1
                    n :: Var
n    = CoreExpr -> Var
primId CoreExpr
p
                in case Dynamic -> Exp
PD.dynExp (VarLib
vlVarLib -> Var -> Dynamic
forall i e. Ix i => Array i e -> i -> e
!Var
n) of 
                                      e :: Exp
e@(VarE Name
name) | String -> Char
forall a. [a] -> a
head String
base Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
"!@#$%&*+./<=>?\\^|-~"
                                                        -> Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE (Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
hsx0) (String -> Exp
actualVarName String
base) (Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
hsx1)
                                                    | Bool
otherwise -> (String -> Exp
actualVarName String
base Exp -> Exp -> Exp
`AppE` Exp
hsx0) Exp -> Exp -> Exp
`AppE` Exp
hsx1
                                                    where base :: String
base = Name -> String
nameBase Name
name
                                      e :: Exp
e@(ConE Name
name) | String
namestr String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
":"      -> case Exp
hsx1 of ListE [Exp]
hsxs                  -> [Exp] -> Exp
ListE (Exp
hsx0 Exp -> [Exp] -> [Exp]
forall a. a -> [a] -> [a]
: [Exp]
hsxs)
                                                                                          ConE Name
n | Name -> String
nameBase Name
n String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"[]" -> [Exp] -> Exp
ListE [Exp
hsx0]
                                                                                          Exp
_                           -> Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE (Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
hsx0) (Name -> Exp
ConE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
":") (Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
hsx1)
                                                    | String -> Char
forall a. [a] -> a
head String
namestr Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':' -> Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE (Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
hsx0) (Name -> Exp
ConE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
namestr) (Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
hsx1)
                                                    | Bool
otherwise -> (Name -> Exp
ConE (String -> Name
mkName String
namestr) Exp -> Exp -> Exp
`AppE` Exp
hsx0) Exp -> Exp -> Exp
`AppE` Exp
hsx1
                                                    where 
                                                       namestr :: String
namestr = Name -> String
nameBase Name
name
                                      Exp
e             -> (Exp
e Exp -> Exp -> Exp
`AppE` Exp
hsx0) Exp -> Exp -> Exp
`AppE` Exp
hsx1

          hdIsCxt :: CoreExpr -> Bool
hdIsCxt (Context{}) = Bool
True
          hdIsCxt (CoreExpr
e :$ CoreExpr
_)    = CoreExpr -> Bool
hdIsCxt CoreExpr
e
          hdIsCxt CoreExpr
_           = Bool
False
          replacePat :: Name -> Pat -> Pat -> Pat
replacePat Name
name Pat
new (VarP Name
o) | Name
oName -> Name -> Bool
forall a. Eq a => a -> a -> Bool
==Name
name   = Name -> Pat -> Pat
AsP Name
name Pat
new
          replacePat Name
_    Pat
_   Pat
old      = Pat
old
          tsToMatch :: Int8 -> Int8 -> (Var, b, CoreExpr) -> Match
tsToMatch Int8
dep Int8
fdep (Var
ctor, b
arity, CoreExpr
expr)
              = case Dynamic -> Exp
PD.dynExp (VarLib
vl VarLib -> Var -> Dynamic
forall i e. Ix i => Array i e -> i -> e
! Var
ctor) of
                  ConE Name
name -> case Int8 -> Int8 -> CoreExpr -> Exp
x2hsx Int8
dep Int8
fdep (Int -> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall i a. Integral i => i -> (a -> a) -> a -> a
napply Int
arint CoreExpr -> CoreExpr
Lambda CoreExpr
expr) of
                                 LamE [Pat]
pvars Exp
ex -> case Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ([Pat] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pat]
pvars) Int
arint of
                                                    Ordering
LT -> String -> Match
forall a. HasCallStack => String -> a
error String
"too few lambda abstractions in Case...can't happen!"
                                                    Ordering
EQ -> Pat -> Body -> [Dec] -> Match
Match (String -> [Pat] -> Pat
mkPat String
nameb [Pat]
pvars) (Exp -> Body
NormalB Exp
ex) []
                                                    Ordering
GT -> Pat -> Body -> [Dec] -> Match
Match (String -> [Pat] -> Pat
mkPat String
nameb [Pat]
tk) (Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ [Pat] -> Exp -> Exp
LamE [Pat]
dr Exp
ex) []
                                                                         where ([Pat]
tk,[Pat]
dr) = Int -> [Pat] -> ([Pat], [Pat])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
arint [Pat]
pvars
                                 Exp
ex -- -- | not pretty && nameb == "[]" -> Match (ConP '[] []) (NormalB ex) []
                                    | Bool
otherwise        -> Pat -> Body -> [Dec] -> Match
Match (Name -> [Pat] -> Pat
ConP (String -> Name
mkName String
nameb) []) (Exp -> Body
NormalB Exp
ex) []
                      where nameb :: String
nameb = Name -> String
nameBase Name
name
                            arint :: Int
arint = b -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral b
arity
                            mkPat :: String -> [Pat] -> Pat
mkPat String
":"     [Pat
pv1,Pat
pv2] = Pat -> Name -> Pat -> Pat
InfixP Pat
pv1 (String -> Name
mkName String
":") Pat
pv2
                            mkPat (Char
':':String
_) [Pat
pv1,Pat
pv2] = Pat -> Name -> Pat -> Pat
InfixP Pat
pv1 (String -> Name
mkName String
nameb) Pat
pv2
                            mkPat String
nmb     [Pat]
pvs       = Name -> [Pat] -> Pat
ConP (String -> Name
mkName String
nameb) [Pat]
pvs
                  VarE Name
name | Name -> String
nameBase Name
name String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"succ" ->
                                case Int8 -> Int8 -> CoreExpr -> Exp
x2hsx (Int8
depInt8 -> Int8 -> Int8
forall a. Num a => a -> a -> a
+Int8
1) Int8
fdep CoreExpr
expr of -- ここのcaseは最初x2hsx dep $ Lambda exprにしていたのだが，WildPになってしまうとguardできなくなるし，かといってCaseの内側でWildPへの置換をやらないとするとみにくいし，このパターンだけWildPを止めるくらいならLambdaの分を展開した方が早いや，ってことで．
                                  Exp
ex -> Pat -> Body -> [Dec] -> Match
Match (Name -> Pat
VarP Name
succn) ([(Guard, Exp)] -> Body
GuardedB [(Exp -> Guard
NormalG (Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE (Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp -> Maybe Exp) -> Exp -> Maybe Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
succn) (Name -> Exp
VarE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
">") (Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp -> Maybe Exp) -> Exp -> Maybe Exp
forall a b. (a -> b) -> a -> b
$ Lit -> Exp
LitE (Lit -> Exp) -> Lit -> Exp
forall a b. (a -> b) -> a -> b
$ Integer -> Lit
IntegerL Integer
0)),Exp
ex)]) [Pat -> Body -> [Dec] -> Dec
ValD (Name -> Pat
VarP Name
name) (Exp -> Body
NormalB (Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE (Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp -> Maybe Exp) -> Exp -> Maybe Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
succn) (Name -> Exp
VarE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"-") (Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp -> Maybe Exp) -> Exp -> Maybe Exp
forall a b. (a -> b) -> a -> b
$ Lit -> Exp
LitE (Integer -> Lit
IntegerL Integer
1)))) []]
                                                    where str :: String
str   = [Int -> Char
chr (Int -> Char) -> Int -> Char
forall a b. (a -> b) -> a -> b
$ Int8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int8
depInt8 -> Int8 -> Int8
forall a. Num a => a -> a -> a
+Int8
1)]
                                                          name :: Name
name  = String -> Name
mkName String
str
                                                          succn :: Name
succn = String -> Name
mkName (String
"succ"String -> ShowS
forall a. [a] -> [a] -> [a]
++String
str)
                            | Name -> String
nameBase Name
name String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"negate"  ->
                                case Int8 -> Int8 -> CoreExpr -> Exp
x2hsx (Int8
depInt8 -> Int8 -> Int8
forall a. Num a => a -> a -> a
+Int8
1) Int8
fdep CoreExpr
expr of
                                  Exp
ex -> Pat -> Body -> [Dec] -> Match
Match (Name -> Pat
VarP Name
negn) ([(Guard, Exp)] -> Body
GuardedB [(Exp -> Guard
NormalG (Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE (Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp -> Maybe Exp) -> Exp -> Maybe Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
negn) (Name -> Exp
VarE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"<") (Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp -> Maybe Exp) -> Exp -> Maybe Exp
forall a b. (a -> b) -> a -> b
$ Lit -> Exp
LitE (Lit -> Exp) -> Lit -> Exp
forall a b. (a -> b) -> a -> b
$ Integer -> Lit
IntegerL Integer
0)),Exp
ex)]) [Pat -> Body -> [Dec] -> Dec
ValD (Name -> Pat
VarP Name
name) (Exp -> Body
NormalB ((Name -> Exp
VarE 'negate) Exp -> Exp -> Exp
`AppE` (Name -> Exp
VarE Name
negn))) []]
                                                    where str :: String
str   = [Int -> Char
chr (Int -> Char) -> Int -> Char
forall a b. (a -> b) -> a -> b
$ Int8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int8
depInt8 -> Int8 -> Int8
forall a. Num a => a -> a -> a
+Int8
1)]
                                                          name :: Name
name  = String -> Name
mkName String
str
                                                          negn :: Name
negn = String -> Name
mkName (String
"neg"String -> ShowS
forall a. [a] -> [a] -> [a]
++String
str)
                  LitE Lit
lit  -> Pat -> Body -> [Dec] -> Match
Match (Lit -> Pat
LitP Lit
lit) (Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ Int8 -> Int8 -> CoreExpr -> Exp
x2hsx Int8
dep Int8
fdep CoreExpr
expr) []
                  Exp
e         -> String -> Match
forall a. HasCallStack => String -> a
error (Exp -> String
forall a. Ppr a => a -> String
pprint Exp
e String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" : non-constructor where a constructor is expected.")
          Int8
n occursIn :: Int8 -> CoreExpr -> Bool
`occursIn` Lambda CoreExpr
e      = Int8 -> Int8
forall a. Enum a => a -> a
succ Int8
n Int8 -> CoreExpr -> Bool
`occursIn` CoreExpr
e
          Int8
n `occursIn` FunLambda CoreExpr
e   = Int8
n      Int8 -> CoreExpr -> Bool
`occursIn` CoreExpr
e
          --          n `occursIn` FixCase ts = any (\(_,a,ce) -> (n+a+2) `occursIn` ce) ts
          Int8
n `occursIn` X Int8
m           = Int8
nInt8 -> Int8 -> Bool
forall a. Eq a => a -> a -> Bool
==Int8
m
          Int8
n `occursIn` (CoreExpr
f :$ CoreExpr
e)   = (Int8
n Int8 -> CoreExpr -> Bool
`occursIn` CoreExpr
f) Bool -> Bool -> Bool
|| (Int8
n Int8 -> CoreExpr -> Bool
`occursIn` CoreExpr
e)
          Int8
n `occursIn` Case CoreExpr
x [(Var, Int8, CoreExpr)]
ts  = Int8
n Int8 -> CoreExpr -> Bool
`occursIn` CoreExpr
x   Bool -> Bool -> Bool
|| ((Var, Int8, CoreExpr) -> Bool) -> [(Var, Int8, CoreExpr)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(Var
_,Int8
a,CoreExpr
ce) -> (Int8
nInt8 -> Int8 -> Int8
forall a. Num a => a -> a -> a
+Int8
a) Int8 -> CoreExpr -> Bool
`occursIn` CoreExpr
ce) [(Var, Int8, CoreExpr)]
ts
          Int8
n `occursIn` Fix CoreExpr
e Int8
m [Int8]
is = Int8
n Int8 -> [Int8] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int8]
is      Bool -> Bool -> Bool
|| (Int8
nInt8 -> Int8 -> Int8
forall a. Num a => a -> a -> a
+Int8
m) Int8 -> CoreExpr -> Bool
`occursIn` CoreExpr
e
          Int8
_ `occursIn` CoreExpr
_          = Bool
False
Int8
n funOccursIn :: Int8 -> CoreExpr -> Bool
`funOccursIn` Lambda CoreExpr
e      = Int8
n      Int8 -> CoreExpr -> Bool
`funOccursIn` CoreExpr
e
Int8
n `funOccursIn` FunLambda CoreExpr
e   = Int8 -> Int8
forall a. Enum a => a -> a
succ Int8
n Int8 -> CoreExpr -> Bool
`funOccursIn` CoreExpr
e
Int8
n `funOccursIn` FunX Int8
m        = Int8
nInt8 -> Int8 -> Bool
forall a. Eq a => a -> a -> Bool
==Int8
m
Int8
n `funOccursIn` (CoreExpr
f :$ CoreExpr
e)   = (Int8
n Int8 -> CoreExpr -> Bool
`funOccursIn` CoreExpr
f) Bool -> Bool -> Bool
|| (Int8
n Int8 -> CoreExpr -> Bool
`funOccursIn` CoreExpr
e)
Int8
n `funOccursIn` Case CoreExpr
x [(Var, Int8, CoreExpr)]
ts  = Int8
n Int8 -> CoreExpr -> Bool
`funOccursIn` CoreExpr
x Bool -> Bool -> Bool
|| ((Var, Int8, CoreExpr) -> Bool) -> [(Var, Int8, CoreExpr)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(Var
_,Int8
a,CoreExpr
ce) -> Int8
n Int8 -> CoreExpr -> Bool
`funOccursIn` CoreExpr
ce) [(Var, Int8, CoreExpr)]
ts
Int8
n `funOccursIn` Fix CoreExpr
e Int8
_ [Int8]
_  = Int8 -> Int8
forall a. Enum a => a -> a
succ Int8
n Int8 -> CoreExpr -> Bool
`funOccursIn` CoreExpr
e
Int8
_ `funOccursIn` CoreExpr
_          = Bool
False


lightBeta :: CoreExpr -> CoreExpr
lightBeta :: CoreExpr -> CoreExpr
lightBeta (Fix CoreExpr
e Int8
m [Int8]
is) | Int8
0 Int8 -> CoreExpr -> Bool
`funOccursIn` CoreExpr
e = CoreExpr -> Int8 -> [Int8] -> CoreExpr
Fix (CoreExpr -> CoreExpr
lightBeta CoreExpr
e) Int8
m [Int8]
is
                       | Bool
otherwise         = Int8 -> CoreExpr -> CoreExpr
liftFun Int8
0 (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ Int8 -> Int8 -> CoreExpr -> CoreExpr
nlift Int8
0 Int8
m (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ ((CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr)
-> CoreExpr -> [CoreExpr -> CoreExpr] -> CoreExpr
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
($) (CoreExpr -> CoreExpr
lightBeta CoreExpr
e) ([CoreExpr -> CoreExpr] -> CoreExpr)
-> [CoreExpr -> CoreExpr] -> CoreExpr
forall a b. (a -> b) -> a -> b
$ (Int8 -> Int8 -> CoreExpr -> CoreExpr)
-> [Int8] -> [Int8] -> [CoreExpr -> CoreExpr]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int8 -> Int8 -> CoreExpr -> CoreExpr
replace [Int8
mInt8 -> Int8 -> Int8
forall a. Num a => a -> a -> a
-Int8
1,Int8
mInt8 -> Int8 -> Int8
forall a. Num a => a -> a -> a
-Int8
2..Int8
0] ([Int8] -> [CoreExpr -> CoreExpr])
-> [Int8] -> [CoreExpr -> CoreExpr]
forall a b. (a -> b) -> a -> b
$ (Int8 -> Int8) -> [Int8] -> [Int8]
forall a b. (a -> b) -> [a] -> [b]
map (Int8
mInt8 -> Int8 -> Int8
forall a. Num a => a -> a -> a
+) [Int8]
is
lightBeta (Lambda CoreExpr
e)    = CoreExpr -> CoreExpr
Lambda (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> CoreExpr
lightBeta CoreExpr
e
lightBeta (FunLambda CoreExpr
e) = CoreExpr -> CoreExpr
FunLambda (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> CoreExpr
lightBeta CoreExpr
e
lightBeta (Lambda CoreExpr
e :$ X Int8
n) = CoreExpr -> CoreExpr
lightBeta (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ Int8 -> Int8 -> CoreExpr -> CoreExpr
nlift Int8
0 Int8
1 (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ Int8 -> Int8 -> CoreExpr -> CoreExpr
replace Int8
0 Int8
n CoreExpr
e

lightBeta (CoreExpr
f :$ CoreExpr
e)      = CoreExpr -> CoreExpr
lightBeta CoreExpr
f CoreExpr -> CoreExpr -> CoreExpr
:$ CoreExpr -> CoreExpr
lightBeta CoreExpr
e
lightBeta (Case CoreExpr
x [(Var, Int8, CoreExpr)]
ts)   = CoreExpr -> [(Var, Int8, CoreExpr)] -> CoreExpr
Case (CoreExpr -> CoreExpr
lightBeta CoreExpr
x) (((Var, Int8, CoreExpr) -> (Var, Int8, CoreExpr))
-> [(Var, Int8, CoreExpr)] -> [(Var, Int8, CoreExpr)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Var
c,Int8
a,CoreExpr
ce) -> (Var
c,Int8
a,CoreExpr -> CoreExpr
lightBeta CoreExpr
ce)) [(Var, Int8, CoreExpr)]
ts)
lightBeta CoreExpr
e             = CoreExpr
e

replace :: Int8 -> Int8 -> CoreExpr -> CoreExpr
replace Int8
o Int8
n e :: CoreExpr
e@(X Int8
i)       | Int8
iInt8 -> Int8 -> Bool
forall a. Eq a => a -> a -> Bool
==Int8
o = Int8 -> CoreExpr
X Int8
n
replace Int8
o Int8
n (Lambda CoreExpr
e)    = CoreExpr -> CoreExpr
Lambda (Int8 -> Int8 -> CoreExpr -> CoreExpr
replace (Int8 -> Int8
forall a. Enum a => a -> a
succ Int8
o) (Int8 -> Int8
forall a. Enum a => a -> a
succ Int8
n) CoreExpr
e)
replace Int8
o Int8
n (FunLambda CoreExpr
e) = CoreExpr -> CoreExpr
FunLambda (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ Int8 -> Int8 -> CoreExpr -> CoreExpr
replace Int8
o Int8
n CoreExpr
e
replace Int8
o Int8
n (CoreExpr
f :$ CoreExpr
e)      = Int8 -> Int8 -> CoreExpr -> CoreExpr
replace Int8
o Int8
n CoreExpr
f CoreExpr -> CoreExpr -> CoreExpr
:$ Int8 -> Int8 -> CoreExpr -> CoreExpr
replace Int8
o Int8
n CoreExpr
e
replace Int8
o Int8
n (Case CoreExpr
x [(Var, Int8, CoreExpr)]
ts)   = CoreExpr -> [(Var, Int8, CoreExpr)] -> CoreExpr
Case (Int8 -> Int8 -> CoreExpr -> CoreExpr
replace Int8
o Int8
n CoreExpr
x) (((Var, Int8, CoreExpr) -> (Var, Int8, CoreExpr))
-> [(Var, Int8, CoreExpr)] -> [(Var, Int8, CoreExpr)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Var
c,Int8
a,CoreExpr
ce) -> (Var
c,Int8
a,Int8 -> Int8 -> CoreExpr -> CoreExpr
replace (Int8
oInt8 -> Int8 -> Int8
forall a. Num a => a -> a -> a
+Int8
a) (Int8
nInt8 -> Int8 -> Int8
forall a. Num a => a -> a -> a
+Int8
a) CoreExpr
ce)) [(Var, Int8, CoreExpr)]
ts)
replace Int8
o Int8
n (Fix CoreExpr
e Int8
m [Int8]
is)  = CoreExpr -> Int8 -> [Int8] -> CoreExpr
Fix (Int8 -> Int8 -> CoreExpr -> CoreExpr
replace (Int8
oInt8 -> Int8 -> Int8
forall a. Num a => a -> a -> a
+Int8
m) (Int8
nInt8 -> Int8 -> Int8
forall a. Num a => a -> a -> a
+Int8
m) CoreExpr
e) Int8
m ((Int8 -> Int8) -> [Int8] -> [Int8]
forall a b. (a -> b) -> [a] -> [b]
map (\Int8
x -> if Int8
xInt8 -> Int8 -> Bool
forall a. Eq a => a -> a -> Bool
==Int8
o then Int8
n else Int8
x) [Int8]
is)
replace Int8
o Int8
n CoreExpr
e = CoreExpr
e

liftFun :: Int8 -> CoreExpr -> CoreExpr
liftFun Int8
th (FunX Int8
i) | Int8
thInt8 -> Int8 -> Bool
forall a. Ord a => a -> a -> Bool
<Int8
i = Int8 -> CoreExpr
FunX (Int8 -> Int8
forall a. Enum a => a -> a
pred Int8
i)
liftFun Int8
th (Lambda CoreExpr
e) = CoreExpr -> CoreExpr
Lambda (Int8 -> CoreExpr -> CoreExpr
liftFun Int8
th CoreExpr
e)
liftFun Int8
th (FunLambda CoreExpr
e) = CoreExpr -> CoreExpr
FunLambda (Int8 -> CoreExpr -> CoreExpr
liftFun (Int8 -> Int8
forall a. Enum a => a -> a
succ Int8
th) CoreExpr
e)
liftFun Int8
th (CoreExpr
f :$ CoreExpr
e) = Int8 -> CoreExpr -> CoreExpr
liftFun Int8
th CoreExpr
f CoreExpr -> CoreExpr -> CoreExpr
:$ Int8 -> CoreExpr -> CoreExpr
liftFun Int8
th CoreExpr
e
liftFun Int8
th (Case CoreExpr
x [(Var, Int8, CoreExpr)]
ts) = CoreExpr -> [(Var, Int8, CoreExpr)] -> CoreExpr
Case (Int8 -> CoreExpr -> CoreExpr
liftFun Int8
th CoreExpr
x) (((Var, Int8, CoreExpr) -> (Var, Int8, CoreExpr))
-> [(Var, Int8, CoreExpr)] -> [(Var, Int8, CoreExpr)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Var
c,Int8
a,CoreExpr
ce) -> (Var
c,Int8
a,Int8 -> CoreExpr -> CoreExpr
liftFun Int8
th CoreExpr
ce)) [(Var, Int8, CoreExpr)]
ts)
liftFun Int8
th (Fix CoreExpr
e Int8
m [Int8]
is) = CoreExpr -> Int8 -> [Int8] -> CoreExpr
Fix (Int8 -> CoreExpr -> CoreExpr
liftFun (Int8 -> Int8
forall a. Enum a => a -> a
succ Int8
th) CoreExpr
e) Int8
m [Int8]
is
liftFun Int8
_  CoreExpr
e = CoreExpr
e
nlift :: Int8 -> Int8 -> CoreExpr -> CoreExpr
nlift :: Int8 -> Int8 -> CoreExpr -> CoreExpr
nlift Int8
th Int8
n (X Int8
i) | Int8
thInt8 -> Int8 -> Bool
forall a. Ord a => a -> a -> Bool
<Int8
i = Int8 -> CoreExpr
X (Int8
iInt8 -> Int8 -> Int8
forall a. Num a => a -> a -> a
-Int8
n)
nlift Int8
th Int8
n (Lambda CoreExpr
e) = CoreExpr -> CoreExpr
Lambda (Int8 -> Int8 -> CoreExpr -> CoreExpr
nlift (Int8 -> Int8
forall a. Enum a => a -> a
succ Int8
th) Int8
n CoreExpr
e)
nlift Int8
th Int8
n (FunLambda CoreExpr
e) = CoreExpr -> CoreExpr
FunLambda (Int8 -> Int8 -> CoreExpr -> CoreExpr
nlift Int8
th Int8
n CoreExpr
e)
nlift Int8
th Int8
n (CoreExpr
f :$ CoreExpr
e) = Int8 -> Int8 -> CoreExpr -> CoreExpr
nlift Int8
th Int8
n CoreExpr
f CoreExpr -> CoreExpr -> CoreExpr
:$ Int8 -> Int8 -> CoreExpr -> CoreExpr
nlift Int8
th Int8
n CoreExpr
e
nlift Int8
th Int8
n (Case CoreExpr
x [(Var, Int8, CoreExpr)]
ts) = CoreExpr -> [(Var, Int8, CoreExpr)] -> CoreExpr
Case (Int8 -> Int8 -> CoreExpr -> CoreExpr
nlift Int8
th Int8
n CoreExpr
x) (((Var, Int8, CoreExpr) -> (Var, Int8, CoreExpr))
-> [(Var, Int8, CoreExpr)] -> [(Var, Int8, CoreExpr)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Var
c,Int8
a,CoreExpr
ce) -> (Var
c,Int8
a,Int8 -> Int8 -> CoreExpr -> CoreExpr
nlift (Int8
thInt8 -> Int8 -> Int8
forall a. Num a => a -> a -> a
+Int8
a) Int8
n CoreExpr
ce)) [(Var, Int8, CoreExpr)]
ts)
nlift Int8
th Int8
n (Fix CoreExpr
e Int8
m [Int8]
is) = CoreExpr -> Int8 -> [Int8] -> CoreExpr
Fix (Int8 -> Int8 -> CoreExpr -> CoreExpr
nlift (Int8
thInt8 -> Int8 -> Int8
forall a. Num a => a -> a -> a
+Int8
m) Int8
n CoreExpr
e) Int8
m ((Int8 -> Int8) -> [Int8] -> [Int8]
forall a b. (a -> b) -> [a] -> [b]
map (Int8 -> Int8 -> Int8 -> Int8
nliftInt Int8
th Int8
n) [Int8]
is)
nlift Int8
th Int8
n CoreExpr
e = CoreExpr
e
nliftInt :: Int8 -> Int8 -> Int8 -> Int8
nliftInt :: Int8 -> Int8 -> Int8 -> Int8
nliftInt Int8
th Int8
n Int8
i | Int8
th Int8 -> Int8 -> Bool
forall a. Ord a => a -> a -> Bool
< Int8
i    = Int8
iInt8 -> Int8 -> Int8
forall a. Num a => a -> a -> a
-Int8
n
                | Bool
otherwise = Int8
i


napply :: i -> (a -> a) -> a -> a
napply i
n a -> a
f a
x = (a -> a) -> a -> [a]
forall a. (a -> a) -> a -> [a]
iterate a -> a
f a
x [a] -> i -> a
forall i a. Integral i => [a] -> i -> a
`genericIndex` i
n



-- Another 'Primitive' moved from MagicHaskeller.lhs, which should be renamed in some way....
type Primitive = (HValue, Exp, Type)
newtype HValue = HV (forall a. a)

primitivesToTCL :: [Primitive] -> TyConLib
primitivesToTCL :: [Primitive] -> TyConLib
primitivesToTCL [Primitive]
ps = let ([HValue]
_,[Exp]
_,[Type]
ts) = [Primitive] -> ([HValue], [Exp], [Type])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 [Primitive]
ps in [Type] -> TyConLib
thTypesToTCL [Type]
ts
-- thTypesToTCL encloses defaultTyCons

primitivesToVL :: TyConLib -> [Primitive] -> VarLib
primitivesToVL :: TyConLib -> [Primitive] -> VarLib
primitivesToVL TyConLib
tcl [Primitive]
ps = [Dynamic] -> VarLib
dynamicsToVL ((Primitive -> Dynamic) -> [Primitive] -> [Dynamic]
forall a b. (a -> b) -> [a] -> [b]
map (TyConLib -> Primitive -> Dynamic
primitiveToDynamic TyConLib
tcl) [Primitive]
ps [Dynamic] -> [Dynamic] -> [Dynamic]
forall a. [a] -> [a] -> [a]
++ [Dynamic]
defaultPrimitives)

-- | 'dynamicsToVL' is useful for incremental learning.
dynamicsToVL :: [PD.Dynamic] -> VarLib
dynamicsToVL :: [Dynamic] -> VarLib
dynamicsToVL = [Dynamic] -> VarLib
forall i a. (Integral i, Ix i) => [a] -> Array i a
listToArray

prioritiesToVPL :: [Int] -> VarPriorityLib
prioritiesToVPL :: [Int] -> VarPriorityLib
prioritiesToVPL = [Int] -> VarPriorityLib
forall i a. (Integral i, Ix i) => [a] -> Array i a
listToArray

listToArray :: (Integral i, Ix i) => [a] -> Array i a
listToArray :: [a] -> Array i a
listToArray [a]
ds = (i, i) -> [a] -> Array i a
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (i
0, [a] -> i
forall i a. Num i => [a] -> i
genericLength [a]
ds i -> i -> i
forall a. Num a => a -> a -> a
- i
1) [a]
ds

primitiveToDynamic :: TyConLib -> Primitive -> PD.Dynamic
primitiveToDynamic :: TyConLib -> Primitive -> Dynamic
primitiveToDynamic TyConLib
tcl (HV forall a. a
x, Exp
e, Type
ty) = TyConLib -> Type -> Any -> Exp -> Dynamic
forall a. TyConLib -> Type -> a -> Exp -> Dynamic
PD.unsafeToDyn TyConLib
tcl (TyConLib -> Type -> Type
thTypeToType TyConLib
tcl Type
ty) Any
forall a. a
x Exp
e

-- | 'defaultVarLib' can be used as a VarLib for testing and debugging. Currently this is used only by the analytical synthesizer.
defaultVarLib :: VarLib
defaultVarLib :: VarLib
defaultVarLib = TyConLib -> [Primitive] -> VarLib
primitivesToVL TyConLib
forall a. HasCallStack => a
undefined []   --  = listArray (0, lenDefaultPrimitives-1) defaultPrimitives

lenDefaultPrimitives :: Integer
lenDefaultPrimitives = [Dynamic] -> Integer
forall i a. Num i => [a] -> i
genericLength [Dynamic]
defaultPrimitives

-- | @defaultPrimitives@ is the set of primitives that we want to make sure to appear in VarLib but may not appear in the primitive set with which to synthesize.
--   In other words, it is the set of primitives we want to make sure to assign IDs to.
defaultPrimitives :: [PD.Dynamic]
defaultPrimitives :: [Dynamic]
defaultPrimitives
    = [
       $(PD.dynamic [|defaultTCL|] [|()::()|]),
       $(PD.dynamic [|defaultTCL|] [|(,)     ::a->b->(a,b)|]),
       $(PD.dynamic [|defaultTCL|] [|(,,)    ::a->b->c->(a,b,c)|]),
       $(PD.dynamic [|defaultTCL|] [|(,,,)   ::a->b->c->d->(a,b,c,d)|]),
       $(PD.dynamic [|defaultTCL|] [|(,,,,)  ::a->b->c->d->e->(a,b,c,d,e)|]),
       $(PD.dynamic [|defaultTCL|] [|(,,,,,) ::a->b->c->d->e->f->(a,b,c,d,e,f)|]),
       $(PD.dynamic [|defaultTCL|] [|(,,,,,,)::a->b->c->d->e->f->g->(a,b,c,d,e,f,g)|]),

       $(PD.dynamic [|defaultTCL|] [|Left    :: a -> Either a b|]),
       $(PD.dynamic [|defaultTCL|] [|Right   :: b -> Either a b|]),
       $(PD.dynamic [|defaultTCL|] [|Nothing :: Maybe a|]),
       $(PD.dynamic [|defaultTCL|] [|Just    :: a -> Maybe a|]),
       $(PD.dynamic [|defaultTCL|] [|LT      :: Ordering|]),
       $(PD.dynamic [|defaultTCL|] [|EQ      :: Ordering|]),
       $(PD.dynamic [|defaultTCL|] [|GT      :: Ordering|]),

       $(PD.dynamic [|defaultTCL|] [|(+)::Int->Int->Int|]),
       $(PD.dynamic [|defaultTCL|] [|False::Bool|]),
       $(PD.dynamic [|defaultTCL|] [|True::Bool|]),
       $(PD.dynamic [|defaultTCL|] [|[]::[a]|]),
       $(PD.dynamic [|defaultTCL|] [|(:)::a->[a]->[a]|]),
       $(PD.dynamic [|defaultTCL|] [|0::Int|]),         -- What if, e.g., Integer instead of Int is used?
       $(PD.dynamic [|defaultTCL|] [|succ::Int->Int|]),
       $(PD.dynamic [|defaultTCL|] [|negate::Int->Int|])]

-- succ, viewed as a constructor, can be converted into n+k pattern while postprocessing, but what can I do for negate?
-- Maybe I could say @ case x of _ | x<0 -> ... where i = -x @, so I can avoid introducing a new variable.
-- ... but then, what if x is not actually a variable?
-- ... Uh, n+k pattern can not yet be handled by TH. (Try  @runQ [| case 3 of k+1 -> k |] >>= print@  in GHCi.)
-- The above are dealt with by CoreLang.exprToTHExp.

\end{code}