--------------------------------------------------------------------
-- |
-- 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
import Control.Applicative hiding (empty)

-- | 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 :: ReObject s r -> [Thread s r]
threads (ReObject StateQueue (Thread s r)
sq) = StateQueue (Thread s r) -> [Thread s r]
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 :: [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 (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 :: 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 :: 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 :: ReObject s r -> Bool
failed ReObject s r
obj = [Thread s r] -> 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 :: 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 :: 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 :: 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 (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 (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 :: 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 :: 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 :: 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 :: RE s a -> RE s a
renumber RE s a
e = (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)
-> State ThreadId (RE s a) -> RE s a
forall a b. (a -> b) -> a -> b
$ RE s a -> State ThreadId (RE s a)
forall s a. RE s a -> State ThreadId (RE s a)
go RE s a
e
  where
    go :: RE s a -> State ThreadId (RE s a)
    go :: RE s a -> State ThreadId (RE s a)
go RE s a
e =
        case RE s a
e of
            RE s a
Eps -> RE s () -> StateT ThreadId Identity (RE s ())
forall (m :: * -> *) a. Monad m => a -> m a
return RE s ()
forall s. RE s ()
Eps
            Symbol ThreadId
_ s -> Maybe a
p -> ThreadId -> (s -> Maybe a) -> RE s a
forall s a. ThreadId -> (s -> Maybe a) -> RE s a
Symbol (ThreadId -> (s -> Maybe a) -> RE s a)
-> StateT ThreadId Identity ThreadId
-> StateT ThreadId Identity ((s -> Maybe a) -> RE s a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT ThreadId Identity ThreadId
fresh StateT ThreadId Identity ((s -> Maybe a) -> RE s a)
-> StateT ThreadId Identity (s -> Maybe a)
-> State ThreadId (RE s a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (s -> Maybe a) -> StateT ThreadId Identity (s -> Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure s -> Maybe a
p
            Alt RE s a
a1 RE s a
a2 -> RE s a -> RE s a -> RE s a
forall s a. RE s a -> RE s a -> RE s a
Alt (RE s a -> RE s a -> RE s a)
-> State ThreadId (RE s a)
-> StateT ThreadId Identity (RE s a -> RE s a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RE s a -> State ThreadId (RE s a)
forall s a. RE s a -> State ThreadId (RE s a)
go RE s a
a1 StateT ThreadId Identity (RE s a -> RE s a)
-> State ThreadId (RE s a) -> State ThreadId (RE s a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RE s a -> State ThreadId (RE s a)
forall s a. RE s a -> State ThreadId (RE s a)
go RE s a
a2
            App RE s (a -> a)
a1 RE s a
a2 -> RE s (a -> a) -> RE s a -> RE s a
forall s a b. RE s (a -> b) -> RE s a -> RE s b
App (RE s (a -> a) -> RE s a -> RE s a)
-> StateT ThreadId Identity (RE s (a -> a))
-> StateT ThreadId Identity (RE s a -> RE s a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RE s (a -> a) -> StateT ThreadId Identity (RE s (a -> a))
forall s a. RE s a -> State ThreadId (RE s a)
go RE s (a -> a)
a1 StateT ThreadId Identity (RE s a -> RE s a)
-> StateT ThreadId Identity (RE s a) -> State ThreadId (RE s a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RE s a -> StateT ThreadId Identity (RE s a)
forall s a. RE s a -> State ThreadId (RE s a)
go RE s a
a2
            RE s a
Fail -> RE s a -> State ThreadId (RE s a)
forall (m :: * -> *) a. Monad m => a -> m a
return RE s a
forall s a. RE s a
Fail
            Fmap a -> a
f RE s a
a -> (a -> a) -> RE s a -> RE s a
forall a b s. (a -> b) -> RE s a -> RE s b
Fmap a -> a
f (RE s a -> RE s a)
-> StateT ThreadId Identity (RE s a) -> State ThreadId (RE s a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RE s a -> StateT ThreadId Identity (RE s a)
forall s a. RE s a -> State ThreadId (RE s a)
go RE s a
a
            Rep Greediness
g a -> a -> a
f a
b RE s a
a -> Greediness -> (a -> a -> a) -> a -> RE s a -> RE s a
forall b a s. Greediness -> (b -> a -> b) -> b -> RE s a -> RE s b
Rep Greediness
g a -> a -> a
f a
b (RE s a -> RE s a)
-> StateT ThreadId Identity (RE s a) -> State ThreadId (RE s a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RE s a -> StateT ThreadId Identity (RE s a)
forall s a. RE s a -> State ThreadId (RE s a)
go RE s a
a
            Void RE s a
a -> RE s a -> RE s ()
forall s a. RE s a -> RE s ()
Void (RE s a -> RE s ())
-> StateT ThreadId Identity (RE s a)
-> StateT ThreadId Identity (RE s ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RE s a -> StateT ThreadId Identity (RE s a)
forall s a. RE s a -> State ThreadId (RE s a)
go RE s a
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 (m :: * -> *) a. Monad m => a -> m a
return ThreadId
t