--------------------------------------------------------------------
-- |
-- Module    : Text.Regex.Applicative.Reference
-- Copyright : (c) Roman Cheplyaka
-- License   : MIT
--
-- Maintainer: Roman Cheplyaka <roma@ro-che.info>
-- Stability : experimental
--
-- Reference implementation (using backtracking).
--
-- This is exposed for testing purposes only!
--------------------------------------------------------------------

{-# LANGUAGE GADTs #-}
module Text.Regex.Applicative.Reference (reference) where
import Prelude hiding (getChar)
import Text.Regex.Applicative.Types
import Control.Applicative
import Control.Monad


-- A simple parsing monad
newtype P s a = P { forall s a. P s a -> [s] -> [(a, [s])]
unP :: [s] -> [(a, [s])] }

instance Monad (P s) where
    return :: forall a. a -> P s a
return a
x = ([s] -> [(a, [s])]) -> P s a
forall s a. ([s] -> [(a, [s])]) -> P s a
P (([s] -> [(a, [s])]) -> P s a) -> ([s] -> [(a, [s])]) -> P s a
forall a b. (a -> b) -> a -> b
$ \[s]
s -> [(a
x, [s]
s)]
    (P [s] -> [(a, [s])]
a) >>= :: forall a b. P s a -> (a -> P s b) -> P s b
>>= a -> P s b
k = ([s] -> [(b, [s])]) -> P s b
forall s a. ([s] -> [(a, [s])]) -> P s a
P (([s] -> [(b, [s])]) -> P s b) -> ([s] -> [(b, [s])]) -> P s b
forall a b. (a -> b) -> a -> b
$ \[s]
s ->
        [s] -> [(a, [s])]
a [s]
s [(a, [s])] -> ((a, [s]) -> [(b, [s])]) -> [(b, [s])]
forall a b. [a] -> (a -> [b]) -> [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(a
x,[s]
s) -> P s b -> [s] -> [(b, [s])]
forall s a. P s a -> [s] -> [(a, [s])]
unP (a -> P s b
k a
x) [s]
s

instance Functor (P s) where
    fmap :: forall a b. (a -> b) -> P s a -> P s b
fmap = (a -> b) -> P s a -> P s b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM

instance Applicative (P s) where
    <*> :: forall a b. P s (a -> b) -> P s a -> P s b
(<*>) = P s (a -> b) -> P s a -> P s b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
    pure :: forall a. a -> P s a
pure = a -> P s a
forall a. a -> P s a
forall (m :: * -> *) a. Monad m => a -> m a
return

instance Alternative (P s) where
    empty :: forall a. P s a
empty = ([s] -> [(a, [s])]) -> P s a
forall s a. ([s] -> [(a, [s])]) -> P s a
P (([s] -> [(a, [s])]) -> P s a) -> ([s] -> [(a, [s])]) -> P s a
forall a b. (a -> b) -> a -> b
$ [(a, [s])] -> [s] -> [(a, [s])]
forall a b. a -> b -> a
const []
    P [s] -> [(a, [s])]
a1 <|> :: forall a. P s a -> P s a -> P s a
<|> P [s] -> [(a, [s])]
a2 = ([s] -> [(a, [s])]) -> P s a
forall s a. ([s] -> [(a, [s])]) -> P s a
P (([s] -> [(a, [s])]) -> P s a) -> ([s] -> [(a, [s])]) -> P s a
forall a b. (a -> b) -> a -> b
$ \[s]
s ->
        [s] -> [(a, [s])]
a1 [s]
s [(a, [s])] -> [(a, [s])] -> [(a, [s])]
forall a. [a] -> [a] -> [a]
++ [s] -> [(a, [s])]
a2 [s]
s

getChar :: P s s
getChar :: forall s. P s s
getChar = ([s] -> [(s, [s])]) -> P s s
forall s a. ([s] -> [(a, [s])]) -> P s a
P (([s] -> [(s, [s])]) -> P s s) -> ([s] -> [(s, [s])]) -> P s s
forall a b. (a -> b) -> a -> b
$ \[s]
s ->
    case [s]
s of
        [] -> []
        s
c:[s]
cs -> [(s
c,[s]
cs)]

re2monad :: RE s a -> P s a
re2monad :: forall s a. RE s a -> P s a
re2monad RE s a
r =
    case RE s a
r of
        RE s a
Eps -> a -> P s a
forall a. a -> P s a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> P s a) -> a -> P s a
forall a b. (a -> b) -> a -> b
$ [Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"eps"
        Symbol ThreadId
_ s -> Maybe a
p -> do
            s
c <- P s s
forall s. P s s
getChar
            case s -> Maybe a
p s
c of
              Just a
r -> a -> P s a
forall a. a -> P s a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r
              Maybe a
Nothing -> P s a
forall a. P s a
forall (f :: * -> *) a. Alternative f => f a
empty
        Alt RE s a
a1 RE s a
a2 -> RE s a -> P s a
forall s a. RE s a -> P s a
re2monad RE s a
a1 P s a -> P s a -> P s a
forall a. P s a -> P s a -> P s a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> RE s a -> P s a
forall s a. RE s a -> P s a
re2monad RE s a
a2
        App RE s (a1 -> a)
a1 RE s a1
a2 -> RE s (a1 -> a) -> P s (a1 -> a)
forall s a. RE s a -> P s a
re2monad RE s (a1 -> a)
a1 P s (a1 -> a) -> P s a1 -> P s a
forall a b. P s (a -> b) -> P s a -> P s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RE s a1 -> P s a1
forall s a. RE s a -> P s a
re2monad RE s a1
a2
        Fmap a1 -> a
f RE s a1
a -> (a1 -> a) -> P s a1 -> P s a
forall a b. (a -> b) -> P s a -> P s b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a1 -> a
f (P s a1 -> P s a) -> P s a1 -> P s a
forall a b. (a -> b) -> a -> b
$ RE s a1 -> P s a1
forall s a. RE s a -> P s a
re2monad RE s a1
a
        CatMaybes RE s (Maybe a)
a -> P s a -> (a -> P s a) -> Maybe a -> P s a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe P s a
forall a. P s a
forall (f :: * -> *) a. Alternative f => f a
empty a -> P s a
forall a. a -> P s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> P s a) -> P s (Maybe a) -> P s a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< RE s (Maybe a) -> P s (Maybe a)
forall s a. RE s a -> P s a
re2monad RE s (Maybe a)
a
        Rep Greediness
g a -> a1 -> a
f a
b RE s a1
a -> a -> P s a
rep a
b
            where
            am :: P s a1
am = RE s a1 -> P s a1
forall s a. RE s a -> P s a
re2monad RE s a1
a
            rep :: a -> P s a
rep a
b = P s a -> P s a -> P s a
combine (do a1
a <- P s a1
am; a -> P s a
rep (a -> P s a) -> a -> P s a
forall a b. (a -> b) -> a -> b
$ a -> a1 -> a
f a
b a1
a) (a -> P s a
forall a. a -> P s a
forall (m :: * -> *) a. Monad m => a -> m a
return a
b)
            combine :: P s a -> P s a -> P s a
combine P s a
a P s a
b = case Greediness
g of Greediness
Greedy -> P s a
a P s a -> P s a -> P s a
forall a. P s a -> P s a -> P s a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> P s a
b; Greediness
NonGreedy -> P s a
b P s a -> P s a -> P s a
forall a. P s a -> P s a -> P s a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> P s a
a
        Void RE s a1
a -> RE s a1 -> P s a1
forall s a. RE s a -> P s a
re2monad RE s a1
a P s a1 -> P s a -> P s a
forall a b. P s a -> P s b -> P s b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> P s a
forall a. a -> P s a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        RE s a
Fail -> P s a
forall a. P s a
forall (f :: * -> *) a. Alternative f => f a
empty

runP :: P s a -> [s] -> Maybe a
runP :: forall s a. P s a -> [s] -> Maybe a
runP P s a
m [s]
s = case ((a, [s]) -> Bool) -> [(a, [s])] -> [(a, [s])]
forall a. (a -> Bool) -> [a] -> [a]
filter ([s] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([s] -> Bool) -> ((a, [s]) -> [s]) -> (a, [s]) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, [s]) -> [s]
forall a b. (a, b) -> b
snd) ([(a, [s])] -> [(a, [s])]) -> [(a, [s])] -> [(a, [s])]
forall a b. (a -> b) -> a -> b
$ P s a -> [s] -> [(a, [s])]
forall s a. P s a -> [s] -> [(a, [s])]
unP P s a
m [s]
s of
    (a
r, [s]
_) : [(a, [s])]
_ -> a -> Maybe a
forall a. a -> Maybe a
Just a
r
    [(a, [s])]
_ -> Maybe a
forall a. Maybe a
Nothing

-- | 'reference' @r@ @s@ should give the same results as @s@ '=~' @r@.
--
-- However, this is not very efficient implementation and is supposed to be
-- used for testing only.
reference :: RE s a -> [s] -> Maybe a
reference :: forall s a. RE s a -> [s] -> Maybe a
reference RE s a
r [s]
s = P s a -> [s] -> Maybe a
forall s a. P s a -> [s] -> Maybe a
runP (RE s a -> P s a
forall s a. RE s a -> P s a
re2monad RE s a
r) [s]
s