{-# LANGUAGE DeriveAnyClass             #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE PatternSynonyms            #-}
{-# LANGUAGE TupleSections              #-}

module Naturals where

import Control.Applicative
import Control.DeepSeq
import Control.Monad.Fix
import Control.Monad.Identity
import Control.Monad.State.Lazy
import Data.Binary
import Data.Functor
import Data.Int (Int64)
import Data.Map (Map)
import Data.Monoid
import Data.Set (Set)
import Debug.Trace
import GHC.Generics

import qualified Control.Monad.State.Lazy as State
import qualified Data.Map as Map
import qualified Data.Set as Set

import Telomare (FragExpr (..), FragIndex (..), IExpr (..), pattern App,
                 pattern ChurchNum, pattern ToChurch)

debug :: Bool
debug :: Bool
debug = Bool
True

debugTrace :: String -> a -> a
debugTrace :: forall a. [Char] -> a -> a
debugTrace [Char]
s a
x = if Bool
debug then forall a. [Char] -> a -> a
trace [Char]
s a
x else a
x

data NaturalType
  = ZeroTypeN
  | PairTypeN NaturalType NaturalType
  | ArrTypeN FragIndex
  | ChurchType
  | UnknownN
  deriving (NaturalType -> NaturalType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NaturalType -> NaturalType -> Bool
$c/= :: NaturalType -> NaturalType -> Bool
== :: NaturalType -> NaturalType -> Bool
$c== :: NaturalType -> NaturalType -> Bool
Eq, Eq NaturalType
NaturalType -> NaturalType -> Bool
NaturalType -> NaturalType -> Ordering
NaturalType -> NaturalType -> NaturalType
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 :: NaturalType -> NaturalType -> NaturalType
$cmin :: NaturalType -> NaturalType -> NaturalType
max :: NaturalType -> NaturalType -> NaturalType
$cmax :: NaturalType -> NaturalType -> NaturalType
>= :: NaturalType -> NaturalType -> Bool
$c>= :: NaturalType -> NaturalType -> Bool
> :: NaturalType -> NaturalType -> Bool
$c> :: NaturalType -> NaturalType -> Bool
<= :: NaturalType -> NaturalType -> Bool
$c<= :: NaturalType -> NaturalType -> Bool
< :: NaturalType -> NaturalType -> Bool
$c< :: NaturalType -> NaturalType -> Bool
compare :: NaturalType -> NaturalType -> Ordering
$ccompare :: NaturalType -> NaturalType -> Ordering
Ord, Int -> NaturalType -> ShowS
[NaturalType] -> ShowS
NaturalType -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [NaturalType] -> ShowS
$cshowList :: [NaturalType] -> ShowS
show :: NaturalType -> [Char]
$cshow :: NaturalType -> [Char]
showsPrec :: Int -> NaturalType -> ShowS
$cshowsPrec :: Int -> NaturalType -> ShowS
Show)

--newtype FragIndex = FragIndex { unFragIndex :: Int } deriving (Eq, Show, Ord, Enum, NFData, Generic)
newtype TypeIndex = TypeIndex { TypeIndex -> Int
unTypeIndex :: Int } deriving (TypeIndex -> TypeIndex -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TypeIndex -> TypeIndex -> Bool
$c/= :: TypeIndex -> TypeIndex -> Bool
== :: TypeIndex -> TypeIndex -> Bool
$c== :: TypeIndex -> TypeIndex -> Bool
Eq, Int -> TypeIndex -> ShowS
[TypeIndex] -> ShowS
TypeIndex -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [TypeIndex] -> ShowS
$cshowList :: [TypeIndex] -> ShowS
show :: TypeIndex -> [Char]
$cshow :: TypeIndex -> [Char]
showsPrec :: Int -> TypeIndex -> ShowS
$cshowsPrec :: Int -> TypeIndex -> ShowS
Show, Eq TypeIndex
TypeIndex -> TypeIndex -> Bool
TypeIndex -> TypeIndex -> Ordering
TypeIndex -> TypeIndex -> TypeIndex
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 :: TypeIndex -> TypeIndex -> TypeIndex
$cmin :: TypeIndex -> TypeIndex -> TypeIndex
max :: TypeIndex -> TypeIndex -> TypeIndex
$cmax :: TypeIndex -> TypeIndex -> TypeIndex
>= :: TypeIndex -> TypeIndex -> Bool
$c>= :: TypeIndex -> TypeIndex -> Bool
> :: TypeIndex -> TypeIndex -> Bool
$c> :: TypeIndex -> TypeIndex -> Bool
<= :: TypeIndex -> TypeIndex -> Bool
$c<= :: TypeIndex -> TypeIndex -> Bool
< :: TypeIndex -> TypeIndex -> Bool
$c< :: TypeIndex -> TypeIndex -> Bool
compare :: TypeIndex -> TypeIndex -> Ordering
$ccompare :: TypeIndex -> TypeIndex -> Ordering
Ord, Int -> TypeIndex
TypeIndex -> Int
TypeIndex -> [TypeIndex]
TypeIndex -> TypeIndex
TypeIndex -> TypeIndex -> [TypeIndex]
TypeIndex -> TypeIndex -> TypeIndex -> [TypeIndex]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: TypeIndex -> TypeIndex -> TypeIndex -> [TypeIndex]
$cenumFromThenTo :: TypeIndex -> TypeIndex -> TypeIndex -> [TypeIndex]
enumFromTo :: TypeIndex -> TypeIndex -> [TypeIndex]
$cenumFromTo :: TypeIndex -> TypeIndex -> [TypeIndex]
enumFromThen :: TypeIndex -> TypeIndex -> [TypeIndex]
$cenumFromThen :: TypeIndex -> TypeIndex -> [TypeIndex]
enumFrom :: TypeIndex -> [TypeIndex]
$cenumFrom :: TypeIndex -> [TypeIndex]
fromEnum :: TypeIndex -> Int
$cfromEnum :: TypeIndex -> Int
toEnum :: Int -> TypeIndex
$ctoEnum :: Int -> TypeIndex
pred :: TypeIndex -> TypeIndex
$cpred :: TypeIndex -> TypeIndex
succ :: TypeIndex -> TypeIndex
$csucc :: TypeIndex -> TypeIndex
Enum)

instance Binary FragIndex

data ExprFrag
  = FZero
  | FPair ExprFrag ExprFrag
  | FEnv
  | FSetEnv ExprFrag
  | FDefer FragIndex
  | FGate ExprFrag ExprFrag
  | FLeft ExprFrag
  | FRight ExprFrag
  | FTrace
  -- complex instructions
  | FApp ExprFrag ExprFrag
  | FNum Int64
  | FToNum
  deriving (ExprFrag -> ExprFrag -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ExprFrag -> ExprFrag -> Bool
$c/= :: ExprFrag -> ExprFrag -> Bool
== :: ExprFrag -> ExprFrag -> Bool
$c== :: ExprFrag -> ExprFrag -> Bool
Eq, Int -> ExprFrag -> ShowS
[ExprFrag] -> ShowS
ExprFrag -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ExprFrag] -> ShowS
$cshowList :: [ExprFrag] -> ShowS
show :: ExprFrag -> [Char]
$cshow :: ExprFrag -> [Char]
showsPrec :: Int -> ExprFrag -> ShowS
$cshowsPrec :: Int -> ExprFrag -> ShowS
Show, Eq ExprFrag
ExprFrag -> ExprFrag -> Bool
ExprFrag -> ExprFrag -> Ordering
ExprFrag -> ExprFrag -> ExprFrag
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 :: ExprFrag -> ExprFrag -> ExprFrag
$cmin :: ExprFrag -> ExprFrag -> ExprFrag
max :: ExprFrag -> ExprFrag -> ExprFrag
$cmax :: ExprFrag -> ExprFrag -> ExprFrag
>= :: ExprFrag -> ExprFrag -> Bool
$c>= :: ExprFrag -> ExprFrag -> Bool
> :: ExprFrag -> ExprFrag -> Bool
$c> :: ExprFrag -> ExprFrag -> Bool
<= :: ExprFrag -> ExprFrag -> Bool
$c<= :: ExprFrag -> ExprFrag -> Bool
< :: ExprFrag -> ExprFrag -> Bool
$c< :: ExprFrag -> ExprFrag -> Bool
compare :: ExprFrag -> ExprFrag -> Ordering
$ccompare :: ExprFrag -> ExprFrag -> Ordering
Ord)

traceSet :: t FragIndex -> (a -> a) -> a -> a
traceSet t FragIndex
inds a -> a
ft a
x = if Int -> FragIndex
FragIndex Int
8 forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t FragIndex
inds
                  then forall a. [Char] -> a -> a
debugTrace ([Char]
"env at apply index: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show (a -> a
ft a
x)) a
x
                  else a
x
-- traceSet _ x = x

data NExpr
  = NZero
  | NPair NExpr NExpr
  | NEnv
  | NSetEnv NExpr
  | NDefer FragIndex
  | NGate NExpr NExpr
  | NLeft NExpr
  | NRight NExpr
  | NTrace
  | NNum Int64
  | NAdd NExpr NExpr
  | NMult NExpr NExpr
  | NPow NExpr NExpr
  {-
  | NForLoop Int64 NExpr -- for runtime, function and number of times to apply it
-}
  | NApp NExpr NExpr
  | NOldDefer NExpr -- can probably delete
  | NToChurch NExpr NExpr
  | NTwiddle NExpr
  | NToNum
  deriving (NExpr -> NExpr -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NExpr -> NExpr -> Bool
$c/= :: NExpr -> NExpr -> Bool
== :: NExpr -> NExpr -> Bool
$c== :: NExpr -> NExpr -> Bool
Eq, Int -> NExpr -> ShowS
[NExpr] -> ShowS
NExpr -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [NExpr] -> ShowS
$cshowList :: [NExpr] -> ShowS
show :: NExpr -> [Char]
$cshow :: NExpr -> [Char]
showsPrec :: Int -> NExpr -> ShowS
$cshowsPrec :: Int -> NExpr -> ShowS
Show, Eq NExpr
NExpr -> NExpr -> Bool
NExpr -> NExpr -> Ordering
NExpr -> NExpr -> NExpr
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 :: NExpr -> NExpr -> NExpr
$cmin :: NExpr -> NExpr -> NExpr
max :: NExpr -> NExpr -> NExpr
$cmax :: NExpr -> NExpr -> NExpr
>= :: NExpr -> NExpr -> Bool
$c>= :: NExpr -> NExpr -> Bool
> :: NExpr -> NExpr -> Bool
$c> :: NExpr -> NExpr -> Bool
<= :: NExpr -> NExpr -> Bool
$c<= :: NExpr -> NExpr -> Bool
< :: NExpr -> NExpr -> Bool
$c< :: NExpr -> NExpr -> Bool
compare :: NExpr -> NExpr -> Ordering
$ccompare :: NExpr -> NExpr -> Ordering
Ord, forall x. Rep NExpr x -> NExpr
forall x. NExpr -> Rep NExpr x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep NExpr x -> NExpr
$cfrom :: forall x. NExpr -> Rep NExpr x
Generic, NExpr -> ()
forall a. (a -> ()) -> NFData a
rnf :: NExpr -> ()
$crnf :: NExpr -> ()
NFData)

instance Binary NExpr

pattern NLamNum :: Int64 -> NExpr -> NExpr
pattern $mNLamNum :: forall {r}. NExpr -> (Int64 -> NExpr -> r) -> ((# #) -> r) -> r
NLamNum x e <- NPair (NPair (NNum x) NEnv) e

pattern NPartialNum :: Int64 -> NExpr -> NExpr
pattern $mNPartialNum :: forall {r}. NExpr -> (Int64 -> NExpr -> r) -> ((# #) -> r) -> r
NPartialNum i f <- (NPair (NNum i) f)

nlam :: NExpr -> NExpr
nlam :: NExpr -> NExpr
nlam NExpr
x = NExpr -> NExpr -> NExpr
NPair (NExpr -> NExpr
NOldDefer NExpr
x) NExpr
NEnv

type NResult = NExpr

newtype NExprs = NExprs (Map FragIndex NResult) deriving NExprs -> NExprs -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NExprs -> NExprs -> Bool
$c/= :: NExprs -> NExprs -> Bool
== :: NExprs -> NExprs -> Bool
$c== :: NExprs -> NExprs -> Bool
Eq

instance Show NExprs where
  show :: NExprs -> [Char]
show (NExprs Map FragIndex NExpr
m) =
    let showInner :: NExpr -> [Char]
showInner NExpr
frag = case NExpr
frag of
          NExpr
NZero -> [Char]
"NZero"
          (NPair NExpr
a NExpr
b) -> forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Char]
"( ", NExpr -> [Char]
showInner NExpr
a, [Char]
", ", NExpr -> [Char]
showInner NExpr
b, [Char]
" )"]
          NExpr
NEnv -> [Char]
"NEnv"
          (NSetEnv NExpr
x) -> forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Char]
"NSetEnv (", NExpr -> [Char]
showInner NExpr
x, [Char]
")"]
          (NDefer FragIndex
ind) -> case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FragIndex
ind Map FragIndex NExpr
m of
            Just NExpr
x  -> forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Char]
"NDefer (", NExpr -> [Char]
showInner NExpr
x, [Char]
")"]
            Maybe NExpr
Nothing -> [Char]
"ERROR undefined index in showing NExprs: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show FragIndex
ind
          NGate NExpr
l NExpr
r -> [Char]
"NGate (" forall a. Semigroup a => a -> a -> a
<> NExpr -> [Char]
showInner NExpr
l forall a. Semigroup a => a -> a -> a
<> [Char]
" " forall a. Semigroup a => a -> a -> a
<> NExpr -> [Char]
showInner NExpr
r forall a. Semigroup a => a -> a -> a
<> [Char]
" )"
          (NLeft NExpr
x) -> forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Char]
"NLeft (", NExpr -> [Char]
showInner NExpr
x, [Char]
")"]
          (NRight NExpr
x) -> forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Char]
"NRight (", NExpr -> [Char]
showInner NExpr
x, [Char]
")"]
          NExpr
NTrace -> [Char]
"NTrace"
          (NAdd NExpr
a NExpr
b) -> forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Char]
"NAdd (", NExpr -> [Char]
showInner NExpr
a, [Char]
" ", NExpr -> [Char]
showInner NExpr
b, [Char]
" )"]
          (NMult NExpr
a NExpr
b) -> forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Char]
"NMult (", NExpr -> [Char]
showInner NExpr
a, [Char]
" ", NExpr -> [Char]
showInner NExpr
b, [Char]
" )"]
          (NPow NExpr
a NExpr
b) -> forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Char]
"NPow (", NExpr -> [Char]
showInner NExpr
a, [Char]
" ", NExpr -> [Char]
showInner NExpr
b, [Char]
" )"]
          (NOldDefer NExpr
x) -> [Char]
"NOldDefer (" forall a. Semigroup a => a -> a -> a
<> NExpr -> [Char]
showInner NExpr
x forall a. Semigroup a => a -> a -> a
<> [Char]
")"
          NExpr
x -> forall a. Show a => a -> [Char]
show NExpr
x
    in case forall k a. Map k a -> Maybe (a, Map k a)
Map.minView Map FragIndex NExpr
m of
      Just (NExpr
x, Map FragIndex NExpr
_) -> NExpr -> [Char]
showInner NExpr
x
      Maybe (NExpr, Map FragIndex NExpr)
_           -> [Char]
"ERROR no root to NExprs tree"

type FragState = State (FragIndex, Map FragIndex ExprFrag)

toFrag :: IExpr -> FragState ExprFrag
-- complex instructions
toFrag :: IExpr -> FragState ExprFrag
toFrag IExpr
ToChurch = forall (f :: * -> *) a. Applicative f => a -> f a
pure ExprFrag
FToNum
toFrag (ChurchNum Int
x) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> ExprFrag
FNum forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x
toFrag (App IExpr
f IExpr
x) = ExprFrag -> ExprFrag -> ExprFrag
FApp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IExpr -> FragState ExprFrag
toFrag IExpr
f forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IExpr -> FragState ExprFrag
toFrag IExpr
x
-- simple instructions
toFrag IExpr
Zero = forall (f :: * -> *) a. Applicative f => a -> f a
pure ExprFrag
FZero
toFrag (Pair IExpr
a IExpr
b) = ExprFrag -> ExprFrag -> ExprFrag
FPair forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IExpr -> FragState ExprFrag
toFrag IExpr
a forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IExpr -> FragState ExprFrag
toFrag IExpr
b
toFrag IExpr
Env = forall (f :: * -> *) a. Applicative f => a -> f a
pure ExprFrag
FEnv
toFrag (SetEnv IExpr
x) = ExprFrag -> ExprFrag
FSetEnv forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IExpr -> FragState ExprFrag
toFrag IExpr
x
toFrag (Defer IExpr
x) = do
  ExprFrag
nx <- IExpr -> FragState ExprFrag
toFrag IExpr
x
  (ei :: FragIndex
ei@(FragIndex Int
i), Map FragIndex ExprFrag
fragMap) <- forall s (m :: * -> *). MonadState s m => m s
State.get
  let td :: a -> a
td = forall a. a -> a
id -- trace ("adding defer " ++ show i ++ " - " ++ show nx)
  forall s (m :: * -> *). MonadState s m => s -> m ()
State.put (Int -> FragIndex
FragIndex (Int
i forall a. Num a => a -> a -> a
+ Int
1), forall a. a -> a
td forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert FragIndex
ei ExprFrag
nx Map FragIndex ExprFrag
fragMap)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ FragIndex -> ExprFrag
FDefer FragIndex
ei
toFrag (Gate IExpr
l IExpr
r) = ExprFrag -> ExprFrag -> ExprFrag
FGate forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IExpr -> FragState ExprFrag
toFrag IExpr
l forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IExpr -> FragState ExprFrag
toFrag IExpr
r
toFrag (PLeft IExpr
x) = ExprFrag -> ExprFrag
FLeft forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IExpr -> FragState ExprFrag
toFrag IExpr
x
toFrag (PRight IExpr
x) = ExprFrag -> ExprFrag
FRight forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IExpr -> FragState ExprFrag
toFrag IExpr
x
toFrag IExpr
Trace = forall (f :: * -> *) a. Applicative f => a -> f a
pure ExprFrag
FTrace

fromFrag :: Map FragIndex ExprFrag -> ExprFrag -> IExpr
fromFrag :: Map FragIndex ExprFrag -> ExprFrag -> IExpr
fromFrag Map FragIndex ExprFrag
fragMap ExprFrag
frag = let recur :: ExprFrag -> IExpr
recur = Map FragIndex ExprFrag -> ExprFrag -> IExpr
fromFrag Map FragIndex ExprFrag
fragMap in case ExprFrag
frag of
  ExprFrag
FZero -> IExpr
Zero
  (FPair ExprFrag
a ExprFrag
b) -> IExpr -> IExpr -> IExpr
Pair (ExprFrag -> IExpr
recur ExprFrag
a) (ExprFrag -> IExpr
recur ExprFrag
b)
  ExprFrag
FEnv -> IExpr
Env
  (FSetEnv ExprFrag
x) -> IExpr -> IExpr
SetEnv forall a b. (a -> b) -> a -> b
$ ExprFrag -> IExpr
recur ExprFrag
x
  (FDefer FragIndex
fi) -> case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FragIndex
fi Map FragIndex ExprFrag
fragMap of
    Maybe ExprFrag
Nothing      -> forall a. HasCallStack => [Char] -> a
error ([Char]
"fromFrag bad index " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show FragIndex
fi)
    Just ExprFrag
subFrag -> IExpr -> IExpr
Defer forall a b. (a -> b) -> a -> b
$ ExprFrag -> IExpr
recur ExprFrag
subFrag
  FGate ExprFrag
l ExprFrag
r -> IExpr -> IExpr -> IExpr
Gate (ExprFrag -> IExpr
recur ExprFrag
l) (ExprFrag -> IExpr
recur ExprFrag
r)
  (FLeft ExprFrag
x) -> IExpr -> IExpr
PLeft forall a b. (a -> b) -> a -> b
$ ExprFrag -> IExpr
recur ExprFrag
x
  (FRight ExprFrag
x) -> IExpr -> IExpr
PRight forall a b. (a -> b) -> a -> b
$ ExprFrag -> IExpr
recur ExprFrag
x
  ExprFrag
FTrace -> IExpr
Trace
  ExprFrag
z -> forall a. HasCallStack => [Char] -> a
error ([Char]
"fromFrag TODO convert " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show ExprFrag
z)

matchChurchPlus :: Map FragIndex ExprFrag -> ExprFrag -> Maybe (ExprFrag, ExprFrag)
matchChurchPlus :: Map FragIndex ExprFrag -> ExprFrag -> Maybe (ExprFrag, ExprFrag)
matchChurchPlus Map FragIndex ExprFrag
fragMap ExprFrag
frag =
  let lam :: ExprFrag -> Maybe ExprFrag
lam (FPair (FDefer FragIndex
ind) ExprFrag
FEnv) = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FragIndex
ind Map FragIndex ExprFrag
fragMap
      lam ExprFrag
_                         = forall a. Maybe a
Nothing
      def :: ExprFrag -> Maybe ExprFrag
def (FDefer FragIndex
ind) = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FragIndex
ind Map FragIndex ExprFrag
fragMap
      def ExprFrag
_            = forall a. Maybe a
Nothing
      firstArg :: ExprFrag -> Maybe ()
firstArg (FLeft ExprFrag
FEnv) = forall a. a -> Maybe a
Just ()
      firstArg ExprFrag
_            = forall a. Maybe a
Nothing
      secondArg :: ExprFrag -> Maybe ()
secondArg (FLeft (FRight ExprFrag
FEnv)) = forall a. a -> Maybe a
Just ()
      secondArg ExprFrag
_                     = forall a. Maybe a
Nothing
      app :: ExprFrag -> Maybe (ExprFrag, ExprFrag)
app = ExprFrag -> Maybe (ExprFrag, ExprFrag)
matchApp
  in ExprFrag -> Maybe ExprFrag
lam ExprFrag
frag forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ExprFrag -> Maybe ExprFrag
lam forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ExprFrag -> Maybe (ExprFrag, ExprFrag)
app forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\(ExprFrag
a, ExprFrag
b) -> (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ExprFrag -> Maybe (ExprFrag, ExprFrag)
app ExprFrag
a forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\(ExprFrag
m, ExprFrag
sa) -> ExprFrag -> Maybe ()
secondArg ExprFrag
sa forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure ExprFrag
m))
                                              forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (ExprFrag -> Maybe (ExprFrag, ExprFrag)
app ExprFrag
b forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\(ExprFrag
c, ExprFrag
fa) -> ExprFrag -> Maybe ()
firstArg ExprFrag
fa forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ExprFrag -> Maybe (ExprFrag, ExprFrag)
app ExprFrag
c
                                                               forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\(ExprFrag
n, ExprFrag
sa) -> ExprFrag -> Maybe ()
secondArg ExprFrag
sa forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure ExprFrag
n)))
                                  )

matchChurchMult :: Map FragIndex ExprFrag -> ExprFrag -> Maybe (ExprFrag, ExprFrag)
matchChurchMult :: Map FragIndex ExprFrag -> ExprFrag -> Maybe (ExprFrag, ExprFrag)
matchChurchMult Map FragIndex ExprFrag
fragMap ExprFrag
frag =
  let lam :: ExprFrag -> Maybe ExprFrag
lam (FPair (FDefer FragIndex
ind) ExprFrag
FEnv) = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FragIndex
ind Map FragIndex ExprFrag
fragMap
      lam ExprFrag
_                         = forall a. Maybe a
Nothing
      def :: ExprFrag -> Maybe ExprFrag
def (FDefer FragIndex
ind) = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FragIndex
ind Map FragIndex ExprFrag
fragMap
      def ExprFrag
_            = forall a. Maybe a
Nothing
      firstArg :: ExprFrag -> Maybe ()
firstArg (FLeft ExprFrag
FEnv) = forall a. a -> Maybe a
Just ()
      firstArg ExprFrag
_            = forall a. Maybe a
Nothing
  in ExprFrag -> Maybe ExprFrag
lam ExprFrag
frag forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ExprFrag -> Maybe (ExprFrag, ExprFrag)
matchApp forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\(ExprFrag
m, ExprFrag
a) -> (ExprFrag
m, ) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ExprFrag -> Maybe (ExprFrag, ExprFrag)
matchApp ExprFrag
a forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\(ExprFrag
n, ExprFrag
fa) -> ExprFrag -> Maybe ()
firstArg ExprFrag
fa forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure ExprFrag
n)))

matchApp :: ExprFrag -> Maybe (ExprFrag, ExprFrag)
matchApp :: ExprFrag -> Maybe (ExprFrag, ExprFrag)
matchApp (FApp ExprFrag
c ExprFrag
i) = forall a. a -> Maybe a
Just (ExprFrag
c, ExprFrag
i)
matchApp ExprFrag
_          = forall a. Maybe a
Nothing

fragmentExpr :: IExpr -> Map FragIndex ExprFrag
fragmentExpr :: IExpr -> Map FragIndex ExprFrag
fragmentExpr IExpr
iexpr = let (ExprFrag
expr, (FragIndex
li, Map FragIndex ExprFrag
m)) = forall s a. State s a -> s -> (a, s)
State.runState (IExpr -> FragState ExprFrag
toFrag IExpr
iexpr) (Int -> FragIndex
FragIndex Int
1, forall k a. Map k a
Map.empty)
                         fragMap :: Map FragIndex ExprFrag
fragMap = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Int -> FragIndex
FragIndex Int
0) ExprFrag
expr Map FragIndex ExprFrag
m
                         -- tt x = trace (show x) x
                     in Map FragIndex ExprFrag
fragMap

fragToNExpr :: Map FragIndex ExprFrag -> ExprFrag -> NExpr
fragToNExpr :: Map FragIndex ExprFrag -> ExprFrag -> NExpr
fragToNExpr Map FragIndex ExprFrag
fragMap ExprFrag
frag =
        let recur :: ExprFrag -> NExpr
recur = Map FragIndex ExprFrag -> ExprFrag -> NExpr
fragToNExpr Map FragIndex ExprFrag
fragMap
        in case ExprFrag
frag of
            ExprFrag
FZero        -> NExpr
NZero
            ExprFrag
FEnv         -> NExpr
NEnv
            (FPair ExprFrag
a ExprFrag
b)  -> NExpr -> NExpr -> NExpr
NPair (ExprFrag -> NExpr
recur ExprFrag
a) (ExprFrag -> NExpr
recur ExprFrag
b)
            (FSetEnv ExprFrag
x)  -> NExpr -> NExpr
NSetEnv forall a b. (a -> b) -> a -> b
$ ExprFrag -> NExpr
recur ExprFrag
x
            FGate ExprFrag
l ExprFrag
r    -> NExpr -> NExpr -> NExpr
NGate (ExprFrag -> NExpr
recur ExprFrag
l) (ExprFrag -> NExpr
recur ExprFrag
r)
            (FLeft ExprFrag
x)    -> NExpr -> NExpr
NLeft forall a b. (a -> b) -> a -> b
$ ExprFrag -> NExpr
recur ExprFrag
x
            (FRight ExprFrag
x)   -> NExpr -> NExpr
NRight forall a b. (a -> b) -> a -> b
$ ExprFrag -> NExpr
recur ExprFrag
x
            ExprFrag
FTrace       -> NExpr
NTrace
            (FDefer FragIndex
ind) -> FragIndex -> NExpr
NDefer FragIndex
ind
            (FNum Int64
x)     -> NExpr -> NExpr -> NExpr
NPair (NExpr -> NExpr
NOldDefer (NExpr -> NExpr -> NExpr
NPair (Int64 -> NExpr
NNum Int64
x) NExpr
NEnv)) NExpr
NEnv
            ExprFrag
FToNum       -> NExpr
NToNum
            (FApp ExprFrag
c ExprFrag
i)   -> NExpr -> NExpr -> NExpr
NApp (ExprFrag -> NExpr
recur ExprFrag
c) (ExprFrag -> NExpr
recur ExprFrag
i)

fragsToNExpr :: Map FragIndex ExprFrag -> Map FragIndex NResult
fragsToNExpr :: Map FragIndex ExprFrag -> Map FragIndex NExpr
fragsToNExpr Map FragIndex ExprFrag
fragMap = forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (Map FragIndex ExprFrag -> ExprFrag -> NExpr
fragToNExpr Map FragIndex ExprFrag
fragMap) Map FragIndex ExprFrag
fragMap

debugShow :: p -> p
debugShow p
x = p
x -- trace ("toNExpr\n" ++ show x) x