--------------------------------------------------------------------
-- |
-- 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 { P s a -> [s] -> [(a, [s])]
unP :: [s] -> [(a, [s])] }

instance Monad (P s) where
    return :: a -> P s a
return x :: 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]
s -> [(a
x, [s]
s)]
    (P a :: [s] -> [(a, [s])]
a) >>= :: P s a -> (a -> P s b) -> P s b
>>= k :: 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 ->
        [s] -> [(a, [s])]
a [s]
s [(a, [s])] -> ((a, [s]) -> [(b, [s])]) -> [(b, [s])]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(x :: a
x,s :: [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 :: (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
    <*> :: 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 :: a -> P s a
pure = a -> P s a
forall (m :: * -> *) a. Monad m => a -> m a
return

instance Alternative (P s) where
    empty :: 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 a1 :: [s] -> [(a, [s])]
a1 <|> :: P s a -> P s a -> P s a
<|> P a2 :: [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 ->
        [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 :: 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]
s ->
    case [s]
s of
        [] -> []
        c :: s
c:cs :: [s]
cs -> [(s
c,[s]
cs)]

re2monad :: RE s a -> P s a
re2monad :: RE s a -> P s a
re2monad r :: RE s a
r =
    case RE s a
r of
        Eps -> 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 "eps"
        Symbol _ p :: 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 r :: a
r -> a -> P s a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r
              Nothing -> P s a
forall (f :: * -> *) a. Alternative f => f a
empty
        Alt a1 :: RE s a
a1 a2 :: 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 (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 a1 :: RE s (a -> a)
a1 a2 :: RE s a
a2 -> RE s (a -> a) -> P s (a -> a)
forall s a. RE s a -> P s a
re2monad RE s (a -> a)
a1 P s (a -> a) -> P s a -> P s a
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RE s a -> P s a
forall s a. RE s a -> P s a
re2monad RE s a
a2
        Fmap f :: a -> a
f a :: RE s a
a -> (a -> a) -> P s a -> P s a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> a
f (P s a -> P s a) -> P s a -> P s a
forall a b. (a -> b) -> a -> b
$ RE s a -> P s a
forall s a. RE s a -> P s a
re2monad RE s a
a
        Rep g :: Greediness
g f :: a -> a -> a
f b :: a
b a :: RE s a
a -> a -> P s a
rep a
b
            where
            am :: P s a
am = RE s a -> P s a
forall s a. RE s a -> P s a
re2monad RE s a
a
            rep :: a -> P s a
rep b :: a
b = P s a -> P s a -> P s a
combine (do a
a <- P s a
am; a -> P s a
rep (a -> P s a) -> a -> P s a
forall a b. (a -> b) -> a -> b
$ a -> a -> a
f a
b a
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 a :: P s a
a b :: P s a
b = case Greediness
g of Greedy -> P s a
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; NonGreedy -> P s a
b 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 a :: RE s a
a -> RE s a -> P s a
forall s a. RE s a -> P s a
re2monad RE s a
a P s a -> P s () -> P s ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> P s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Fail -> P s a
forall (f :: * -> *) a. Alternative f => f a
empty

runP :: P s a -> [s] -> Maybe a
runP :: P s a -> [s] -> Maybe a
runP m :: P s a
m s :: [s]
s = case ((a, [s]) -> Bool) -> [(a, [s])] -> [(a, [s])]
forall a. (a -> Bool) -> [a] -> [a]
filter ([s] -> 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
    (r :: a
r, _) : _ -> a -> Maybe a
forall a. a -> Maybe a
Just a
r
    _ -> 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 :: RE s a -> [s] -> Maybe a
reference r :: RE s a
r s :: [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