{-# LANGUAGE GADTs #-}
module Text.Regex.Applicative.Object
( ReObject
, compile
, emptyObject
, Thread
, threads
, failed
, isResult
, getResult
, results
, ThreadId
, threadId
, step
, stepThread
, fromThreads
, addThread
) where
import Text.Regex.Applicative.Types
import qualified Text.Regex.Applicative.StateQueue as SQ
import qualified Text.Regex.Applicative.Compile as Compile
import Data.Maybe
import Data.Foldable as F
import Control.Monad.Trans.State
newtype ReObject s r = ReObject (SQ.StateQueue (Thread s r))
threads :: ReObject s r -> [Thread s r]
threads :: forall s r. ReObject s r -> [Thread s r]
threads (ReObject StateQueue (Thread s r)
sq) = StateQueue (Thread s r) -> [Thread s r]
forall a. StateQueue a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList StateQueue (Thread s r)
sq
fromThreads :: [Thread s r] -> ReObject s r
fromThreads :: forall s r. [Thread s r] -> ReObject s r
fromThreads [Thread s r]
ts = (ReObject s r -> Thread s r -> ReObject s r)
-> ReObject s r -> [Thread s r] -> ReObject s r
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
F.foldl' ((Thread s r -> ReObject s r -> ReObject s r)
-> ReObject s r -> Thread s r -> ReObject s r
forall a b c. (a -> b -> c) -> b -> a -> c
flip Thread s r -> ReObject s r -> ReObject s r
forall s r. Thread s r -> ReObject s r -> ReObject s r
addThread) ReObject s r
forall s r. ReObject s r
emptyObject [Thread s r]
ts
isResult :: Thread s r -> Bool
isResult :: forall s r. Thread s r -> Bool
isResult Accept {} = Bool
True
isResult Thread s r
_ = Bool
False
getResult :: Thread s r -> Maybe r
getResult :: forall s r. Thread s r -> Maybe r
getResult (Accept r
r) = r -> Maybe r
forall a. a -> Maybe a
Just r
r
getResult Thread s r
_ = Maybe r
forall a. Maybe a
Nothing
failed :: ReObject s r -> Bool
failed :: forall s r. ReObject s r -> Bool
failed ReObject s r
obj = [Thread s r] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Thread s r] -> Bool) -> [Thread s r] -> Bool
forall a b. (a -> b) -> a -> b
$ ReObject s r -> [Thread s r]
forall s r. ReObject s r -> [Thread s r]
threads ReObject s r
obj
emptyObject :: ReObject s r
emptyObject :: forall s r. ReObject s r
emptyObject = StateQueue (Thread s r) -> ReObject s r
forall s r. StateQueue (Thread s r) -> ReObject s r
ReObject (StateQueue (Thread s r) -> ReObject s r)
-> StateQueue (Thread s r) -> ReObject s r
forall a b. (a -> b) -> a -> b
$ StateQueue (Thread s r)
forall a. StateQueue a
SQ.empty
results :: ReObject s r -> [r]
results :: forall s r. ReObject s r -> [r]
results ReObject s r
obj =
(Thread s r -> Maybe r) -> [Thread s r] -> [r]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Thread s r -> Maybe r
forall s r. Thread s r -> Maybe r
getResult ([Thread s r] -> [r]) -> [Thread s r] -> [r]
forall a b. (a -> b) -> a -> b
$ ReObject s r -> [Thread s r]
forall s r. ReObject s r -> [Thread s r]
threads ReObject s r
obj
step :: s -> ReObject s r -> ReObject s r
step :: forall s r. s -> ReObject s r -> ReObject s r
step s
s (ReObject StateQueue (Thread s r)
sq) =
let accum :: ReObject s r -> Thread s r -> ReObject s r
accum ReObject s r
q Thread s r
t =
case Thread s r
t of
Accept {} -> ReObject s r
q
Thread ThreadId
_ s -> [Thread s r]
c ->
(ReObject s r -> Thread s r -> ReObject s r)
-> ReObject s r -> [Thread s r] -> ReObject s r
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
F.foldl' (\ReObject s r
q Thread s r
x -> Thread s r -> ReObject s r -> ReObject s r
forall s r. Thread s r -> ReObject s r -> ReObject s r
addThread Thread s r
x ReObject s r
q) ReObject s r
q ([Thread s r] -> ReObject s r) -> [Thread s r] -> ReObject s r
forall a b. (a -> b) -> a -> b
$ s -> [Thread s r]
c s
s
newQueue :: ReObject s r
newQueue = (ReObject s r -> Thread s r -> ReObject s r)
-> ReObject s r -> StateQueue (Thread s r) -> ReObject s r
forall b a. (b -> a -> b) -> b -> StateQueue a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
F.foldl' ReObject s r -> Thread s r -> ReObject s r
accum ReObject s r
forall s r. ReObject s r
emptyObject StateQueue (Thread s r)
sq
in ReObject s r
newQueue
stepThread :: s -> Thread s r -> [Thread s r]
stepThread :: forall s r. s -> Thread s r -> [Thread s r]
stepThread s
s Thread s r
t =
case Thread s r
t of
Thread ThreadId
_ s -> [Thread s r]
c -> s -> [Thread s r]
c s
s
Accept {} -> [Char] -> [Thread s r]
forall a. HasCallStack => [Char] -> a
error [Char]
"stepThread on a result"
addThread :: Thread s r -> ReObject s r -> ReObject s r
addThread :: forall s r. Thread s r -> ReObject s r -> ReObject s r
addThread Thread s r
t (ReObject StateQueue (Thread s r)
q) =
case Thread s r
t of
Accept {} -> StateQueue (Thread s r) -> ReObject s r
forall s r. StateQueue (Thread s r) -> ReObject s r
ReObject (StateQueue (Thread s r) -> ReObject s r)
-> StateQueue (Thread s r) -> ReObject s r
forall a b. (a -> b) -> a -> b
$ Thread s r -> StateQueue (Thread s r) -> StateQueue (Thread s r)
forall a. a -> StateQueue a -> StateQueue a
SQ.insert Thread s r
t StateQueue (Thread s r)
q
Thread { threadId_ :: forall s r. Thread s r -> ThreadId
threadId_ = ThreadId Int
i } -> StateQueue (Thread s r) -> ReObject s r
forall s r. StateQueue (Thread s r) -> ReObject s r
ReObject (StateQueue (Thread s r) -> ReObject s r)
-> StateQueue (Thread s r) -> ReObject s r
forall a b. (a -> b) -> a -> b
$ Int
-> Thread s r -> StateQueue (Thread s r) -> StateQueue (Thread s r)
forall a. Int -> a -> StateQueue a -> StateQueue a
SQ.insertUnique Int
i Thread s r
t StateQueue (Thread s r)
q
compile :: RE s r -> ReObject s r
compile :: forall s r. RE s r -> ReObject s r
compile =
[Thread s r] -> ReObject s r
forall s r. [Thread s r] -> ReObject s r
fromThreads ([Thread s r] -> ReObject s r)
-> (RE s r -> [Thread s r]) -> RE s r -> ReObject s r
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
(RE s r -> (r -> [Thread s r]) -> [Thread s r])
-> (r -> [Thread s r]) -> RE s r -> [Thread s r]
forall a b c. (a -> b -> c) -> b -> a -> c
flip RE s r -> (r -> [Thread s r]) -> [Thread s r]
forall s a r. RE s a -> (a -> [Thread s r]) -> [Thread s r]
Compile.compile (\r
x -> [r -> Thread s r
forall s r. r -> Thread s r
Accept r
x]) (RE s r -> [Thread s r])
-> (RE s r -> RE s r) -> RE s r -> [Thread s r]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
RE s r -> RE s r
forall s a. RE s a -> RE s a
renumber
renumber :: RE s a -> RE s a
renumber :: forall s a. RE s a -> RE s a
renumber =
(State ThreadId (RE s a) -> ThreadId -> RE s a)
-> ThreadId -> State ThreadId (RE s a) -> RE s a
forall a b c. (a -> b -> c) -> b -> a -> c
flip State ThreadId (RE s a) -> ThreadId -> RE s a
forall s a. State s a -> s -> a
evalState (Int -> ThreadId
ThreadId Int
1) (State ThreadId (RE s a) -> RE s a)
-> (RE s a -> State ThreadId (RE s a)) -> RE s a -> RE s a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
(forall a1. RE s a1 -> StateT ThreadId Identity (RE s a1))
-> RE s a -> State ThreadId (RE s a)
forall s a (m :: * -> *).
Monad m =>
(forall a1. RE s a1 -> m (RE s a1)) -> RE s a -> m (RE s a)
traversePostorder (\ case Symbol ThreadId
_ s -> Maybe a1
p -> (ThreadId -> (s -> Maybe a1) -> RE s a1)
-> (s -> Maybe a1) -> ThreadId -> RE s a1
forall a b c. (a -> b -> c) -> b -> a -> c
flip ThreadId -> (s -> Maybe a1) -> RE s a1
forall s a. ThreadId -> (s -> Maybe a) -> RE s a
Symbol s -> Maybe a1
p (ThreadId -> RE s a1)
-> StateT ThreadId Identity ThreadId
-> StateT ThreadId Identity (RE s a1)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT ThreadId Identity ThreadId
fresh; RE s a1
a -> RE s a1 -> StateT ThreadId Identity (RE s a1)
forall a. a -> StateT ThreadId Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RE s a1
a)
fresh :: State ThreadId ThreadId
fresh :: StateT ThreadId Identity ThreadId
fresh = do
t :: ThreadId
t@(ThreadId Int
i) <- StateT ThreadId Identity ThreadId
forall (m :: * -> *) s. Monad m => StateT s m s
get
ThreadId -> StateT ThreadId Identity ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (ThreadId -> StateT ThreadId Identity ())
-> ThreadId -> StateT ThreadId Identity ()
forall a b. (a -> b) -> a -> b
$! Int -> ThreadId
ThreadId (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
ThreadId -> StateT ThreadId Identity ThreadId
forall a. a -> StateT ThreadId Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ThreadId
t