--------------------------------------------------------------------
-- |
-- Module    : Text.Regex.Applicative.Object
-- Copyright : (c) Roman Cheplyaka
-- License   : MIT
--
-- Maintainer: Roman Cheplyaka <roma@ro-che.info>
-- Stability : experimental
--
-- This is a low-level interface to the regex engine.
--------------------------------------------------------------------
{-# 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

-- | The state of the engine is represented as a \"regex object\" of type
-- @'ReObject' s r@, where @s@ is the type of symbols and @r@ is the
-- result type (as in the 'RE' type). Think of 'ReObject' as a collection of
-- 'Thread's ordered by priority. E.g. threads generated by the left part of
-- '<|>' come before the threads generated by the right part.
newtype ReObject s r = ReObject (SQ.StateQueue (Thread s r))

-- | List of all threads of an object. Each non-result thread has a unique id.
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

-- | Create an object from a list of threads. It is recommended that all
-- threads come from the same 'ReObject', unless you know what you're doing.
-- However, it should be safe to filter out or rearrange threads.
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

-- | Check whether a thread is a result thread
isResult :: Thread s r -> Bool
isResult :: forall s r. Thread s r -> Bool
isResult Accept {} = Bool
True
isResult Thread s r
_ = Bool
False

-- | Return the result of a result thread, or 'Nothing' if it's not a result
-- thread
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

-- | Check if the object has no threads. In that case it never will
-- produce any new threads as a result of 'step'.
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

-- | Empty object (with no threads)
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

-- | Extract the result values from all the result threads of an object
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

-- | Feed a symbol into a regex object
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

-- | Feed a symbol into a non-result thread. It is an error to call 'stepThread'
-- on a result thread.
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"

-- | Add a thread to an object. The new thread will have lower priority than the
-- threads which are already in the object.
--
-- If a (non-result) thread with the same id already exists in the object, the
-- object is not changed.
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 a regular expression into a regular expression object
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