-- 
-- (c) Susumu Katayama
--
{-# LANGUAGE MagicHash, TemplateHaskell #-}
module MagicHaskeller.Execute(unsafeExecute, unDeBruijn, s, sprime, bprime, cprime, fix) where
import System.IO.Unsafe(unsafeInterleaveIO)
import MagicHaskeller.CoreLang
import GHC.Exts(unsafeCoerce#)
import Control.Concurrent(yield, ThreadId, throwTo)
import Control.Monad(mplus)
import MagicHaskeller.TyConLib
import Data.Array((!))

import MagicHaskeller.MyDynamic

import Language.Haskell.TH hiding (Type)

import Data.Int

unDeBruijn :: CoreExpr -> CoreExpr
unDeBruijn CoreExpr
e = Int8 -> CoreExpr -> CoreExpr
undeb Int8
0 CoreExpr
e

undeb :: Int8 -> CoreExpr -> CoreExpr
undeb Int8
dep (Lambda CoreExpr
e) = Int8 -> CoreExpr -> CoreExpr
lambda (Int8
depInt8 -> Int8 -> Int8
forall a. Num a => a -> a -> a
+Int8
1) (Int8 -> CoreExpr -> CoreExpr
undeb (Int8
depInt8 -> Int8 -> Int8
forall a. Num a => a -> a -> a
+Int8
1) CoreExpr
e)
undeb Int8
dep (X Int8
n)      = Int8 -> CoreExpr
X (Int8
depInt8 -> Int8 -> Int8
forall a. Num a => a -> a -> a
-Int8
n)
undeb Int8
dep (CoreExpr
Y :$ CoreExpr
e) = case Int8 -> CoreExpr -> CoreExpr
undeb Int8
dep CoreExpr
e of CoreExpr
K :$ CoreExpr
und -> CoreExpr
und       -- fix (\_ -> foo) = foo 
                                         CoreExpr
unde     -> CoreExpr
Y CoreExpr -> CoreExpr -> CoreExpr
:$ CoreExpr
unde
undeb Int8
dep (CoreExpr
e0 :$ CoreExpr
e1) = Int8 -> CoreExpr -> CoreExpr
undeb Int8
dep CoreExpr
e0 CoreExpr -> CoreExpr -> CoreExpr
:$ Int8 -> CoreExpr -> CoreExpr
undeb Int8
dep CoreExpr
e1
undeb Int8
dep (Fix CoreExpr
e Int8
n [Int8]
is)  = Int8 -> CoreExpr -> CoreExpr
undeb Int8
dep (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ (CoreExpr -> CoreExpr -> CoreExpr)
-> CoreExpr -> [CoreExpr] -> CoreExpr
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl CoreExpr -> CoreExpr -> CoreExpr
(:$) (CoreExpr
Y CoreExpr -> CoreExpr -> CoreExpr
:$ 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
e)) ((Int8 -> CoreExpr) -> [Int8] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map Int8 -> CoreExpr
X [Int8]
is)
undeb Int8
dep CoreExpr
e          = CoreExpr
e

-- well, B' is not so efficient.
lambda :: Int8 -> CoreExpr -> CoreExpr
lambda :: Int8 -> CoreExpr -> CoreExpr
lambda Int8
v CoreExpr
e | Int8
v Int8 -> CoreExpr -> Bool
`isFreeIn` CoreExpr
e = CoreExpr
K CoreExpr -> CoreExpr -> CoreExpr
:$ CoreExpr
e
lambda Int8
v (X Int8
n)           = CoreExpr
I
lambda Int8
v (CoreExpr
f :$ CoreExpr
x :$ CoreExpr
y)
        | Int8
v Int8 -> CoreExpr -> Bool
`isFreeIn` CoreExpr
f = if Int8
v Int8 -> CoreExpr -> Bool
`isFreeIn` CoreExpr
x
                           then CoreExpr
B' CoreExpr -> CoreExpr -> CoreExpr
:$ CoreExpr
f CoreExpr -> CoreExpr -> CoreExpr
:$ CoreExpr
x CoreExpr -> CoreExpr -> CoreExpr
:$ (Int8 -> CoreExpr -> CoreExpr
lambda Int8
v CoreExpr
y)
                           else if Int8
v Int8 -> CoreExpr -> Bool
`isFreeIn` CoreExpr
y
                                then CoreExpr
C' CoreExpr -> CoreExpr -> CoreExpr
:$ CoreExpr
f CoreExpr -> CoreExpr -> CoreExpr
:$ (Int8 -> CoreExpr -> CoreExpr
lambda Int8
v CoreExpr
x) CoreExpr -> CoreExpr -> CoreExpr
:$ CoreExpr
y
                                else CoreExpr
S' CoreExpr -> CoreExpr -> CoreExpr
:$ CoreExpr
f CoreExpr -> CoreExpr -> CoreExpr
:$ (Int8 -> CoreExpr -> CoreExpr
lambda Int8
v CoreExpr
x) CoreExpr -> CoreExpr -> CoreExpr
:$ (Int8 -> CoreExpr -> CoreExpr
lambda Int8
v CoreExpr
y)
lambda Int8
v (CoreExpr
x :$ CoreExpr
y)
        | Int8
v Int8 -> CoreExpr -> Bool
`isFreeIn` CoreExpr
x = CoreExpr
B CoreExpr -> CoreExpr -> CoreExpr
:$ CoreExpr
x          CoreExpr -> CoreExpr -> CoreExpr
:$ Int8 -> CoreExpr -> CoreExpr
lambda Int8
v CoreExpr
y
        | Int8
v Int8 -> CoreExpr -> Bool
`isFreeIn` CoreExpr
y = CoreExpr
C CoreExpr -> CoreExpr -> CoreExpr
:$ Int8 -> CoreExpr -> CoreExpr
lambda Int8
v CoreExpr
x CoreExpr -> CoreExpr -> CoreExpr
:$ CoreExpr
y
        | Bool
otherwise      = CoreExpr
S CoreExpr -> CoreExpr -> CoreExpr
:$ Int8 -> CoreExpr -> CoreExpr
lambda Int8
v CoreExpr
x CoreExpr -> CoreExpr -> CoreExpr
:$ Int8 -> CoreExpr -> CoreExpr
lambda Int8
v CoreExpr
y
Int8
v isFreeIn :: Int8 -> CoreExpr -> Bool
`isFreeIn` (CoreExpr
f :$ CoreExpr
x) = Int8
v Int8 -> CoreExpr -> Bool
`isFreeIn` CoreExpr
f Bool -> Bool -> Bool
&& Int8
v Int8 -> CoreExpr -> Bool
`isFreeIn` CoreExpr
x
Int8
v `isFreeIn` (X Int8
n)    = Int8
v Int8 -> Int8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Int8
n
Int8
v `isFreeIn` CoreExpr
_        = Bool
True

-- checks if there is a free variable. usually used after unDeBruijn is applied and before tiExpression is applied. 
-- と思ったのだが，tiExpressionが内部でunDeBruijnを呼んでる．
-- やっぱtiExpressionでfail使ってメッセージ運んだ方がよい？
freeVar :: CoreExpr -> Maybe String
freeVar :: CoreExpr -> Maybe String
freeVar (Lambda CoreExpr
e)        = CoreExpr -> Maybe String
freeVar CoreExpr
e
freeVar (CoreExpr
e0 :$ CoreExpr
e1)        = CoreExpr -> Maybe String
freeVar CoreExpr
e0 Maybe String -> Maybe String -> Maybe String
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` CoreExpr -> Maybe String
freeVar CoreExpr
e1
freeVar CoreExpr
_ = Maybe String
forall a. Maybe a
Nothing

-- Use haddock-2.2.2. Later (and much earlier) versions of haddock do not like quasi-quotes. See http://www.nabble.com/build-problems-on-Hackage-td21848164.html
unsafeExecute :: VarLib -> CoreExpr -> Dynamic
unsafeExecute :: VarLib -> CoreExpr -> Dynamic
unsafeExecute VarLib
vl CoreExpr
e = CoreExpr -> Dynamic
exe (CoreExpr -> CoreExpr
unDeBruijn CoreExpr
e) where
    exe :: CoreExpr -> Dynamic
exe (CoreExpr
e0 :$ CoreExpr
e1) = String -> Dynamic -> Dynamic -> Dynamic
dynAppErr String
"apply" (CoreExpr -> Dynamic
exe CoreExpr
e0) (CoreExpr -> Dynamic
exe CoreExpr
e1)
    exe (Primitive Var
n) = Dynamic -> Dynamic
fromPD (VarLib
vlVarLib -> Var -> Dynamic
forall i e. Ix i => Array i e -> i -> e
!Var
n)
    exe (PrimCon   Var
n) = Dynamic -> Dynamic
fromPD (VarLib
vlVarLib -> Var -> Dynamic
forall i e. Ix i => Array i e -> i -> e
!Var
n)
    exe (Context (Dict Dynamic
pd)) = Dynamic -> Dynamic
fromPD Dynamic
pd
    exe CoreExpr
S = $(dynamic [|defaultTCL|] [| s     :: (b->c->a) -> (b->c) -> b -> a |])
    exe CoreExpr
K = $(dynamic [|defaultTCL|] [| const :: a->b->a |])
    exe CoreExpr
I = $(dynamic [|defaultTCL|] [| id    :: a->a    |])
    exe CoreExpr
B = $(dynamic [|defaultTCL|] [| (.)   :: (c->a) ->    (b->c) -> b -> a |])
    exe CoreExpr
C = $(dynamic [|defaultTCL|] [| flip  :: (b->c->a) ->     c  -> b -> a |])
    exe CoreExpr
S' = $(dynamic [|defaultTCL|] [| sprime :: (a->b->c)->(d->a)->(d->b)->d->c |])
    exe CoreExpr
B' = $(dynamic [|defaultTCL|] [| bprime :: (a->b->c)->    a ->(d->b)->d->c |])
    exe CoreExpr
C' = $(dynamic [|defaultTCL|] [| cprime :: (a->b->c)->(d->a)->b->d->c |])
    exe CoreExpr
Y  = $(dynamic [|defaultTCL|] [| fix    :: (a->a)->a |])
    exe CoreExpr
foo = String -> Dynamic
forall a. HasCallStack => String -> a
error (CoreExpr -> String
forall a. Show a => a -> String
show CoreExpr
foo String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" : unknown combinator")
-- readType assumes the tcl is undefined, so it cannot be used when type constructors other than -> are used.
s :: (t -> t -> t) -> (t -> t) -> t -> t
s = \t -> t -> t
f t -> t
g t
x -> t -> t -> t
f t
x (t -> t
g t
x)
sprime :: (t -> t -> t) -> (t -> t) -> (t -> t) -> t -> t
sprime = \t -> t -> t
f t -> t
g t -> t
h t
x -> t -> t -> t
f (t -> t
g t
x) (t -> t
h t
x)
bprime :: (t -> t -> t) -> t -> (t -> t) -> t -> t
bprime = \t -> t -> t
f t
g t -> t
h t
x -> t -> t -> t
f  t
g    (t -> t
h t
x)
cprime :: (t -> t -> t) -> (t -> t) -> t -> t -> t
cprime = \t -> t -> t
f t -> t
g t
h t
x -> t -> t -> t
f (t -> t
g t
x)  t
h
fix :: (t -> t) -> t
fix t -> t
f = let x :: t
x = t -> t
f t
x in t
x