{-# LANGUAGE GADTs #-}
module Text.Regex.Applicative.Compile (compile) where
import Control.Monad ((<=<))
import Control.Monad.Trans.State
import Data.Foldable
import Data.Maybe
import Data.Monoid (Any (..))
import qualified Data.IntMap as IntMap
import Text.Regex.Applicative.Types
compile :: RE s a -> (a -> [Thread s r]) -> [Thread s r]
compile :: forall s a r. RE s a -> (a -> [Thread s r]) -> [Thread s r]
compile RE s a
e a -> [Thread s r]
k = forall s a r. RE s a -> Cont (a -> [Thread s r]) -> [Thread s r]
compile2 RE s a
e (forall a. a -> Cont a
SingleCont a -> [Thread s r]
k)
data Cont a = SingleCont !a | EmptyNonEmpty !a !a
instance Functor Cont where
fmap :: forall a b. (a -> b) -> Cont a -> Cont b
fmap a -> b
f Cont a
k =
case Cont a
k of
SingleCont a
a -> forall a. a -> Cont a
SingleCont (a -> b
f a
a)
EmptyNonEmpty a
a a
b -> forall a. a -> a -> Cont a
EmptyNonEmpty (a -> b
f a
a) (a -> b
f a
b)
emptyCont :: Cont a -> a
emptyCont :: forall a. Cont a -> a
emptyCont Cont a
k =
case Cont a
k of
SingleCont a
a -> a
a
EmptyNonEmpty a
a a
_ -> a
a
nonEmptyCont :: Cont a -> a
nonEmptyCont :: forall a. Cont a -> a
nonEmptyCont Cont a
k =
case Cont a
k of
SingleCont a
a -> a
a
EmptyNonEmpty a
_ a
a -> a
a
compile2 :: RE s a -> Cont (a -> [Thread s r]) -> [Thread s r]
compile2 :: forall s a r. RE s a -> Cont (a -> [Thread s r]) -> [Thread s r]
compile2 RE s a
e =
case RE s a
e of
RE s a
Eps -> \Cont (a -> [Thread s r])
k -> forall a. Cont a -> a
emptyCont Cont (a -> [Thread s r])
k ()
Symbol ThreadId
i s -> Maybe a
p -> \Cont (a -> [Thread s r])
k -> [(a -> [Thread s r]) -> Thread s r
t forall a b. (a -> b) -> a -> b
$ forall a. Cont a -> a
nonEmptyCont Cont (a -> [Thread s r])
k] where
t :: (a -> [Thread s r]) -> Thread s r
t a -> [Thread s r]
k = forall s r. ThreadId -> (s -> [Thread s r]) -> Thread s r
Thread ThreadId
i forall a b. (a -> b) -> a -> b
$ \s
s ->
case s -> Maybe a
p s
s of
Just a
r -> a -> [Thread s r]
k a
r
Maybe a
Nothing -> []
App RE s (a -> a)
n1 RE s a
n2 ->
let a1 :: Cont ((a -> a) -> [Thread s r]) -> [Thread s r]
a1 = forall s a r. RE s a -> Cont (a -> [Thread s r]) -> [Thread s r]
compile2 RE s (a -> a)
n1
a2 :: Cont (a -> [Thread s r]) -> [Thread s r]
a2 = forall s a r. RE s a -> Cont (a -> [Thread s r]) -> [Thread s r]
compile2 RE s a
n2
in \Cont (a -> [Thread s r])
k -> case Cont (a -> [Thread s r])
k of
SingleCont a -> [Thread s r]
k -> Cont ((a -> a) -> [Thread s r]) -> [Thread s r]
a1 forall a b. (a -> b) -> a -> b
$ forall a. a -> Cont a
SingleCont forall a b. (a -> b) -> a -> b
$ \a -> a
a1_value -> Cont (a -> [Thread s r]) -> [Thread s r]
a2 forall a b. (a -> b) -> a -> b
$ forall a. a -> Cont a
SingleCont forall a b. (a -> b) -> a -> b
$ a -> [Thread s r]
k forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
a1_value
EmptyNonEmpty a -> [Thread s r]
ke a -> [Thread s r]
kn ->
Cont ((a -> a) -> [Thread s r]) -> [Thread s r]
a1 forall a b. (a -> b) -> a -> b
$ forall a. a -> a -> Cont a
EmptyNonEmpty
(\a -> a
a1_value -> Cont (a -> [Thread s r]) -> [Thread s r]
a2 forall a b. (a -> b) -> a -> b
$ forall a. a -> a -> Cont a
EmptyNonEmpty (a -> [Thread s r]
ke forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
a1_value) (a -> [Thread s r]
kn forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
a1_value))
(\a -> a
a1_value -> Cont (a -> [Thread s r]) -> [Thread s r]
a2 forall a b. (a -> b) -> a -> b
$ forall a. a -> a -> Cont a
EmptyNonEmpty (a -> [Thread s r]
kn forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
a1_value) (a -> [Thread s r]
kn forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
a1_value))
Alt RE s a
n1 RE s a
n2 ->
let a1 :: Cont (a -> [Thread s r]) -> [Thread s r]
a1 = forall s a r. RE s a -> Cont (a -> [Thread s r]) -> [Thread s r]
compile2 RE s a
n1
a2 :: Cont (a -> [Thread s r]) -> [Thread s r]
a2 = forall s a r. RE s a -> Cont (a -> [Thread s r]) -> [Thread s r]
compile2 RE s a
n2
in \Cont (a -> [Thread s r])
k -> Cont (a -> [Thread s r]) -> [Thread s r]
a1 Cont (a -> [Thread s r])
k forall a. [a] -> [a] -> [a]
++ Cont (a -> [Thread s r]) -> [Thread s r]
a2 Cont (a -> [Thread s r])
k
RE s a
Fail -> forall a b. a -> b -> a
const []
Fmap a -> a
f RE s a
n -> let a :: Cont (a -> [Thread s r]) -> [Thread s r]
a = forall s a r. RE s a -> Cont (a -> [Thread s r]) -> [Thread s r]
compile2 RE s a
n in \Cont (a -> [Thread s r])
k -> Cont (a -> [Thread s r]) -> [Thread s r]
a forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
f) Cont (a -> [Thread s r])
k
CatMaybes RE s (Maybe a)
n -> let a :: Cont (Maybe a -> [Thread s r]) -> [Thread s r]
a = forall s a r. RE s a -> Cont (a -> [Thread s r]) -> [Thread s r]
compile2 RE s (Maybe a)
n in \Cont (a -> [Thread s r])
k -> Cont (Maybe a -> [Thread s r]) -> [Thread s r]
a forall a b. (a -> b) -> a -> b
$ (forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall (t :: * -> *) a. Foldable t => t a -> [a]
toList) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cont (a -> [Thread s r])
k
Rep Greediness
g a -> a -> a
f a
b RE s a
n ->
let a :: Cont (a -> [Thread s r]) -> [Thread s r]
a = forall s a r. RE s a -> Cont (a -> [Thread s r]) -> [Thread s r]
compile2 RE s a
n
threads :: a -> Cont (a -> [Thread s r]) -> [Thread s r]
threads a
b Cont (a -> [Thread s r])
k =
forall a. Greediness -> [a] -> [a] -> [a]
combine Greediness
g
(Cont (a -> [Thread s r]) -> [Thread s r]
a forall a b. (a -> b) -> a -> b
$ forall a. a -> a -> Cont a
EmptyNonEmpty (\a
_ -> []) (\a
v -> let b' :: a
b' = a -> a -> a
f a
b a
v in a -> Cont (a -> [Thread s r]) -> [Thread s r]
threads a
b' (forall a. a -> Cont a
SingleCont forall a b. (a -> b) -> a -> b
$ forall a. Cont a -> a
nonEmptyCont Cont (a -> [Thread s r])
k)))
(forall a. Cont a -> a
emptyCont Cont (a -> [Thread s r])
k a
b)
in a -> Cont (a -> [Thread s r]) -> [Thread s r]
threads a
b
Void RE s a
n
| forall s a. RE s a -> Bool
hasCatMaybes RE s a
n -> forall s a r. RE s a -> Cont (a -> [Thread s r]) -> [Thread s r]
compile2 RE s a
n forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall b c a. (b -> c) -> (a -> b) -> a -> c
. \ a
_ -> ())
| Bool
otherwise -> forall s a r. RE s a -> Cont [Thread s r] -> [Thread s r]
compile2_ RE s a
n forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> a -> b
$ ())
data FSMState
= SAccept
| STransition !ThreadId
type FSMMap s = IntMap.IntMap (s -> Bool, [FSMState])
mkNFA :: RE s a -> ([FSMState], (FSMMap s))
mkNFA :: forall s a. RE s a -> ([FSMState], FSMMap s)
mkNFA RE s a
e =
forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s a. State s a -> s -> (a, s)
runState forall a. IntMap a
IntMap.empty forall a b. (a -> b) -> a -> b
$
forall s a. RE s a -> [FSMState] -> State (FSMMap s) [FSMState]
go RE s a
e [FSMState
SAccept]
where
go :: RE s a -> [FSMState] -> State (FSMMap s) [FSMState]
go :: forall s a. RE s a -> [FSMState] -> State (FSMMap s) [FSMState]
go RE s a
e [FSMState]
k =
case RE s a
e of
RE s a
Eps -> forall (m :: * -> *) a. Monad m => a -> m a
return [FSMState]
k
Symbol i :: ThreadId
i@(ThreadId Int
n) s -> Maybe a
p -> do
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify forall a b. (a -> b) -> a -> b
$ forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert Int
n forall a b. (a -> b) -> a -> b
$
(forall a. Maybe a -> Bool
isJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> Maybe a
p, [FSMState]
k)
forall (m :: * -> *) a. Monad m => a -> m a
return [ThreadId -> FSMState
STransition ThreadId
i]
App RE s (a -> a)
n1 RE s a
n2 -> forall s a. RE s a -> [FSMState] -> State (FSMMap s) [FSMState]
go RE s (a -> a)
n1 forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall s a. RE s a -> [FSMState] -> State (FSMMap s) [FSMState]
go RE s a
n2 [FSMState]
k
Alt RE s a
n1 RE s a
n2 -> forall a. [a] -> [a] -> [a]
(++) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s a. RE s a -> [FSMState] -> State (FSMMap s) [FSMState]
go RE s a
n1 [FSMState]
k forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall s a. RE s a -> [FSMState] -> State (FSMMap s) [FSMState]
go RE s a
n2 [FSMState]
k
RE s a
Fail -> forall (m :: * -> *) a. Monad m => a -> m a
return []
Fmap a -> a
_ RE s a
n -> forall s a. RE s a -> [FSMState] -> State (FSMMap s) [FSMState]
go RE s a
n [FSMState]
k
CatMaybes RE s (Maybe a)
_ -> forall a. HasCallStack => [Char] -> a
error [Char]
"mkNFA CatMaybes"
Rep Greediness
g a -> a -> a
_ a
_ RE s a
n ->
let entries :: [FSMState]
entries = forall s a. RE s a -> [FSMState]
findEntries RE s a
n
cont :: [FSMState]
cont = forall a. Greediness -> [a] -> [a] -> [a]
combine Greediness
g [FSMState]
entries [FSMState]
k
in
forall s a. RE s a -> [FSMState] -> State (FSMMap s) [FSMState]
go RE s a
n [FSMState]
cont forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return [FSMState]
cont
Void RE s a
n -> forall s a. RE s a -> [FSMState] -> State (FSMMap s) [FSMState]
go RE s a
n [FSMState]
k
findEntries :: RE s a -> [FSMState]
findEntries :: forall s a. RE s a -> [FSMState]
findEntries RE s a
e =
forall s a. State s a -> s -> a
evalState (forall s a. RE s a -> [FSMState] -> State (FSMMap s) [FSMState]
go RE s a
e []) forall a. IntMap a
IntMap.empty
hasCatMaybes :: RE s a -> Bool
hasCatMaybes :: forall s a. RE s a -> Bool
hasCatMaybes = Any -> Bool
getAny forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b s a. Monoid b => (forall a1. RE s a1 -> b) -> RE s a -> b
foldMapPostorder (Bool -> Any
Any forall b c a. (b -> c) -> (a -> b) -> a -> c
. \ case CatMaybes RE s (Maybe a1)
_ -> Bool
True; RE s a1
_ -> Bool
False)
compile2_ :: RE s a -> Cont [Thread s r] -> [Thread s r]
compile2_ :: forall s a r. RE s a -> Cont [Thread s r] -> [Thread s r]
compile2_ RE s a
e =
let ([FSMState]
entries, FSMMap s
fsmap) = forall s a. RE s a -> ([FSMState], FSMMap s)
mkNFA RE s a
e
mkThread :: [Thread s r] -> [Thread s r] -> FSMState -> [Thread s r]
mkThread [Thread s r]
_ [Thread s r]
k1 (STransition i :: ThreadId
i@(ThreadId Int
n)) =
let (s -> Bool
p, [FSMState]
cont) = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => [Char] -> a
error [Char]
"Unknown id") forall a b. (a -> b) -> a -> b
$ forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
n FSMMap s
fsmap
in [forall s r. ThreadId -> (s -> [Thread s r]) -> Thread s r
Thread ThreadId
i forall a b. (a -> b) -> a -> b
$ \s
s ->
if s -> Bool
p s
s
then forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([Thread s r] -> [Thread s r] -> FSMState -> [Thread s r]
mkThread [Thread s r]
k1 [Thread s r]
k1) [FSMState]
cont
else []]
mkThread [Thread s r]
k0 [Thread s r]
_ FSMState
SAccept = [Thread s r]
k0
in \Cont [Thread s r]
k -> forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([Thread s r] -> [Thread s r] -> FSMState -> [Thread s r]
mkThread (forall a. Cont a -> a
emptyCont Cont [Thread s r]
k) (forall a. Cont a -> a
nonEmptyCont Cont [Thread s r]
k)) [FSMState]
entries
combine :: Greediness -> [a] -> [a] -> [a]
combine :: forall a. Greediness -> [a] -> [a] -> [a]
combine Greediness
g [a]
continue [a]
stop =
case Greediness
g of
Greediness
Greedy -> [a]
continue forall a. [a] -> [a] -> [a]
++ [a]
stop
Greediness
NonGreedy -> [a]
stop forall a. [a] -> [a] -> [a]
++ [a]
continue