{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TupleSections #-}

module Logic.NextBind where

import Control.Monad
import Effect

data NextBind t x where
  DoNothing :: x -> NextBind t x
  Fail :: NextBind t ()
  Now :: t x -> NextBind t x
  Branch :: NextBind t x -> NextBind t x -> NextBind t x
  Next :: NextBind t y -> (y -> NextBind t x) -> NextBind t x

andLater :: t a -> (a -> t b) -> NextBind t b
andLater :: forall (t :: * -> *) a b. t a -> (a -> t b) -> NextBind t b
andLater t a
x a -> t b
y = NextBind t a -> (a -> NextBind t b) -> NextBind t b
forall (t :: * -> *) y x.
NextBind t y -> (y -> NextBind t x) -> NextBind t x
Next (t a -> NextBind t a
forall (t :: * -> *) x. t x -> NextBind t x
Now t a
x) (t b -> NextBind t b
forall (t :: * -> *) x. t x -> NextBind t x
Now (t b -> NextBind t b) -> (a -> t b) -> a -> NextBind t b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> t b
y)

somewhere :: t a -> NextBind t a
somewhere :: forall (t :: * -> *) x. t x -> NextBind t x
somewhere t a
x = NextBind t a -> NextBind t a -> NextBind t a
forall (t :: * -> *) x.
NextBind t x -> NextBind t x -> NextBind t x
Branch (t a -> NextBind t a
forall (t :: * -> *) x. t x -> NextBind t x
Now t a
x) (NextBind t () -> (() -> NextBind t a) -> NextBind t a
forall (t :: * -> *) y x.
NextBind t y -> (y -> NextBind t x) -> NextBind t x
Next (() -> NextBind t ()
forall x (t :: * -> *). x -> NextBind t x
DoNothing ()) (NextBind t a -> () -> NextBind t a
forall a b. a -> b -> a
const (NextBind t a -> () -> NextBind t a)
-> NextBind t a -> () -> NextBind t a
forall a b. (a -> b) -> a -> b
$ t a -> NextBind t a
forall (t :: * -> *) x. t x -> NextBind t x
somewhere t a
x))

everywhere :: t a -> NextBind t a
everywhere :: forall (t :: * -> *) x. t x -> NextBind t x
everywhere t a
x = NextBind t a -> (a -> NextBind t a) -> NextBind t a
forall (t :: * -> *) y x.
NextBind t y -> (y -> NextBind t x) -> NextBind t x
Next (t a -> NextBind t a
forall (t :: * -> *) x. t x -> NextBind t x
Now t a
x) (NextBind t a -> a -> NextBind t a
forall a b. a -> b -> a
const (NextBind t a -> a -> NextBind t a)
-> NextBind t a -> a -> NextBind t a
forall a b. (a -> b) -> a -> b
$ t a -> NextBind t a
forall (t :: * -> *) x. t x -> NextBind t x
everywhere t a
x)

finished :: NextBind t x -> Bool
finished :: forall (t :: * -> *) x. NextBind t x -> Bool
finished DoNothing {} = Bool
True
finished (Branch NextBind t x
l NextBind t x
r) = NextBind t x -> Bool
forall (t :: * -> *) x. NextBind t x -> Bool
finished NextBind t x
l Bool -> Bool -> Bool
|| NextBind t x -> Bool
forall (t :: * -> *) x. NextBind t x -> Bool
finished NextBind t x
r
finished NextBind t x
_ = Bool
False

immediate :: NextBind t x -> [x]
immediate :: forall (t :: * -> *) x. NextBind t x -> [x]
immediate (DoNothing x
x) = [x
x]
immediate (Branch NextBind t x
l NextBind t x
r) = NextBind t x -> [x]
forall (t :: * -> *) x. NextBind t x -> [x]
immediate NextBind t x
l [x] -> [x] -> [x]
forall a. [a] -> [a] -> [a]
++ NextBind t x -> [x]
forall (t :: * -> *) x. NextBind t x -> [x]
immediate NextBind t x
r
immediate NextBind t x
_ = []

data Interpretation t m ops a where
  Direct :: (forall x. t x -> m (Maybe (a, x))) -> Interpretation t m ops a
  Nested ::
    AST ops b ->
    (forall x. NextBind t x -> NextBind t x) ->
    (forall x. m (b, NextBind t x) -> m (a, NextBind t x)) ->
    Interpretation t m ops a

class InterpretNextBind t m op where
  interpretNextBind ::
    op (AST ops) a ->
    Interpretation t m ops a

instance (MonadPlus m, InterpretEffect m op, InterpretNextBind t m op) => InterpretEffectStateful (NextBind t) m op where
  interpretEffectStateful :: forall (ops :: [Effect]) x a.
(forall b y. NextBind t y -> AST ops b -> m (b, NextBind t y))
-> NextBind t x -> op (AST ops) a -> m (a, NextBind t x)
interpretEffectStateful forall b y. NextBind t y -> AST ops b -> m (b, NextBind t y)
evalActs NextBind t x
nextBind op (AST ops) a
op =
    case op (AST ops) a -> Interpretation t m ops a
forall (ops :: [Effect]) a.
op (AST ops) a -> Interpretation t m ops a
forall (t :: * -> *) (m :: * -> *) (op :: Effect) (ops :: [Effect])
       a.
InterpretNextBind t m op =>
op (AST ops) a -> Interpretation t m ops a
interpretNextBind op (AST ops) a
op of
      Nested AST ops b
acts forall x. NextBind t x -> NextBind t x
changeMod forall x. m (b, NextBind t x) -> m (a, NextBind t x)
wrap -> m (b, NextBind t x) -> m (a, NextBind t x)
forall x. m (b, NextBind t x) -> m (a, NextBind t x)
wrap (m (b, NextBind t x) -> m (a, NextBind t x))
-> m (b, NextBind t x) -> m (a, NextBind t x)
forall a b. (a -> b) -> a -> b
$ NextBind t x -> AST ops b -> m (b, NextBind t x)
forall b y. NextBind t y -> AST ops b -> m (b, NextBind t y)
evalActs (NextBind t x -> NextBind t x
forall x. NextBind t x -> NextBind t x
changeMod NextBind t x
nextBind) AST ops b
acts
      Direct forall x. t x -> m (Maybe (a, x))
direct -> case NextBind t x
nextBind of
        DoNothing x
x ->
          (,x -> NextBind t x
forall x (t :: * -> *). x -> NextBind t x
DoNothing x
x) (a -> (a, NextBind t x)) -> m a -> m (a, NextBind t x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall b. AST ops b -> m b) -> op (AST ops) a -> m a
forall (ops :: [Effect]) a.
(forall b. AST ops b -> m b) -> op (AST ops) a -> m a
forall (m :: * -> *) (op :: Effect) (ops :: [Effect]) a.
InterpretEffect m op =>
(forall b. AST ops b -> m b) -> op (AST ops) a -> m a
interpretEffect (((b, NextBind t x) -> b) -> m (b, NextBind t x) -> m b
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (b, NextBind t x) -> b
forall a b. (a, b) -> a
fst (m (b, NextBind t x) -> m b)
-> (AST ops b -> m (b, NextBind t x)) -> AST ops b -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NextBind t x -> AST ops b -> m (b, NextBind t x)
forall b y. NextBind t y -> AST ops b -> m (b, NextBind t y)
evalActs (x -> NextBind t x
forall x (t :: * -> *). x -> NextBind t x
DoNothing x
x)) op (AST ops) a
op
        NextBind t x
Fail -> m (a, NextBind t x)
forall a. m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
        Now t x
t -> do
          Maybe (a, x)
mAx <- t x -> m (Maybe (a, x))
forall x. t x -> m (Maybe (a, x))
direct t x
t
          case Maybe (a, x)
mAx of
            Just (a
a, x
x) -> (a, NextBind t x) -> m (a, NextBind t x)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, x -> NextBind t x
forall x (t :: * -> *). x -> NextBind t x
DoNothing x
x)
            Maybe (a, x)
Nothing -> m (a, NextBind t x)
forall a. m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
        Next NextBind t y
x y -> NextBind t x
y -> do
          (a
a, NextBind t y
x') <- (forall b y. NextBind t y -> AST ops b -> m (b, NextBind t y))
-> NextBind t y -> op (AST ops) a -> m (a, NextBind t y)
forall (ops :: [Effect]) x a.
(forall b y. NextBind t y -> AST ops b -> m (b, NextBind t y))
-> NextBind t x -> op (AST ops) a -> m (a, NextBind t x)
forall (t :: * -> *) (m :: * -> *) (op :: Effect) (ops :: [Effect])
       x a.
InterpretEffectStateful t m op =>
(forall b y. t y -> AST ops b -> m (b, t y))
-> t x -> op (AST ops) a -> m (a, t x)
interpretEffectStateful NextBind t y -> AST ops b -> m (b, NextBind t y)
forall b y. NextBind t y -> AST ops b -> m (b, NextBind t y)
evalActs NextBind t y
x op (AST ops) a
op
          if NextBind t y -> Bool
forall (t :: * -> *) x. NextBind t x -> Bool
finished NextBind t y
x'
            then [m (a, NextBind t x)] -> m (a, NextBind t x)
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ([m (a, NextBind t x)] -> m (a, NextBind t x))
-> [m (a, NextBind t x)] -> m (a, NextBind t x)
forall a b. (a -> b) -> a -> b
$ (y -> m (a, NextBind t x)) -> [y] -> [m (a, NextBind t x)]
forall a b. (a -> b) -> [a] -> [b]
map ((a, NextBind t x) -> m (a, NextBind t x)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((a, NextBind t x) -> m (a, NextBind t x))
-> (y -> (a, NextBind t x)) -> y -> m (a, NextBind t x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a
a,) (NextBind t x -> (a, NextBind t x))
-> (y -> NextBind t x) -> y -> (a, NextBind t x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. y -> NextBind t x
y) ([y] -> [m (a, NextBind t x)]) -> [y] -> [m (a, NextBind t x)]
forall a b. (a -> b) -> a -> b
$ NextBind t y -> [y]
forall (t :: * -> *) x. NextBind t x -> [x]
immediate NextBind t y
x'
            else (a, NextBind t x) -> m (a, NextBind t x)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, NextBind t y -> (y -> NextBind t x) -> NextBind t x
forall (t :: * -> *) y x.
NextBind t y -> (y -> NextBind t x) -> NextBind t x
Next NextBind t y
x' y -> NextBind t x
y)
        Branch NextBind t x
l NextBind t x
r ->
          (forall b y. NextBind t y -> AST ops b -> m (b, NextBind t y))
-> NextBind t x -> op (AST ops) a -> m (a, NextBind t x)
forall (ops :: [Effect]) x a.
(forall b y. NextBind t y -> AST ops b -> m (b, NextBind t y))
-> NextBind t x -> op (AST ops) a -> m (a, NextBind t x)
forall (t :: * -> *) (m :: * -> *) (op :: Effect) (ops :: [Effect])
       x a.
InterpretEffectStateful t m op =>
(forall b y. t y -> AST ops b -> m (b, t y))
-> t x -> op (AST ops) a -> m (a, t x)
interpretEffectStateful NextBind t y -> AST ops b -> m (b, NextBind t y)
forall b y. NextBind t y -> AST ops b -> m (b, NextBind t y)
evalActs NextBind t x
l op (AST ops) a
op
            m (a, NextBind t x) -> m (a, NextBind t x) -> m (a, NextBind t x)
forall a. m a -> m a -> m a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` (forall b y. NextBind t y -> AST ops b -> m (b, NextBind t y))
-> NextBind t x -> op (AST ops) a -> m (a, NextBind t x)
forall (ops :: [Effect]) x a.
(forall b y. NextBind t y -> AST ops b -> m (b, NextBind t y))
-> NextBind t x -> op (AST ops) a -> m (a, NextBind t x)
forall (t :: * -> *) (m :: * -> *) (op :: Effect) (ops :: [Effect])
       x a.
InterpretEffectStateful t m op =>
(forall b y. t y -> AST ops b -> m (b, t y))
-> t x -> op (AST ops) a -> m (a, t x)
interpretEffectStateful NextBind t y -> AST ops b -> m (b, NextBind t y)
forall b y. NextBind t y -> AST ops b -> m (b, NextBind t y)
evalActs NextBind t x
r op (AST ops) a
op