{-# LANGUAGE DeriveFoldable         #-}
{-# LANGUAGE DeriveFunctor          #-}
{-# LANGUAGE DeriveTraversable      #-}
{-# LANGUAGE FlexibleInstances      #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs                  #-}
{-# LANGUAGE Safe                   #-}
{-# LANGUAGE ScopedTypeVariables    #-}
module Kleene.Monad (
    M (..),
    -- * Construction
    --
    -- | Binary operators are
    --
    -- * '<>' for append
    --
    -- There are no binary operator for union. Use 'unions'.
    --
    empty,
    eps,
    char,
    charRange,
    anyChar,
    appends,
    unions,
    star,
    string,
    -- * Derivative
    nullable,
    derivate,
    -- * Generation
    generate,
    -- * Conversion
    toKleene,
    -- * Other
    isEmpty,
    isEps,
    ) where

import Control.Applicative (liftA2)
import Control.Monad       (ap)
import Data.Foldable       (toList)
import Data.List           (foldl')
import Data.String         (IsString (..))

import qualified Test.QuickCheck        as QC
import qualified Test.QuickCheck.Gen    as QC (unGen)
import qualified Test.QuickCheck.Random as QC (mkQCGen)

import qualified Kleene.Classes         as C
import           Kleene.Internal.Pretty

-- $setup
-- >>> :set -XOverloadedStrings
-- >>> import Data.Foldable (traverse_)
-- >>> import Data.List (sort)
-- >>> import Kleene.Internal.Pretty (putPretty)
--
-- >>> import Test.QuickCheck ((===))
-- >>> import qualified Test.QuickCheck as QC
--
-- >>> import Kleene.RE (RE)
-- >>> import Kleene.Classes (match)
-- >>> let asMBool :: M Bool -> M Bool; asMBool = id

-- | Regular expression which has no restrictions on the elements.
-- Therefore we can have 'Monad' instance, i.e. have a regexp where
-- characters are regexps themselves.
--
-- Because there are no optimisations, it's better to work over small alphabets.
-- On the other hand, we can work over infinite alphabets, if we only
-- use small amount of symbols!
--
-- >>> putPretty $ string [True, False]
-- ^10$
--
-- >>> let re  = string [True, False, True]
-- >>> let re' = re >>= \b -> if b then char () else star (char ())
-- >>> putPretty re'
-- ^..*.$
--
data M c
    = MAppend [M c]     -- ^ Concatenation
    | MUnion [c] [M c]  -- ^ Union
    | MStar (M c)       -- ^ Kleene star
  deriving (M c -> M c -> Bool
(M c -> M c -> Bool) -> (M c -> M c -> Bool) -> Eq (M c)
forall c. Eq c => M c -> M c -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall c. Eq c => M c -> M c -> Bool
== :: M c -> M c -> Bool
$c/= :: forall c. Eq c => M c -> M c -> Bool
/= :: M c -> M c -> Bool
Eq, Eq (M c)
Eq (M c) =>
(M c -> M c -> Ordering)
-> (M c -> M c -> Bool)
-> (M c -> M c -> Bool)
-> (M c -> M c -> Bool)
-> (M c -> M c -> Bool)
-> (M c -> M c -> M c)
-> (M c -> M c -> M c)
-> Ord (M c)
M c -> M c -> Bool
M c -> M c -> Ordering
M c -> M c -> M c
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall c. Ord c => Eq (M c)
forall c. Ord c => M c -> M c -> Bool
forall c. Ord c => M c -> M c -> Ordering
forall c. Ord c => M c -> M c -> M c
$ccompare :: forall c. Ord c => M c -> M c -> Ordering
compare :: M c -> M c -> Ordering
$c< :: forall c. Ord c => M c -> M c -> Bool
< :: M c -> M c -> Bool
$c<= :: forall c. Ord c => M c -> M c -> Bool
<= :: M c -> M c -> Bool
$c> :: forall c. Ord c => M c -> M c -> Bool
> :: M c -> M c -> Bool
$c>= :: forall c. Ord c => M c -> M c -> Bool
>= :: M c -> M c -> Bool
$cmax :: forall c. Ord c => M c -> M c -> M c
max :: M c -> M c -> M c
$cmin :: forall c. Ord c => M c -> M c -> M c
min :: M c -> M c -> M c
Ord, Int -> M c -> ShowS
[M c] -> ShowS
M c -> String
(Int -> M c -> ShowS)
-> (M c -> String) -> ([M c] -> ShowS) -> Show (M c)
forall c. Show c => Int -> M c -> ShowS
forall c. Show c => [M c] -> ShowS
forall c. Show c => M c -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall c. Show c => Int -> M c -> ShowS
showsPrec :: Int -> M c -> ShowS
$cshow :: forall c. Show c => M c -> String
show :: M c -> String
$cshowList :: forall c. Show c => [M c] -> ShowS
showList :: [M c] -> ShowS
Show, (forall a b. (a -> b) -> M a -> M b)
-> (forall a b. a -> M b -> M a) -> Functor M
forall a b. a -> M b -> M a
forall a b. (a -> b) -> M a -> M b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> M a -> M b
fmap :: forall a b. (a -> b) -> M a -> M b
$c<$ :: forall a b. a -> M b -> M a
<$ :: forall a b. a -> M b -> M a
Functor, (forall m. Monoid m => M m -> m)
-> (forall m a. Monoid m => (a -> m) -> M a -> m)
-> (forall m a. Monoid m => (a -> m) -> M a -> m)
-> (forall a b. (a -> b -> b) -> b -> M a -> b)
-> (forall a b. (a -> b -> b) -> b -> M a -> b)
-> (forall b a. (b -> a -> b) -> b -> M a -> b)
-> (forall b a. (b -> a -> b) -> b -> M a -> b)
-> (forall a. (a -> a -> a) -> M a -> a)
-> (forall a. (a -> a -> a) -> M a -> a)
-> (forall a. M a -> [a])
-> (forall a. M a -> Bool)
-> (forall a. M a -> Int)
-> (forall a. Eq a => a -> M a -> Bool)
-> (forall a. Ord a => M a -> a)
-> (forall a. Ord a => M a -> a)
-> (forall a. Num a => M a -> a)
-> (forall a. Num a => M a -> a)
-> Foldable M
forall a. Eq a => a -> M a -> Bool
forall a. Num a => M a -> a
forall a. Ord a => M a -> a
forall m. Monoid m => M m -> m
forall a. M a -> Bool
forall a. M a -> Int
forall a. M a -> [a]
forall a. (a -> a -> a) -> M a -> a
forall m a. Monoid m => (a -> m) -> M a -> m
forall b a. (b -> a -> b) -> b -> M a -> b
forall a b. (a -> b -> b) -> b -> M a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => M m -> m
fold :: forall m. Monoid m => M m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> M a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> M a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> M a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> M a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> M a -> b
foldr :: forall a b. (a -> b -> b) -> b -> M a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> M a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> M a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> M a -> b
foldl :: forall b a. (b -> a -> b) -> b -> M a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> M a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> M a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> M a -> a
foldr1 :: forall a. (a -> a -> a) -> M a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> M a -> a
foldl1 :: forall a. (a -> a -> a) -> M a -> a
$ctoList :: forall a. M a -> [a]
toList :: forall a. M a -> [a]
$cnull :: forall a. M a -> Bool
null :: forall a. M a -> Bool
$clength :: forall a. M a -> Int
length :: forall a. M a -> Int
$celem :: forall a. Eq a => a -> M a -> Bool
elem :: forall a. Eq a => a -> M a -> Bool
$cmaximum :: forall a. Ord a => M a -> a
maximum :: forall a. Ord a => M a -> a
$cminimum :: forall a. Ord a => M a -> a
minimum :: forall a. Ord a => M a -> a
$csum :: forall a. Num a => M a -> a
sum :: forall a. Num a => M a -> a
$cproduct :: forall a. Num a => M a -> a
product :: forall a. Num a => M a -> a
Foldable, Functor M
Foldable M
(Functor M, Foldable M) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> M a -> f (M b))
-> (forall (f :: * -> *) a. Applicative f => M (f a) -> f (M a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> M a -> m (M b))
-> (forall (m :: * -> *) a. Monad m => M (m a) -> m (M a))
-> Traversable M
forall (t :: * -> *).
(Functor t, Foldable t) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => M (m a) -> m (M a)
forall (f :: * -> *) a. Applicative f => M (f a) -> f (M a)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> M a -> m (M b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> M a -> f (M b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> M a -> f (M b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> M a -> f (M b)
$csequenceA :: forall (f :: * -> *) a. Applicative f => M (f a) -> f (M a)
sequenceA :: forall (f :: * -> *) a. Applicative f => M (f a) -> f (M a)
$cmapM :: forall (m :: * -> *) a b. Monad m => (a -> m b) -> M a -> m (M b)
mapM :: forall (m :: * -> *) a b. Monad m => (a -> m b) -> M a -> m (M b)
$csequence :: forall (m :: * -> *) a. Monad m => M (m a) -> m (M a)
sequence :: forall (m :: * -> *) a. Monad m => M (m a) -> m (M a)
Traversable)

instance Applicative M where
    pure :: forall a. a -> M a
pure = a -> M a
forall a. a -> M a
char
    <*> :: forall a b. M (a -> b) -> M a -> M b
(<*>) = M (a -> b) -> M a -> M b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad M where
    return :: forall a. a -> M a
return = a -> M a
forall a. a -> M a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

    MAppend [M a]
rs   >>= :: forall a b. M a -> (a -> M b) -> M b
>>= a -> M b
k  = [M b] -> M b
forall c. [M c] -> M c
appends ((M a -> M b) -> [M a] -> [M b]
forall a b. (a -> b) -> [a] -> [b]
map (M a -> (a -> M b) -> M b
forall a b. M a -> (a -> M b) -> M b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> M b
k) [M a]
rs)
    MUnion [a]
cs [M a]
rs >>= a -> M b
k  = [M b] -> M b
forall c. [M c] -> M c
unions ([M b] -> M b
forall c. [M c] -> M c
appends ((a -> M b) -> [a] -> [M b]
forall a b. (a -> b) -> [a] -> [b]
map a -> M b
k [a]
cs) M b -> [M b] -> [M b]
forall a. a -> [a] -> [a]
: (M a -> M b) -> [M a] -> [M b]
forall a b. (a -> b) -> [a] -> [b]
map (M a -> (a -> M b) -> M b
forall a b. M a -> (a -> M b) -> M b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> M b
k) [M a]
rs)
    MStar M a
r      >>= a -> M b
k  = M b -> M b
forall c. M c -> M c
star (M a
r M a -> (a -> M b) -> M b
forall a b. M a -> (a -> M b) -> M b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> M b
k)

-------------------------------------------------------------------------------
-- Smart constructor
-------------------------------------------------------------------------------

-- | Empty regex. Doesn't accept anything.
--
-- >>> putPretty (empty :: M Bool)
-- ^[]$
--
-- prop> match (empty :: M Char) (s :: String) === False
--
empty :: M c
empty :: forall c. M c
empty = [c] -> [M c] -> M c
forall c. [c] -> [M c] -> M c
MUnion [] []

-- | Empty string. /Note:/ different than 'empty'.
--
-- >>> putPretty (eps :: M Bool)
-- ^$
--
-- >>> putPretty (mempty :: M Bool)
-- ^$
--
-- prop> match (eps :: M Char) s === null (s :: String)
--
eps :: M c
eps :: forall c. M c
eps = [M c] -> M c
forall c. [M c] -> M c
MAppend []

-- |
--
-- >>> putPretty (char 'x')
-- ^x$
--
char :: c -> M c
char :: forall a. a -> M a
char c
c = [c] -> [M c] -> M c
forall c. [c] -> [M c] -> M c
MUnion [c
c] []

-- | /Note:/ we know little about @c@.
--
-- >>> putPretty $ charRange 'a' 'z'
-- ^[abcdefghijklmnopqrstuvwxyz]$
--
charRange :: Enum c => c -> c -> M c
charRange :: forall c. Enum c => c -> c -> M c
charRange c
c c
c' = [c] -> [M c] -> M c
forall c. [c] -> [M c] -> M c
MUnion [c
c .. c
c'] []


-- | Any character. /Note:/ different than dot!
--
-- >>> putPretty (anyChar :: M Bool)
-- ^[01]$
--
anyChar :: (Bounded c, Enum c) => M c
anyChar :: forall c. (Bounded c, Enum c) => M c
anyChar = [c] -> [M c] -> M c
forall c. [c] -> [M c] -> M c
MUnion [c
forall a. Bounded a => a
minBound .. c
forall a. Bounded a => a
maxBound] []

-- | Concatenate regular expressions.
--
appends :: [M c] -> M c
appends :: forall c. [M c] -> M c
appends [M c]
rs0
    | (M c -> Bool) -> [M c] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any M c -> Bool
forall a. M a -> Bool
isEmpty [M c]
rs1 = M c
forall c. M c
empty
    | Bool
otherwise = case [M c]
rs1 of
        [M c
r] -> M c
r
        [M c]
rs  -> [M c] -> M c
forall c. [M c] -> M c
MAppend [M c]
rs
  where
    -- flatten one level of MAppend
    rs1 :: [M c]
rs1 = (M c -> [M c]) -> [M c] -> [M c]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap M c -> [M c]
forall {c}. M c -> [M c]
f [M c]
rs0

    f :: M c -> [M c]
f (MAppend [M c]
rs) = [M c]
rs
    f M c
r             = [M c
r]

-- | Union of regular expressions.
--
-- Lattice laws don't hold structurally:
--
unions :: [M c] -> M c
unions :: forall c. [M c] -> M c
unions = ([c] -> [M c] -> M c) -> ([c], [M c]) -> M c
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [c] -> [M c] -> M c
forall c. [c] -> [M c] -> M c
mk (([c], [M c]) -> M c) -> ([M c] -> ([c], [M c])) -> [M c] -> M c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (M c -> ([c], [M c])) -> [M c] -> ([c], [M c])
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap M c -> ([c], [M c])
forall {c}. M c -> ([c], [M c])
f where
    f :: M c -> ([c], [M c])
f (MUnion [c]
cs [M c]
rs) = ([c]
cs, [M c]
rs)
    f M c
r              = ([], [M c
r])

    mk :: [c] -> [M c] -> M c
mk [] [M c
r] = M c
r
    mk [c]
cs [M c]
rs = [c] -> [M c] -> M c
forall c. [c] -> [M c] -> M c
MUnion [c]
cs [M c]
rs

-- | Kleene star.
--
star :: M c -> M c
star :: forall c. M c -> M c
star M c
r = case M c
r of
    MStar M c
_                    -> M c
r
    MAppend []                 -> M c
forall c. M c
eps
    MUnion [c]
cs [M c]
rs | (M c -> Bool) -> [M c] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any M c -> Bool
forall a. M a -> Bool
isEps [M c]
rs -> case [M c]
rs' of
        [M c
r'] | [c] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [c]
cs -> M c -> M c
forall c. M c -> M c
star M c
r'
        [M c]
_              -> M c -> M c
forall c. M c -> M c
MStar ([c] -> [M c] -> M c
forall c. [c] -> [M c] -> M c
MUnion [c]
cs [M c]
rs')
      where
        rs' :: [M c]
rs' = (M c -> Bool) -> [M c] -> [M c]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (M c -> Bool) -> M c -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. M c -> Bool
forall a. M a -> Bool
isEps) [M c]
rs
    M c
_                          -> M c -> M c
forall c. M c -> M c
MStar M c
r

-- | Literal string.
--
-- >>> putPretty ("foobar" :: M Char)
-- ^foobar$
--
-- >>> putPretty ("(.)" :: M Char)
-- ^\(\.\)$
--
-- >>> putPretty $ string [False, True]
-- ^01$
--
string :: [c] -> M c
string :: forall c. [c] -> M c
string []  = M c
forall c. M c
eps
string [c
c] = c -> M c
forall a. a -> M a
char c
c
string [c]
cs  = [M c] -> M c
forall c. [M c] -> M c
MAppend ([M c] -> M c) -> [M c] -> M c
forall a b. (a -> b) -> a -> b
$ (c -> M c) -> [c] -> [M c]
forall a b. (a -> b) -> [a] -> [b]
map c -> M c
forall a. a -> M a
char [c]
cs

instance C.Kleene  (M c) where
    empty :: M c
empty      = M c
forall c. M c
empty
    eps :: M c
eps        = M c
forall c. M c
eps
    appends :: [M c] -> M c
appends    = [M c] -> M c
forall c. [M c] -> M c
appends
    unions :: [M c] -> M c
unions     = [M c] -> M c
forall c. [M c] -> M c
unions
    star :: M c -> M c
star       = M c -> M c
forall c. M c -> M c
star

instance C.CharKleene c (M c) where
    char :: c -> M c
char       = c -> M c
forall a. a -> M a
char

-------------------------------------------------------------------------------
-- derivative
-------------------------------------------------------------------------------

-- | We say that a regular expression r is nullable if the language it defines
-- contains the empty string.
--
-- >>> nullable eps
-- True
--
-- >>> nullable (star "x")
-- True
--
-- >>> nullable "foo"
-- False
--
nullable :: M c -> Bool
nullable :: forall a. M a -> Bool
nullable (MAppend [M c]
rs)    = (M c -> Bool) -> [M c] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all M c -> Bool
forall a. M a -> Bool
nullable [M c]
rs
nullable (MUnion [c]
_cs [M c]
rs) = (M c -> Bool) -> [M c] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any M c -> Bool
forall a. M a -> Bool
nullable [M c]
rs
nullable (MStar M c
_)       = Bool
True

-- | Intuitively, the derivative of a language \(\mathcal{L} \subset \Sigma^\star\)
-- with respect to a symbol \(a \in \Sigma\) is the language that includes only
-- those suffixes of strings with a leading symbol \(a\) in \(\mathcal{L}\).
--
-- >>> putPretty $ derivate 'f' "foobar"
-- ^oobar$
--
-- >>> putPretty $ derivate 'x' $ unions ["xyz", "abc"]
-- ^yz$
--
-- >>> putPretty $ derivate 'x' $ star "xyz"
-- ^yz(xyz)*$
--
derivate :: (Eq c, Enum c, Bounded c) => c -> M c -> M c
derivate :: forall c. (Eq c, Enum c, Bounded c) => c -> M c -> M c
derivate c
c (MUnion [c]
cs [M c]
rs)  = [M c] -> M c
forall c. [M c] -> M c
unions ([M c] -> M c) -> [M c] -> M c
forall a b. (a -> b) -> a -> b
$ c -> [c] -> M c
forall c. Eq c => c -> [c] -> M c
derivateChars c
c [c]
cs M c -> [M c] -> [M c]
forall a. a -> [a] -> [a]
: [ c -> M c -> M c
forall c. (Eq c, Enum c, Bounded c) => c -> M c -> M c
derivate c
c M c
r | M c
r <- [M c] -> [M c]
forall a. [a] -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList [M c]
rs]
derivate c
c (MAppend [M c]
rs)    = c -> [M c] -> M c
forall c. (Eq c, Enum c, Bounded c) => c -> [M c] -> M c
derivateAppend c
c [M c]
rs
derivate c
c rs :: M c
rs@(MStar M c
r)    = c -> M c -> M c
forall c. (Eq c, Enum c, Bounded c) => c -> M c -> M c
derivate c
c M c
r M c -> M c -> M c
forall a. Semigroup a => a -> a -> a
<> M c
rs

derivateAppend :: (Eq c, Enum c, Bounded c) => c -> [M c] -> M c
derivateAppend :: forall c. (Eq c, Enum c, Bounded c) => c -> [M c] -> M c
derivateAppend c
_ []      = M c
forall c. M c
empty
derivateAppend c
c [M c
r]     = c -> M c -> M c
forall c. (Eq c, Enum c, Bounded c) => c -> M c -> M c
derivate c
c M c
r
derivateAppend c
c (M c
r:[M c]
rs)
    | M c -> Bool
forall a. M a -> Bool
nullable M c
r         = [M c] -> M c
forall c. [M c] -> M c
unions [M c
r' M c -> M c -> M c
forall a. Semigroup a => a -> a -> a
<> [M c] -> M c
forall c. [M c] -> M c
appends [M c]
rs, M c
rs']
    | Bool
otherwise          = M c
r' M c -> M c -> M c
forall a. Semigroup a => a -> a -> a
<> [M c] -> M c
forall c. [M c] -> M c
appends [M c]
rs
  where
    r' :: M c
r'  = c -> M c -> M c
forall c. (Eq c, Enum c, Bounded c) => c -> M c -> M c
derivate c
c M c
r
    rs' :: M c
rs' = c -> [M c] -> M c
forall c. (Eq c, Enum c, Bounded c) => c -> [M c] -> M c
derivateAppend c
c [M c]
rs

derivateChars :: Eq c =>  c -> [c] -> M c
derivateChars :: forall c. Eq c => c -> [c] -> M c
derivateChars c
c [c]
cs
    | c
c c -> [c] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [c]
cs = M c
forall c. M c
eps
    | Bool
otherwise   = M c
forall c. M c
empty

instance (Eq c, Enum c, Bounded c) => C.Derivate c (M c) where
    nullable :: M c -> Bool
nullable = M c -> Bool
forall a. M a -> Bool
nullable
    derivate :: c -> M c -> M c
derivate = c -> M c -> M c
forall c. (Eq c, Enum c, Bounded c) => c -> M c -> M c
derivate

instance (Eq c, Enum c, Bounded c) => C.Match c (M c) where
    match :: M c -> [c] -> Bool
match M c
r = M c -> Bool
forall a. M a -> Bool
nullable (M c -> Bool) -> ([c] -> M c) -> [c] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (M c -> c -> M c) -> M c -> [c] -> M c
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((c -> M c -> M c) -> M c -> c -> M c
forall a b c. (a -> b -> c) -> b -> a -> c
flip c -> M c -> M c
forall c. (Eq c, Enum c, Bounded c) => c -> M c -> M c
derivate) M c
r

-------------------------------------------------------------------------------
-- isEmpty
-------------------------------------------------------------------------------

-- | Whether 'M' is (structurally) equal to 'empty'.
isEmpty :: M c -> Bool
isEmpty :: forall a. M a -> Bool
isEmpty (MUnion [c]
cs [M c]
rs) = [c] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [c]
cs Bool -> Bool -> Bool
&& [M c] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [M c]
rs
isEmpty M c
_              = Bool
False

-- | Whether 'M' is (structurally) equal to 'eps'.
isEps :: M c -> Bool
isEps :: forall a. M a -> Bool
isEps (MAppend [M c]
rs) = [M c] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [M c]
rs
isEps M c
_            = Bool
False

-------------------------------------------------------------------------------
-- Generation
-------------------------------------------------------------------------------

-- | Generate random strings of the language @M c@ describes.
--
-- >>> let example = traverse_ print . take 3 . generate 42
-- >>> example "abc"
-- "abc"
-- "abc"
-- "abc"
--
-- >>> example $ star $ unions ["a", "b"]
-- ""
-- "aaababaaab"
-- "a"
--
-- xx >>> example empty
--
-- expensive-prop> all (match r) $ take 10 $ generate 42 (r :: M Bool)
--
generate
    :: Int    -- ^ seed
    -> M c
    -> [[c]]  -- ^ infinite list of results
generate :: forall c. Int -> M c -> [[c]]
generate Int
seed M c
re
    | M c -> Bool
forall a. M a -> Bool
isEmpty M c
re = []
    | Bool
otherwise  = Gen [[c]] -> QCGen -> Int -> [[c]]
forall a. Gen a -> QCGen -> Int -> a
QC.unGen (Gen [c] -> Gen [[c]]
forall a. Gen a -> Gen [a]
QC.infiniteListOf (M c -> Gen [c]
forall c. M c -> Gen [c]
generator M c
re)) (Int -> QCGen
QC.mkQCGen Int
seed) Int
10

generator :: M c -> QC.Gen [c]
generator :: forall c. M c -> Gen [c]
generator = M c -> Gen [c]
forall c. M c -> Gen [c]
go where
    go :: M a -> Gen [a]
go (MAppend [M a]
rs)   = [[a]] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[a]] -> [a]) -> Gen [[a]] -> Gen [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (M a -> Gen [a]) -> [M a] -> Gen [[a]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse M a -> Gen [a]
go [M a]
rs
    go (MUnion [a]
cs [M a]
rs)
        | [a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
cs   = [Gen [a]] -> Gen [a]
forall a. [Gen a] -> Gen a
QC.oneof [ M a -> Gen [a]
go M a
r | M a
r <- [M a] -> [M a]
forall a. [a] -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList [M a]
rs ]
        | Bool
otherwise = [Gen [a]] -> Gen [a]
forall a. [Gen a] -> Gen a
QC.oneof ([Gen [a]] -> Gen [a]) -> [Gen [a]] -> Gen [a]
forall a b. (a -> b) -> a -> b
$ [a] -> Gen [a]
forall {f :: * -> *} {a}. Applicative f => [a] -> Gen (f a)
goChars [a]
cs Gen [a] -> [Gen [a]] -> [Gen [a]]
forall a. a -> [a] -> [a]
: [ M a -> Gen [a]
go M a
r | M a
r <- [M a] -> [M a]
forall a. [a] -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList [M a]
rs ]
    go (MStar M a
r)      = (Int -> Gen [a]) -> Gen [a]
forall a. (Int -> Gen a) -> Gen a
QC.sized ((Int -> Gen [a]) -> Gen [a]) -> (Int -> Gen [a]) -> Gen [a]
forall a b. (a -> b) -> a -> b
$ \Int
n -> do
        Int
n' <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
QC.choose (Int
0, Int
n)
        [[a]] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[a]] -> [a]) -> Gen [[a]] -> Gen [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Gen [a]] -> Gen [[a]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence (Int -> Gen [a] -> [Gen [a]]
forall a. Int -> a -> [a]
replicate Int
n' (M a -> Gen [a]
go M a
r))

    goChars :: [a] -> Gen (f a)
goChars [a]
cs = a -> f a
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> f a) -> Gen a -> Gen (f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a] -> Gen a
forall a. [a] -> Gen a
QC.elements [a]
cs

-------------------------------------------------------------------------------
-- Conversion
-------------------------------------------------------------------------------

-- | Convert to 'Kleene'
--
-- >>> let re = charRange 'a' 'z'
-- >>> putPretty re
-- ^[abcdefghijklmnopqrstuvwxyz]$
--
-- >>> putPretty (toKleene re :: RE Char)
-- ^[a-z]$
--
toKleene :: C.CharKleene c k => M c -> k
toKleene :: forall c k. CharKleene c k => M c -> k
toKleene (MAppend [M c]
rs)   = [k] -> k
forall k. Kleene k => [k] -> k
C.appends ((M c -> k) -> [M c] -> [k]
forall a b. (a -> b) -> [a] -> [b]
map M c -> k
forall c k. CharKleene c k => M c -> k
toKleene [M c]
rs)
toKleene (MUnion [c]
cs [M c]
rs) = [k] -> k
forall k. Kleene k => [k] -> k
C.unions ([c] -> k
forall c k (f :: * -> *). (CharKleene c k, Foldable f) => f c -> k
C.oneof [c]
cs k -> [k] -> [k]
forall a. a -> [a] -> [a]
: (M c -> k) -> [M c] -> [k]
forall a b. (a -> b) -> [a] -> [b]
map M c -> k
forall c k. CharKleene c k => M c -> k
toKleene [M c]
rs)
toKleene (MStar M c
r)      = k -> k
forall k. Kleene k => k -> k
C.star (M c -> k
forall c k. CharKleene c k => M c -> k
toKleene M c
r)

-------------------------------------------------------------------------------
-- Instances
-------------------------------------------------------------------------------

instance Semigroup (M c) where
    M c
r <> :: M c -> M c -> M c
<> M c
r' = [M c] -> M c
forall c. [M c] -> M c
appends [M c
r, M c
r']

instance Monoid (M c) where
    mempty :: M c
mempty  = M c
forall c. M c
eps
    mappend :: M c -> M c -> M c
mappend = M c -> M c -> M c
forall a. Semigroup a => a -> a -> a
(<>)
    mconcat :: [M c] -> M c
mconcat = [M c] -> M c
forall c. [M c] -> M c
appends

instance c ~ Char => IsString (M c) where
    fromString :: String -> M c
fromString = String -> M c
String -> M Char
forall c. [c] -> M c
string

instance (Eq c, Enum c, Bounded c, QC.Arbitrary c) => QC.Arbitrary (M c) where
    arbitrary :: Gen (M c)
arbitrary = (Int -> Gen (M c)) -> Gen (M c)
forall a. (Int -> Gen a) -> Gen a
QC.sized Int -> Gen (M c)
arb where
        c :: QC.Gen (M c)
        c :: Gen (M c)
c = c -> M c
forall a. a -> M a
char (c -> M c) -> Gen c -> Gen (M c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen c
forall a. Arbitrary a => Gen a
QC.arbitrary

        arb :: Int -> QC.Gen (M c)
        arb :: Int -> Gen (M c)
arb Int
n | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0    = [Gen (M c)] -> Gen (M c)
forall a. [Gen a] -> Gen a
QC.oneof [Gen (M c)
c, (c -> M c) -> Gen c -> Gen (M c)
forall a b. (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap c -> M c
forall a. a -> M a
char Gen c
forall a. Arbitrary a => Gen a
QC.arbitrary, M c -> Gen (M c)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure M c
forall c. M c
eps]
              | Bool
otherwise = [Gen (M c)] -> Gen (M c)
forall a. [Gen a] -> Gen a
QC.oneof
            [ Gen (M c)
c
            , M c -> Gen (M c)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure M c
forall c. M c
eps
            , (c -> M c) -> Gen c -> Gen (M c)
forall a b. (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap c -> M c
forall a. a -> M a
char Gen c
forall a. Arbitrary a => Gen a
QC.arbitrary
            , (M c -> M c -> M c) -> Gen (M c) -> Gen (M c) -> Gen (M c)
forall a b c. (a -> b -> c) -> Gen a -> Gen b -> Gen c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 M c -> M c -> M c
forall a. Semigroup a => a -> a -> a
(<>) (Int -> Gen (M c)
arb Int
n2) (Int -> Gen (M c)
arb Int
n2)
            , (M c -> M c -> M c) -> Gen (M c) -> Gen (M c) -> Gen (M c)
forall a b c. (a -> b -> c) -> Gen a -> Gen b -> Gen c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (\M c
x M c
y -> [M c] -> M c
forall c. [M c] -> M c
unions [M c
x,M c
y]) (Int -> Gen (M c)
arb Int
n2) (Int -> Gen (M c)
arb Int
n2)
            , (M c -> M c) -> Gen (M c) -> Gen (M c)
forall a b. (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap M c -> M c
forall c. M c -> M c
star (Int -> Gen (M c)
arb Int
n2)
            ]
          where
            n2 :: Int
n2 = Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2

instance (QC.CoArbitrary c) => QC.CoArbitrary (M c) where
    coarbitrary :: forall b. M c -> Gen b -> Gen b
coarbitrary (MAppend [M c]
rs)   = Int -> Gen b -> Gen b
forall n a. Integral n => n -> Gen a -> Gen a
QC.variant (Int
1 :: Int) (Gen b -> Gen b) -> (Gen b -> Gen b) -> Gen b -> Gen b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [M c] -> Gen b -> Gen b
forall b. [M c] -> Gen b -> Gen b
forall a b. CoArbitrary a => a -> Gen b -> Gen b
QC.coarbitrary [M c]
rs
    coarbitrary (MUnion [c]
cs [M c]
rs) = Int -> Gen b -> Gen b
forall n a. Integral n => n -> Gen a -> Gen a
QC.variant (Int
2 :: Int) (Gen b -> Gen b) -> (Gen b -> Gen b) -> Gen b -> Gen b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([c], [M c]) -> Gen b -> Gen b
forall b. ([c], [M c]) -> Gen b -> Gen b
forall a b. CoArbitrary a => a -> Gen b -> Gen b
QC.coarbitrary ([c]
cs, [M c]
rs)
    coarbitrary (MStar M c
r)      = Int -> Gen b -> Gen b
forall n a. Integral n => n -> Gen a -> Gen a
QC.variant (Int
3 :: Int) (Gen b -> Gen b) -> (Gen b -> Gen b) -> Gen b -> Gen b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. M c -> Gen b -> Gen b
forall a b. CoArbitrary a => a -> Gen b -> Gen b
forall b. M c -> Gen b -> Gen b
QC.coarbitrary M c
r

-------------------------------------------------------------------------------
-- JavaScript
-------------------------------------------------------------------------------

instance (Pretty c, Eq c) => Pretty (M c) where
    prettyS :: M c -> ShowS
prettyS M c
x = Char -> ShowS
showChar Char
'^' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> M c -> ShowS
go Bool
False M c
x ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
'$'
      where
        go :: Bool -> M c -> ShowS
        go :: Bool -> M c -> ShowS
go Bool
p (MStar M c
a)
            = Bool -> ShowS -> ShowS
parens Bool
p
            (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Bool -> M c -> ShowS
go Bool
True M c
a ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
'*'
        go Bool
p (MAppend [M c]
rs)
            = Bool -> ShowS -> ShowS
parens Bool
p (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ShowS -> [M c] -> ShowS
goMany ShowS
forall a. a -> a
id [M c]
rs
        go Bool
p (MUnion [c]
cs [M c]
rs)
            | [M c] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [M c]
rs   = [c] -> ShowS
prettySList [c]
cs
            | [c] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [c]
cs   = Bool -> [M c] -> ShowS
goUnion Bool
p [M c]
rs
            | Bool
otherwise = Bool -> [M c] -> ShowS
goUnion Bool
p ([c] -> [M c] -> M c
forall c. [c] -> [M c] -> M c
MUnion [c]
cs [] M c -> [M c] -> [M c]
forall a. a -> [a] -> [a]
: [M c]
rs)

        goUnion :: Bool -> [M c] -> ShowS
goUnion Bool
p [M c]
rs
            | M c -> [M c] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem M c
forall c. M c
eps [M c]
rs = Bool -> ShowS -> ShowS
parens Bool
p (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Bool -> ShowS
goUnion' Bool
True ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
'?'
            | Bool
otherwise   = Bool -> ShowS
goUnion' Bool
p
          where
            goUnion' :: Bool -> ShowS
goUnion' Bool
p' = case (M c -> Bool) -> [M c] -> [M c]
forall a. (a -> Bool) -> [a] -> [a]
filter (M c -> M c -> Bool
forall a. Eq a => a -> a -> Bool
/= M c
forall c. M c
eps) [M c]
rs of
                []      -> Bool -> M c -> ShowS
go Bool
True M c
forall c. M c
empty
                [M c
r]     -> Bool -> M c -> ShowS
go Bool
p' M c
r
                (M c
r:[M c]
rs') -> Bool -> ShowS -> ShowS
parens Bool
True (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ShowS -> M c -> [M c] -> ShowS
goSome1 (Char -> ShowS
showChar Char
'|') M c
r [M c]
rs'

        goMany :: ShowS -> [M c] -> ShowS
        goMany :: ShowS -> [M c] -> ShowS
goMany ShowS
sep = (M c -> ShowS -> ShowS) -> ShowS -> [M c] -> ShowS
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\M c
a ShowS
b -> Bool -> M c -> ShowS
go Bool
False M c
a ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
sep ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
b) ShowS
forall a. a -> a
id

        goSome1 :: ShowS -> M c -> [M c] -> ShowS
        goSome1 :: ShowS -> M c -> [M c] -> ShowS
goSome1 ShowS
sep M c
r = (ShowS -> M c -> ShowS) -> ShowS -> [M c] -> ShowS
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\ShowS
a M c
b -> ShowS
a ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
sep ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> M c -> ShowS
go Bool
False M c
b) (Bool -> M c -> ShowS
go Bool
False M c
r)

        parens :: Bool -> ShowS -> ShowS
        parens :: Bool -> ShowS -> ShowS
parens Bool
True  ShowS
s = String -> ShowS
showString String
"(" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
s ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
')'
        parens Bool
False ShowS
s = ShowS
s

        prettySList :: [c] -> ShowS
        prettySList :: [c] -> ShowS
prettySList [c
c] = c -> ShowS
forall a. Pretty a => a -> ShowS
prettyS c
c
        prettySList [c]
xs  = Char -> ShowS
showChar Char
'[' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (c -> ShowS -> ShowS) -> ShowS -> [c] -> ShowS
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\c
a ShowS
b -> c -> ShowS
forall a. Pretty a => a -> ShowS
prettyS c
a ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
b) (Char -> ShowS
showChar Char
']') [c]
xs