{-# LANGUAGE BangPatterns           #-}
{-# LANGUAGE FlexibleInstances      #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs                  #-}
{-# LANGUAGE Safe                   #-}
{-# LANGUAGE ScopedTypeVariables    #-}
{-# OPTIONS_HADDOCK not-home #-}
module Kleene.Internal.RE (
    RE (..),
    -- * Construction
    --
    -- | Binary operators are
    --
    -- * '<>' for append
    -- * '\/' for union
    --
    empty,
    eps,
    everything,
    char,
    charRange,
    anyChar,
    appends,
    unions,
    star,
    string,
    -- * Derivative
    nullable,
    derivate,
    -- * Transition map
    transitionMap,
    leadingChars,
    -- * Equivalence
    equivalent,
    -- * Generation
    generate,
    -- * Other
    isEmpty,
    nullableProof,
    ) where

import Control.Applicative (liftA2)
import Data.Foldable       (toList)
import Data.List           (foldl')
import Data.Map            (Map)
import Data.RangeSet.Map   (RSet)
import Data.Set            (Set)
import Data.String         (IsString (..))

import qualified Data.Function.Step.Discrete.Closed as SF
import qualified Data.Map                           as Map
import qualified Data.RangeSet.Map                  as RSet
import qualified Data.Set                           as Set
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 qualified Kleene.Internal.Partition as P
import           Kleene.Internal.Pretty

-- $setup
-- >>> :set -XOverloadedStrings
-- >>> import Control.Monad (void)
-- >>> import Data.Foldable (traverse_)
-- >>> import Data.List (sort)
-- >>> import Data.Maybe (isJust)
-- >>> import Data.Semigroup (Semigroup (..))
--
-- >>> import Test.QuickCheck ((===))
-- >>> import qualified Test.QuickCheck as QC
-- >>> import qualified Data.Map as Map
-- >>> import qualified Data.Function.Step.Discrete.Closed as SF
--
-- >>> import Kleene.Classes (match)
-- >>> import Kleene.Internal.Pretty (putPretty, pretty)
-- >>> import Algebra.Lattice (bottom, (\/))
-- >>> import Kleene.RE ()
--
-- >>> let asREChar :: RE Char -> RE Char; asREChar = id

-------------------------------------------------------------------------------
-- RE
-------------------------------------------------------------------------------

-- | Regular expression
--
-- Constructors are exposed, but you should use
-- smart constructors in this module to construct 'RE'.
--
-- The 'Eq' and 'Ord' instances are structural.
-- The 'Kleene' etc constructors do "weak normalisation", so for values
-- constructed using those operations 'Eq' witnesses "weak equivalence".
-- See 'equivalent' for regular-expression equivalence.
--
-- Structure is exposed in "Kleene.RE" module but consider constructors as
-- half-internal.  There are soft-invariants, but violating them shouldn't
-- break anything in the package. (e.g. 'transitionMap' will eventually
-- terminate, but may create more redundant states if starting regexp is not
-- "weakly normalised").
--
data RE c
    = REChars (RSet c)               -- ^ Single character
    | REAppend [RE c]                -- ^ Concatenation
    | REUnion (RSet c) (Set (RE c))  -- ^ Union
    | REStar (RE c)                  -- ^ Kleene star
  deriving (RE c -> RE c -> Bool
(RE c -> RE c -> Bool) -> (RE c -> RE c -> Bool) -> Eq (RE c)
forall c. Eq c => RE c -> RE c -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall c. Eq c => RE c -> RE c -> Bool
== :: RE c -> RE c -> Bool
$c/= :: forall c. Eq c => RE c -> RE c -> Bool
/= :: RE c -> RE c -> Bool
Eq, Eq (RE c)
Eq (RE c) =>
(RE c -> RE c -> Ordering)
-> (RE c -> RE c -> Bool)
-> (RE c -> RE c -> Bool)
-> (RE c -> RE c -> Bool)
-> (RE c -> RE c -> Bool)
-> (RE c -> RE c -> RE c)
-> (RE c -> RE c -> RE c)
-> Ord (RE c)
RE c -> RE c -> Bool
RE c -> RE c -> Ordering
RE c -> RE c -> RE 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 (RE c)
forall c. Ord c => RE c -> RE c -> Bool
forall c. Ord c => RE c -> RE c -> Ordering
forall c. Ord c => RE c -> RE c -> RE c
$ccompare :: forall c. Ord c => RE c -> RE c -> Ordering
compare :: RE c -> RE c -> Ordering
$c< :: forall c. Ord c => RE c -> RE c -> Bool
< :: RE c -> RE c -> Bool
$c<= :: forall c. Ord c => RE c -> RE c -> Bool
<= :: RE c -> RE c -> Bool
$c> :: forall c. Ord c => RE c -> RE c -> Bool
> :: RE c -> RE c -> Bool
$c>= :: forall c. Ord c => RE c -> RE c -> Bool
>= :: RE c -> RE c -> Bool
$cmax :: forall c. Ord c => RE c -> RE c -> RE c
max :: RE c -> RE c -> RE c
$cmin :: forall c. Ord c => RE c -> RE c -> RE c
min :: RE c -> RE c -> RE c
Ord, Int -> RE c -> ShowS
[RE c] -> ShowS
RE c -> String
(Int -> RE c -> ShowS)
-> (RE c -> String) -> ([RE c] -> ShowS) -> Show (RE c)
forall c. Show c => Int -> RE c -> ShowS
forall c. Show c => [RE c] -> ShowS
forall c. Show c => RE c -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall c. Show c => Int -> RE c -> ShowS
showsPrec :: Int -> RE c -> ShowS
$cshow :: forall c. Show c => RE c -> String
show :: RE c -> String
$cshowList :: forall c. Show c => [RE c] -> ShowS
showList :: [RE c] -> ShowS
Show)

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

-- | Empty regex. Doesn't accept anything.
--
-- >>> putPretty (empty :: RE Char)
-- ^[]$
--
-- >>> putPretty (bottom :: RE Char)
-- ^[]$
--
-- prop> match (empty :: RE Char) (s :: String) === False
--
empty :: RE c
empty :: forall c. RE c
empty = RSet c -> RE c
forall c. RSet c -> RE c
REChars RSet c
forall a. RSet a
RSet.empty

-- | Everything.
--
-- >>> putPretty everything
-- ^[^]*$
--
-- prop> match (everything :: RE Char) (s :: String) === True
--
everything :: Bounded c => RE c
everything :: forall c. Bounded c => RE c
everything = RE c -> RE c
forall c. RE c -> RE c
REStar (RSet c -> RE c
forall c. RSet c -> RE c
REChars RSet c
forall a. Bounded a => RSet a
RSet.full)

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

-- |
--
-- >>> putPretty (char 'x')
-- ^x$
--
char :: c -> RE c
char :: forall c. c -> RE c
char = RSet c -> RE c
forall c. RSet c -> RE c
REChars (RSet c -> RE c) -> (c -> RSet c) -> c -> RE c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. c -> RSet c
forall a. a -> RSet a
RSet.singleton

-- |
--
-- >>> putPretty $ charRange 'a' 'z'
-- ^[a-z]$
--
charRange :: Ord c => c -> c -> RE c
charRange :: forall c. Ord c => c -> c -> RE c
charRange c
c c
c' = RSet c -> RE c
forall c. RSet c -> RE c
REChars (RSet c -> RE c) -> RSet c -> RE c
forall a b. (a -> b) -> a -> b
$ (c, c) -> RSet c
forall a. Ord a => (a, a) -> RSet a
RSet.singletonRange (c
c, c
c')

-- | Any character. /Note:/ different than dot!
--
-- >>> putPretty anyChar
-- ^[^]$
--
anyChar :: Bounded c => RE c
anyChar :: forall c. Bounded c => RE c
anyChar = RSet c -> RE c
forall c. RSet c -> RE c
REChars RSet c
forall a. Bounded a => RSet a
RSet.full

-- | Concatenate regular expressions.
--
-- prop> (asREChar r <> s) <> t === r <> (s <> t)
--
-- prop> asREChar r <> empty === empty
-- prop> empty <> asREChar r === empty
--
-- prop> asREChar r <> eps === r
-- prop> eps <> asREChar r === r
--
appends :: Eq c => [RE c] -> RE c
appends :: forall c. Eq c => [RE c] -> RE c
appends [RE c]
rs0
    | RE c -> [RE c] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem RE c
forall c. RE c
empty [RE c]
rs1 = RE c
forall c. RE c
empty
    | Bool
otherwise = case [RE c]
rs1 of
        [RE c
r] -> RE c
r
        [RE c]
rs  -> [RE c] -> RE c
forall c. [RE c] -> RE c
REAppend [RE c]
rs
  where
    rs1 :: [RE c]
rs1 = (RE c -> [RE c]) -> [RE c] -> [RE c]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap RE c -> [RE c]
forall c. RE c -> [RE c]
f [RE c]
rs0

    f :: RE c -> [RE c]
    f :: forall c. RE c -> [RE c]
f (REAppend [RE c]
rs) = (RE c -> [RE c]) -> [RE c] -> [RE c]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap RE c -> [RE c]
forall c. RE c -> [RE c]
f [RE c]
rs
    f RE c
r             = [RE c
r]

-- | Union of regular expressions.
--
-- prop> asREChar r \/ r === r
-- prop> asREChar r \/ s === s \/ r
-- prop> (asREChar r \/ s) \/ t === r \/ (s \/ t)
--
-- prop> empty \/ asREChar r === r
-- prop> asREChar r \/ empty === r
--
-- prop> everything \/ asREChar r === everything
-- prop> asREChar r \/ everything === everything
--
unions :: (Ord c, Enum c, Bounded c) => [RE c] -> RE c
unions :: forall c. (Ord c, Enum c, Bounded c) => [RE c] -> RE c
unions = (RSet c -> Set (RE c) -> RE c) -> (RSet c, Set (RE c)) -> RE c
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry RSet c -> Set (RE c) -> RE c
forall {a}. (Ord a, Bounded a) => RSet a -> Set (RE a) -> RE a
mk ((RSet c, Set (RE c)) -> RE c)
-> ([RE c] -> (RSet c, Set (RE c))) -> [RE c] -> RE c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RE c -> (RSet c, Set (RE c))) -> [RE c] -> (RSet c, Set (RE c))
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap RE c -> (RSet c, Set (RE c))
forall {c}. (Ord c, Enum c) => RE c -> (RSet c, Set (RE c))
f where
    mk :: RSet a -> Set (RE a) -> RE a
mk RSet a
cs Set (RE a)
rss
        | Set (RE a) -> Bool
forall a. Set a -> Bool
Set.null Set (RE a)
rss = RSet a -> RE a
forall c. RSet c -> RE c
REChars RSet a
cs
        | RE a -> Set (RE a) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member RE a
forall c. Bounded c => RE c
everything Set (RE a)
rss = RE a
forall c. Bounded c => RE c
everything
        | RSet a -> Bool
forall a. RSet a -> Bool
RSet.null RSet a
cs = case Set (RE a) -> [RE a]
forall a. Set a -> [a]
Set.toList Set (RE a)
rss of
            []  -> RE a
forall c. RE c
empty
            [RE a
r] -> RE a
r
            [RE a]
_   -> RSet a -> Set (RE a) -> RE a
forall c. RSet c -> Set (RE c) -> RE c
REUnion RSet a
cs Set (RE a)
rss
        | Bool
otherwise    = RSet a -> Set (RE a) -> RE a
forall c. RSet c -> Set (RE c) -> RE c
REUnion RSet a
cs Set (RE a)
rss

    f :: RE c -> (RSet c, Set (RE c))
f (REUnion RSet c
cs Set (RE c)
rs) = (RSet c
cs, Set (RE c)
rs)
    f (REChars RSet c
cs)    = (RSet c
cs, Set (RE c)
forall a. Set a
Set.empty)
    f RE c
r               = (RSet c
forall a. Monoid a => a
mempty, RE c -> Set (RE c)
forall a. a -> Set a
Set.singleton RE c
r)

-- | Kleene star.
--
-- prop> star (star r) === star (asREChar r)
--
-- prop> star eps     === asREChar eps
-- prop> star empty   === asREChar eps
-- prop> star anyChar === asREChar everything
--
-- prop> star (r      \/ eps) === star (asREChar r)
-- prop> star (char c \/ eps) === star (asREChar (char c))
-- prop> star (empty  \/ eps) === asREChar eps
--
star :: Ord c => RE c -> RE c
star :: forall c. Ord c => RE c -> RE c
star RE c
r = case RE c
r of
    REStar RE c
_                          -> RE c
r
    REAppend []                       -> RE c
forall c. RE c
eps
    REChars RSet c
cs | RSet c -> Bool
forall a. RSet a -> Bool
RSet.null RSet c
cs         -> RE c
forall c. RE c
eps
    REUnion RSet c
cs Set (RE c)
rs | RE c -> Set (RE c) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member RE c
forall c. RE c
eps Set (RE c)
rs -> case Set (RE c) -> [RE c]
forall a. Set a -> [a]
Set.toList Set (RE c)
rs' of
        []                  -> RE c -> RE c
forall c. Ord c => RE c -> RE c
star (RSet c -> RE c
forall c. RSet c -> RE c
REChars RSet c
cs)
        [RE c
r'] | RSet c -> Bool
forall a. RSet a -> Bool
RSet.null RSet c
cs -> RE c -> RE c
forall c. Ord c => RE c -> RE c
star RE c
r'
        [RE c]
_                   -> RE c -> RE c
forall c. RE c -> RE c
REStar (RSet c -> Set (RE c) -> RE c
forall c. RSet c -> Set (RE c) -> RE c
REUnion RSet c
cs Set (RE c)
rs')
      where
        rs' :: Set (RE c)
rs' = RE c -> Set (RE c) -> Set (RE c)
forall a. Ord a => a -> Set a -> Set a
Set.delete RE c
forall c. RE c
eps Set (RE c)
rs
    RE c
_                                 -> RE c -> RE c
forall c. RE c -> RE c
REStar RE c
r

-- | Literal string.
--
-- >>> putPretty ("foobar" :: RE Char)
-- ^foobar$
--
-- >>> putPretty ("(.)" :: RE Char)
-- ^\(\.\)$
--
string :: [c] -> RE c
string :: forall c. [c] -> RE c
string []  = RE c
forall c. RE c
eps
string [c
c] = RSet c -> RE c
forall c. RSet c -> RE c
REChars (c -> RSet c
forall a. a -> RSet a
RSet.singleton c
c)
string [c]
cs  = [RE c] -> RE c
forall c. [RE c] -> RE c
REAppend ([RE c] -> RE c) -> [RE c] -> RE c
forall a b. (a -> b) -> a -> b
$ (c -> RE c) -> [c] -> [RE c]
forall a b. (a -> b) -> [a] -> [b]
map (RSet c -> RE c
forall c. RSet c -> RE c
REChars (RSet c -> RE c) -> (c -> RSet c) -> c -> RE c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. c -> RSet c
forall a. a -> RSet a
RSet.singleton) [c]
cs

instance (Ord c, Enum c, Bounded c) => C.Kleene (RE c) where
    empty :: RE c
empty      = RE c
forall c. RE c
empty
    eps :: RE c
eps        = RE c
forall c. RE c
eps
    appends :: [RE c] -> RE c
appends    = [RE c] -> RE c
forall c. Eq c => [RE c] -> RE c
appends
    unions :: [RE c] -> RE c
unions     = [RE c] -> RE c
forall c. (Ord c, Enum c, Bounded c) => [RE c] -> RE c
unions
    star :: RE c -> RE c
star       = RE c -> RE c
forall c. Ord c => RE c -> RE c
star

instance (Ord c, Enum c, Bounded c) => C.CharKleene c (RE c) where
    char :: c -> RE c
char       = c -> RE c
forall c. c -> RE c
char

instance (Ord c, Enum c, Bounded c) => C.FiniteKleene c (RE c) where
    everything :: RE c
everything = RE c
forall c. Bounded c => RE c
everything
    charRange :: c -> c -> RE c
charRange  = c -> c -> RE c
forall c. Ord c => c -> c -> RE c
charRange
    fromRSet :: RSet c -> RE c
fromRSet   = RSet c -> RE c
forall c. RSet c -> RE c
REChars
    anyChar :: RE c
anyChar    = RE c
forall c. Bounded c => RE c
anyChar

-------------------------------------------------------------------------------
-- Pseudo lattice
-------------------------------------------------------------------------------

(\/) :: (Ord c, Enum c, Bounded c) => RE c -> RE c -> RE c
RE c
r \/ :: forall c. (Ord c, Enum c, Bounded c) => RE c -> RE c -> RE c
\/ RE c
r' = [RE c] -> RE c
forall c. (Ord c, Enum c, Bounded c) => [RE c] -> RE c
unions [RE c
r, RE c
r']

-------------------------------------------------------------------------------
-- 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 :: RE c -> Bool
nullable :: forall c. RE c -> Bool
nullable (REChars RSet c
_)      = Bool
False
nullable (REAppend [RE c]
rs)    = (RE c -> Bool) -> [RE c] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all RE c -> Bool
forall c. RE c -> Bool
nullable [RE c]
rs
nullable (REUnion RSet c
_cs Set (RE c)
rs) = (RE c -> Bool) -> Set (RE c) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any RE c -> Bool
forall c. RE c -> Bool
nullable Set (RE c)
rs
nullable (REStar RE 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' $ "xyz" \/ "abc"
-- ^yz$
--
-- >>> putPretty $ derivate 'x' $ star "xyz"
-- ^yz(xyz)*$
--
derivate :: (Ord c, Enum c, Bounded c) => c -> RE c -> RE c
derivate :: forall c. (Ord c, Enum c, Bounded c) => c -> RE c -> RE c
derivate c
c (REChars RSet c
cs)     = c -> RSet c -> RE c
forall c. Ord c => c -> RSet c -> RE c
derivateChars c
c RSet c
cs
derivate c
c (REUnion RSet c
cs Set (RE c)
rs)  = [RE c] -> RE c
forall c. (Ord c, Enum c, Bounded c) => [RE c] -> RE c
unions ([RE c] -> RE c) -> [RE c] -> RE c
forall a b. (a -> b) -> a -> b
$ c -> RSet c -> RE c
forall c. Ord c => c -> RSet c -> RE c
derivateChars c
c RSet c
cs RE c -> [RE c] -> [RE c]
forall a. a -> [a] -> [a]
: [ c -> RE c -> RE c
forall c. (Ord c, Enum c, Bounded c) => c -> RE c -> RE c
derivate c
c RE c
r | RE c
r <- Set (RE c) -> [RE c]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Set (RE c)
rs]
derivate c
c (REAppend [RE c]
rs)    = c -> [RE c] -> RE c
forall c. (Ord c, Enum c, Bounded c) => c -> [RE c] -> RE c
derivateAppend c
c [RE c]
rs
derivate c
c rs :: RE c
rs@(REStar RE c
r)    = c -> RE c -> RE c
forall c. (Ord c, Enum c, Bounded c) => c -> RE c -> RE c
derivate c
c RE c
r RE c -> RE c -> RE c
forall a. Semigroup a => a -> a -> a
<> RE c
rs

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

derivateChars :: Ord c =>  c -> RSet c -> RE c
derivateChars :: forall c. Ord c => c -> RSet c -> RE c
derivateChars c
c RSet c
cs
    | c
c c -> RSet c -> Bool
forall a. Ord a => a -> RSet a -> Bool
`RSet.member` RSet c
cs      = RE c
forall c. RE c
eps
    | Bool
otherwise               = RE c
forall c. RE c
empty

instance (Ord c, Enum c, Bounded c) => C.Derivate c (RE c) where
    nullable :: RE c -> Bool
nullable = RE c -> Bool
forall c. RE c -> Bool
nullable
    derivate :: c -> RE c -> RE c
derivate = c -> RE c -> RE c
forall c. (Ord c, Enum c, Bounded c) => c -> RE c -> RE c
derivate

instance (Ord c, Enum c, Bounded c) => C.Match c (RE c) where
    match :: RE c -> [c] -> Bool
match RE c
r = RE c -> Bool
forall c. RE c -> Bool
nullable (RE c -> Bool) -> ([c] -> RE c) -> [c] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RE c -> c -> RE c) -> RE c -> [c] -> RE 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 -> RE c -> RE c) -> RE c -> c -> RE c
forall a b c. (a -> b -> c) -> b -> a -> c
flip c -> RE c -> RE c
forall c. (Ord c, Enum c, Bounded c) => c -> RE c -> RE c
derivate) RE c
r

-------------------------------------------------------------------------------
-- Nullable with proof
-------------------------------------------------------------------------------

-- | Not only we can decide whether 'RE' is nullable, we can also
-- remove the empty string:
--
-- >>> putPretty $ nullableProof eps
-- ^[]$
--
-- >>> putPretty $ nullableProof $ star "x"
-- ^xx*$
--
-- >>> putPretty $ nullableProof "foo"
-- Nothing
--
-- 'nullableProof' is consistent with 'nullable':
--
-- prop> isJust (nullableProof r) === nullable (asREChar r)
--
-- The returned regular expression is not nullable:
--
-- prop> maybe True (not . nullable) $ nullableProof $ asREChar r
--
-- If we union with empty regex, we get a equivalent regular expression
-- we started with:
--
-- prop> maybe r (eps \/) (nullableProof r) `equivalent` (asREChar r)
--
nullableProof :: forall c. (Ord c, Enum c, Bounded c) => RE c -> Maybe (RE c)
nullableProof :: forall c. (Ord c, Enum c, Bounded c) => RE c -> Maybe (RE c)
nullableProof (REChars RSet c
_)   = Maybe (RE c)
forall a. Maybe a
Nothing

nullableProof (REAppend []) = RE c -> Maybe (RE c)
forall a. a -> Maybe a
Just RE c
forall c. RE c
empty
nullableProof (REAppend [RE c]
xs)
    | Just [(RE c, RE c)]
ys <- (RE c -> Maybe (RE c, RE c)) -> [RE c] -> Maybe [(RE c, RE c)]
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 (\RE c
x -> (,) RE c
x (RE c -> (RE c, RE c)) -> Maybe (RE c) -> Maybe (RE c, RE c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RE c -> Maybe (RE c)
forall c. (Ord c, Enum c, Bounded c) => RE c -> Maybe (RE c)
nullableProof RE c
x) [RE c]
xs = RE c -> Maybe (RE c)
forall a. a -> Maybe a
Just ([(RE c, RE c)] -> RE c
go [(RE c, RE c)]
ys)
    | Bool
otherwise = Maybe (RE c)
forall a. Maybe a
Nothing
  where
    go :: [(RE c, RE c)] -> RE c
    go :: [(RE c, RE c)] -> RE c
go [(RE c, RE c)]
rs = [RE c] -> RE c
forall c. (Ord c, Enum c, Bounded c) => [RE c] -> RE c
unions ([RE c] -> RE c) -> [RE c] -> RE c
forall a b. (a -> b) -> a -> b
$ ([RE c] -> RE c) -> [[RE c]] -> [RE c]
forall a b. (a -> b) -> [a] -> [b]
map [RE c] -> RE c
forall c. Eq c => [RE c] -> RE c
appends ([[RE c]] -> [RE c]) -> [[RE c]] -> [RE c]
forall a b. (a -> b) -> a -> b
$ [[RE c]] -> [[RE c]]
forall a. HasCallStack => [a] -> [a]
tail ([[RE c]] -> [[RE c]]) -> [[RE c]] -> [[RE c]]
forall a b. (a -> b) -> a -> b
$ ((RE c, RE c) -> [RE c]) -> [(RE c, RE c)] -> [[RE c]]
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 (\(RE c
r,RE c
r') -> [RE c
r,RE c
r']) [(RE c, RE c)]
rs

nullableProof (REUnion RSet c
cs Set (RE c)
rs)
    | (RE c -> Bool) -> Set (RE c) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any RE c -> Bool
forall c. RE c -> Bool
nullable Set (RE c)
rs = RE c -> Maybe (RE c)
forall a. a -> Maybe a
Just (RE c -> Maybe (RE c)) -> RE c -> Maybe (RE c)
forall a b. (a -> b) -> a -> b
$ RSet c -> Set (RE c) -> RE c
forall c. RSet c -> Set (RE c) -> RE c
REUnion RSet c
cs (Set (RE c) -> RE c) -> Set (RE c) -> RE c
forall a b. (a -> b) -> a -> b
$ (RE c -> RE c) -> Set (RE c) -> Set (RE c)
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (\RE c
r -> RE c -> (RE c -> RE c) -> Maybe (RE c) -> RE c
forall b a. b -> (a -> b) -> Maybe a -> b
maybe RE c
r RE c -> RE c
forall a. a -> a
id (Maybe (RE c) -> RE c) -> Maybe (RE c) -> RE c
forall a b. (a -> b) -> a -> b
$ RE c -> Maybe (RE c)
forall c. (Ord c, Enum c, Bounded c) => RE c -> Maybe (RE c)
nullableProof RE c
r) Set (RE c)
rs
    | Bool
otherwise       = Maybe (RE c)
forall a. Maybe a
Nothing

nullableProof (REStar RE c
r)
    | Just RE c
r' <- RE c -> Maybe (RE c)
forall c. (Ord c, Enum c, Bounded c) => RE c -> Maybe (RE c)
nullableProof RE c
r = RE c -> Maybe (RE c)
forall a. a -> Maybe a
Just (RE c
r' RE c -> RE c -> RE c
forall a. Semigroup a => a -> a -> a
<> RE c -> RE c
forall c. RE c -> RE c
REStar RE c
r')
    | Bool
otherwise                  = RE c -> Maybe (RE c)
forall a. a -> Maybe a
Just (RE c
r RE c -> RE c -> RE c
forall a. Semigroup a => a -> a -> a
<> RE c -> RE c
forall c. RE c -> RE c
REStar RE c
r)

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

-- | Whether 'RE' is (structurally) equal to 'empty'.
--
-- prop> isEmpty r === all (not . nullable) (Map.keys $ transitionMap $ asREChar r)
isEmpty :: RE c -> Bool
isEmpty :: forall c. RE c -> Bool
isEmpty (REChars RSet c
rs) = RSet c -> Bool
forall a. RSet a -> Bool
RSet.null RSet c
rs
isEmpty RE c
_            = Bool
False

-------------------------------------------------------------------------------
-- States
-------------------------------------------------------------------------------

-- | Transition map. Used to construct 'Kleene.DFA.DFA'.
--
-- >>> void $ Map.traverseWithKey (\k v -> putStrLn $ pretty k ++ " : " ++ SF.showSF (fmap pretty v)) $ transitionMap ("ab" :: RE Char)
-- ^[]$ : \_ -> "^[]$"
-- ^b$ : \x -> if
--     | x <= 'a'  -> "^[]$"
--     | x <= 'b'  -> "^$"
--     | otherwise -> "^[]$"
-- ^$ : \_ -> "^[]$"
-- ^ab$ : \x -> if
--     | x <= '`'  -> "^[]$"
--     | x <= 'a'  -> "^b$"
--     | otherwise -> "^[]$"
--
transitionMap
    :: forall c. (Ord c, Enum c, Bounded c)
    => RE c
    -> Map (RE c) (SF.SF c (RE c))
transitionMap :: forall c.
(Ord c, Enum c, Bounded c) =>
RE c -> Map (RE c) (SF c (RE c))
transitionMap RE c
re = Map (RE c) (SF c (RE c)) -> [RE c] -> Map (RE c) (SF c (RE c))
go Map (RE c) (SF c (RE c))
forall k a. Map k a
Map.empty [RE c
re] where
    go :: Map (RE c) (SF.SF c (RE c))
       -> [RE c]
       -> Map (RE c) (SF.SF c (RE c))
    go :: Map (RE c) (SF c (RE c)) -> [RE c] -> Map (RE c) (SF c (RE c))
go !Map (RE c) (SF c (RE c))
acc [] = Map (RE c) (SF c (RE c))
acc
    go Map (RE c) (SF c (RE c))
acc (RE c
r : [RE c]
rs)
        | RE c
r RE c -> Map (RE c) (SF c (RE c)) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map (RE c) (SF c (RE c))
acc = Map (RE c) (SF c (RE c)) -> [RE c] -> Map (RE c) (SF c (RE c))
go Map (RE c) (SF c (RE c))
acc [RE c]
rs
        | Bool
otherwise = Map (RE c) (SF c (RE c)) -> [RE c] -> Map (RE c) (SF c (RE c))
go (RE c
-> SF c (RE c)
-> Map (RE c) (SF c (RE c))
-> Map (RE c) (SF c (RE c))
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert RE c
r SF c (RE c)
pm Map (RE c) (SF c (RE c))
acc) (SF c (RE c) -> [RE c]
forall k v. SF k v -> [v]
SF.values SF c (RE c)
pm [RE c] -> [RE c] -> [RE c]
forall a. [a] -> [a] -> [a]
++ [RE c]
rs)
      where
        pm :: SF c (RE c)
pm = (c -> RE c) -> Partition c -> SF c (RE c)
forall a b.
(Enum a, Bounded a, Ord a) =>
(a -> b) -> Partition a -> SF a b
P.toSF (\c
c -> c -> RE c -> RE c
forall c. (Ord c, Enum c, Bounded c) => c -> RE c -> RE c
derivate c
c RE c
r) (RE c -> Partition c
forall c. (Ord c, Enum c, Bounded c) => RE c -> Partition c
leadingChars RE c
r)

instance (Ord c, Enum c, Bounded c) => C.TransitionMap c (RE c) where
    transitionMap :: RE c -> Map (RE c) (SF c (RE c))
transitionMap = RE c -> Map (RE c) (SF c (RE c))
forall c.
(Ord c, Enum c, Bounded c) =>
RE c -> Map (RE c) (SF c (RE c))
transitionMap

-- | Leading character sets of regular expression.
--
-- >>> leadingChars "foo"
-- fromSeparators "ef"
--
-- >>> leadingChars (star "b" <> star "e")
-- fromSeparators "abde"
--
-- >>> leadingChars (charRange 'b' 'z')
-- fromSeparators "az"
--
leadingChars :: (Ord c, Enum c, Bounded c) => RE c -> P.Partition c
leadingChars :: forall c. (Ord c, Enum c, Bounded c) => RE c -> Partition c
leadingChars (REChars RSet c
cs)    = RSet c -> Partition c
forall a. (Enum a, Bounded a, Ord a) => RSet a -> Partition a
P.fromRSet RSet c
cs
leadingChars (REUnion RSet c
cs Set (RE c)
rs) = RSet c -> Partition c
forall a. (Enum a, Bounded a, Ord a) => RSet a -> Partition a
P.fromRSet RSet c
cs Partition c -> Partition c -> Partition c
forall a. Semigroup a => a -> a -> a
<> (RE c -> Partition c) -> Set (RE c) -> Partition c
forall m a. Monoid m => (a -> m) -> Set a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap RE c -> Partition c
forall c. (Ord c, Enum c, Bounded c) => RE c -> Partition c
leadingChars Set (RE c)
rs
leadingChars (REStar RE c
r)      = RE c -> Partition c
forall c. (Ord c, Enum c, Bounded c) => RE c -> Partition c
leadingChars RE c
r
leadingChars (REAppend [RE c]
rs)   = [RE c] -> Partition c
forall c. (Ord c, Enum c, Bounded c) => [RE c] -> Partition c
leadingCharsAppend [RE c]
rs

leadingCharsAppend :: (Ord c, Enum c, Bounded c) => [RE c] -> P.Partition c
leadingCharsAppend :: forall c. (Ord c, Enum c, Bounded c) => [RE c] -> Partition c
leadingCharsAppend [] = Partition c
forall a. Partition a
P.whole
leadingCharsAppend (RE c
r : [RE c]
rs)
    | RE c -> Bool
forall c. RE c -> Bool
nullable RE c
r = RE c -> Partition c
forall c. (Ord c, Enum c, Bounded c) => RE c -> Partition c
leadingChars RE c
r Partition c -> Partition c -> Partition c
forall a. Semigroup a => a -> a -> a
<> [RE c] -> Partition c
forall c. (Ord c, Enum c, Bounded c) => [RE c] -> Partition c
leadingCharsAppend [RE c]
rs
    | Bool
otherwise  = RE c -> Partition c
forall c. (Ord c, Enum c, Bounded c) => RE c -> Partition c
leadingChars RE c
r

-------------------------------------------------------------------------------
-- Equivalence
-------------------------------------------------------------------------------

-- | Whether two regexps are equivalent.
--
-- @
-- 'equivalent' re1 re2 <=> forall s. 'match' re1 s === 'match' re1 s
-- @
--
-- >>> let re1 = star "a" <> "a"
-- >>> let re2 = "a" <> star "a"
--
-- These are different regular expressions, even we perform
-- some normalisation-on-construction:
--
-- >>> re1 == re2
-- False
--
-- They are however equivalent:
--
-- >>> equivalent re1 re2
-- True
--
-- The algorithm works by executing 'states' on "product" regexp,
-- and checking whether all resulting states are both accepting or rejecting.
--
-- @
-- re1 == re2 ==> 'equivalent' re1 re2
-- @
--
-- === More examples
--
-- >>> let example re1 re2 = putPretty re1 >> putPretty re2 >> return (equivalent re1 re2)
-- >>> example re1 re2
-- ^a*a$
-- ^aa*$
-- True
--
-- >>> example (star "aa") (star "aaa")
-- ^(aa)*$
-- ^(aaa)*$
-- False
--
-- >>> example (star "aa" <> star "aaa") (star "aaa" <> star "aa")
-- ^(aa)*(aaa)*$
-- ^(aaa)*(aa)*$
-- True
--
-- >>> example (star ("a" \/ "b")) (star $ star "a" <> star "b")
-- ^[a-b]*$
-- ^(a*b*)*$
-- True
--
equivalent :: forall c. (Ord c, Enum c, Bounded c) => RE c -> RE c -> Bool
equivalent :: forall c. (Ord c, Enum c, Bounded c) => RE c -> RE c -> Bool
equivalent RE c
x0 RE c
y0 = Set (RE c, RE c) -> [(RE c, RE c)] -> Bool
go Set (RE c, RE c)
forall a. Monoid a => a
mempty [(RE c
x0, RE c
y0)] where
    go :: Set (RE c, RE c) -> [(RE c, RE c)] -> Bool
    go :: Set (RE c, RE c) -> [(RE c, RE c)] -> Bool
go !Set (RE c, RE c)
_ [] = Bool
True
    go Set (RE c, RE c)
acc (p :: (RE c, RE c)
p@(RE c
x, RE c
y) : [(RE c, RE c)]
zs)
        | (RE c, RE c)
p (RE c, RE c) -> Set (RE c, RE c) -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set (RE c, RE c)
acc = Set (RE c, RE c) -> [(RE c, RE c)] -> Bool
go Set (RE c, RE c)
acc [(RE c, RE c)]
zs
        -- if two regexps are structurally the same, we don't need to recurse.
        | RE c
x RE c -> RE c -> Bool
forall a. Eq a => a -> a -> Bool
== RE c
y             = Set (RE c, RE c) -> [(RE c, RE c)] -> Bool
go ((RE c, RE c) -> Set (RE c, RE c) -> Set (RE c, RE c)
forall a. Ord a => a -> Set a -> Set a
Set.insert (RE c, RE c)
p Set (RE c, RE c)
acc) [(RE c, RE c)]
zs
        | ((RE c, RE c) -> Bool) -> [(RE c, RE c)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (RE c, RE c) -> Bool
agree [(RE c, RE c)]
ps       = Set (RE c, RE c) -> [(RE c, RE c)] -> Bool
go ((RE c, RE c) -> Set (RE c, RE c) -> Set (RE c, RE c)
forall a. Ord a => a -> Set a -> Set a
Set.insert (RE c, RE c)
p Set (RE c, RE c)
acc) ([(RE c, RE c)]
ps [(RE c, RE c)] -> [(RE c, RE c)] -> [(RE c, RE c)]
forall a. [a] -> [a] -> [a]
++ [(RE c, RE c)]
zs)
        | Bool
otherwise = Bool
False
      where
        cs :: [c]
cs = Set c -> [c]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Set c -> [c]) -> Set c -> [c]
forall a b. (a -> b) -> a -> b
$ Partition c -> Set c
forall a. (Bounded a, Enum a, Ord a) => Partition a -> Set a
P.examples (Partition c -> Set c) -> Partition c -> Set c
forall a b. (a -> b) -> a -> b
$ RE c -> Partition c
forall c. (Ord c, Enum c, Bounded c) => RE c -> Partition c
leadingChars RE c
x Partition c -> Partition c -> Partition c
forall a. Ord a => Partition a -> Partition a -> Partition a
`P.wedge` RE c -> Partition c
forall c. (Ord c, Enum c, Bounded c) => RE c -> Partition c
leadingChars RE c
y
        ps :: [(RE c, RE c)]
ps = (c -> (RE c, RE c)) -> [c] -> [(RE c, RE c)]
forall a b. (a -> b) -> [a] -> [b]
map (\c
c -> (c -> RE c -> RE c
forall c. (Ord c, Enum c, Bounded c) => c -> RE c -> RE c
derivate c
c RE c
x, c -> RE c -> RE c
forall c. (Ord c, Enum c, Bounded c) => c -> RE c -> RE c
derivate c
c RE c
y)) [c]
cs

    agree :: (RE c, RE c) -> Bool
    agree :: (RE c, RE c) -> Bool
agree (RE c
x, RE c
y) = RE c -> Bool
forall c. RE c -> Bool
nullable RE c
x Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== RE c -> Bool
forall c. RE c -> Bool
nullable RE c
y

instance (Ord c, Enum c, Bounded c) => C.Equivalent c (RE c) where
    equivalent :: RE c -> RE c -> Bool
equivalent = RE c -> RE c -> Bool
forall c. (Ord c, Enum c, Bounded c) => RE c -> RE c -> Bool
equivalent

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

-- | Generate random strings of the language @RE c@ describes.
--
-- >>> let example = traverse_ print . take 3 . generate (curry QC.choose) 42
-- >>> example "abc"
-- "abc"
-- "abc"
-- "abc"
--
-- >>> example $ star $ "a" \/ "b"
-- ""
-- "bbaabbaaba"
-- "b"
--
-- >>> example empty
--
-- prop> all (match r) $ take 10 $ generate (curry QC.choose) 42 (r :: RE Char)
--
generate
    :: (c -> c -> QC.Gen c) -- ^ character range generator
    -> Int    -- ^ seed
    -> RE c
    -> [[c]]  -- ^ infinite list of results
generate :: forall c. (c -> c -> Gen c) -> Int -> RE c -> [[c]]
generate c -> c -> Gen c
c Int
seed RE c
re
    | RE c -> Bool
forall c. RE c -> Bool
isEmpty RE 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 ((c -> c -> Gen c) -> RE c -> Gen [c]
forall c. (c -> c -> Gen c) -> RE c -> Gen [c]
generator c -> c -> Gen c
c RE c
re)) (Int -> QCGen
QC.mkQCGen Int
seed) Int
10

generator
    :: (c -> c -> QC.Gen c)
    -> RE c
    -> QC.Gen [c]
generator :: forall c. (c -> c -> Gen c) -> RE c -> Gen [c]
generator c -> c -> Gen c
c = RE c -> Gen [c]
go where
    go :: RE c -> Gen [c]
go (REChars RSet c
cs)    = RSet c -> Gen [c]
goChars RSet c
cs
    go (REAppend [RE c]
rs)   = [[c]] -> [c]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[c]] -> [c]) -> Gen [[c]] -> Gen [c]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (RE c -> Gen [c]) -> [RE c] -> Gen [[c]]
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 RE c -> Gen [c]
go [RE c]
rs
    go (REUnion RSet c
cs Set (RE c)
rs)
        | RSet c -> Bool
forall a. RSet a -> Bool
RSet.null  RSet c
cs = [Gen [c]] -> Gen [c]
forall a. [Gen a] -> Gen a
QC.oneof [ RE c -> Gen [c]
go RE c
r | RE c
r <- Set (RE c) -> [RE c]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Set (RE c)
rs ]
        | Bool
otherwise     = [Gen [c]] -> Gen [c]
forall a. [Gen a] -> Gen a
QC.oneof ([Gen [c]] -> Gen [c]) -> [Gen [c]] -> Gen [c]
forall a b. (a -> b) -> a -> b
$ RSet c -> Gen [c]
goChars RSet c
cs Gen [c] -> [Gen [c]] -> [Gen [c]]
forall a. a -> [a] -> [a]
: [ RE c -> Gen [c]
go RE c
r | RE c
r <- Set (RE c) -> [RE c]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Set (RE c)
rs ]
    go (REStar RE c
r)      = (Int -> Gen [c]) -> Gen [c]
forall a. (Int -> Gen a) -> Gen a
QC.sized ((Int -> Gen [c]) -> Gen [c]) -> (Int -> Gen [c]) -> Gen [c]
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)
        [[c]] -> [c]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[c]] -> [c]) -> Gen [[c]] -> Gen [c]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Gen [c]] -> Gen [[c]]
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 [c] -> [Gen [c]]
forall a. Int -> a -> [a]
replicate Int
n' (RE c -> Gen [c]
go RE c
r))

    goChars :: RSet c -> Gen [c]
goChars RSet c
cs = c -> [c]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (c -> [c]) -> Gen c -> Gen [c]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Gen c] -> Gen c
forall a. [Gen a] -> Gen a
QC.oneof [ c -> c -> Gen c
c c
x c
y | (c
x,c
y) <- RSet c -> [(c, c)]
forall a. RSet a -> [(a, a)]
RSet.toRangeList RSet c
cs ]

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

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

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



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

instance (Ord c, Enum c, Bounded c, QC.Arbitrary c) => QC.Arbitrary (RE c) where
    arbitrary :: Gen (RE c)
arbitrary = (Int -> Gen (RE c)) -> Gen (RE c)
forall a. (Int -> Gen a) -> Gen a
QC.sized Int -> Gen (RE c)
arb where
        c :: QC.Gen (RE c)
        c :: Gen (RE c)
c = RSet c -> RE c
forall c. RSet c -> RE c
REChars (RSet c -> RE c) -> ([(c, c)] -> RSet c) -> [(c, c)] -> RE c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(c, c)] -> RSet c
forall a. (Ord a, Enum a) => [(a, a)] -> RSet a
RSet.fromRangeList ([(c, c)] -> RE c) -> Gen [(c, c)] -> Gen (RE c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen [(c, c)]
forall a. Arbitrary a => Gen a
QC.arbitrary

        arb :: Int -> QC.Gen (RE c)
        arb :: Int -> Gen (RE c)
arb Int
n | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0    = [Gen (RE c)] -> Gen (RE c)
forall a. [Gen a] -> Gen a
QC.oneof [Gen (RE c)
c, (c -> RE c) -> Gen c -> Gen (RE c)
forall a b. (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap c -> RE c
forall c. c -> RE c
char Gen c
forall a. Arbitrary a => Gen a
QC.arbitrary, RE c -> Gen (RE c)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RE c
forall c. RE c
eps]
              | Bool
otherwise = [Gen (RE c)] -> Gen (RE c)
forall a. [Gen a] -> Gen a
QC.oneof
            [ Gen (RE c)
c
            , RE c -> Gen (RE c)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RE c
forall c. RE c
eps
            , (c -> RE c) -> Gen c -> Gen (RE c)
forall a b. (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap c -> RE c
forall c. c -> RE c
char Gen c
forall a. Arbitrary a => Gen a
QC.arbitrary
            , (RE c -> RE c -> RE c) -> Gen (RE c) -> Gen (RE c) -> Gen (RE 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 RE c -> RE c -> RE c
forall a. Semigroup a => a -> a -> a
(<>) (Int -> Gen (RE c)
arb Int
n2) (Int -> Gen (RE c)
arb Int
n2)
            , (RE c -> RE c -> RE c) -> Gen (RE c) -> Gen (RE c) -> Gen (RE 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 RE c -> RE c -> RE c
forall c. (Ord c, Enum c, Bounded c) => RE c -> RE c -> RE c
(\/) (Int -> Gen (RE c)
arb Int
n2) (Int -> Gen (RE c)
arb Int
n2)
            , (RE c -> RE c) -> Gen (RE c) -> Gen (RE c)
forall a b. (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RE c -> RE c
forall c. Ord c => RE c -> RE c
star (Int -> Gen (RE c)
arb Int
n2)
            ]
          where
            n2 :: Int
n2 = Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2

    shrink :: RE c -> [RE c]
shrink (REUnion RSet c
_cs Set (RE c)
rs) = Set (RE c) -> [RE c]
forall a. Set a -> [a]
Set.toList Set (RE c)
rs
    shrink (REAppend [RE c]
rs)    = [RE c]
rs [RE c] -> [RE c] -> [RE c]
forall a. [a] -> [a] -> [a]
++ ([RE c] -> RE c) -> [[RE c]] -> [RE c]
forall a b. (a -> b) -> [a] -> [b]
map [RE c] -> RE c
forall c. Eq c => [RE c] -> RE c
appends ([RE c] -> [[RE c]]
forall a. Arbitrary a => a -> [a]
QC.shrink [RE c]
rs)
    shrink (REStar RE c
r)       = RE c
r RE c -> [RE c] -> [RE c]
forall a. a -> [a] -> [a]
: (RE c -> RE c) -> [RE c] -> [RE c]
forall a b. (a -> b) -> [a] -> [b]
map RE c -> RE c
forall c. Ord c => RE c -> RE c
star (RE c -> [RE c]
forall a. Arbitrary a => a -> [a]
QC.shrink RE c
r)
    shrink RE c
_                = []

instance (QC.CoArbitrary c) => QC.CoArbitrary (RE c) where
    coarbitrary :: forall b. RE c -> Gen b -> Gen b
coarbitrary (REChars RSet c
cs)    = Int -> Gen b -> Gen b
forall n a. Integral n => n -> Gen a -> Gen a
QC.variant (Int
0 :: Int) (Gen b -> Gen b) -> (Gen b -> Gen b) -> Gen b -> Gen b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(c, c)] -> Gen b -> Gen b
forall b. [(c, c)] -> Gen b -> Gen b
forall a b. CoArbitrary a => a -> Gen b -> Gen b
QC.coarbitrary (RSet c -> [(c, c)]
forall a. RSet a -> [(a, a)]
RSet.toRangeList RSet c
cs)
    coarbitrary (REAppend [RE 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
. [RE c] -> Gen b -> Gen b
forall b. [RE c] -> Gen b -> Gen b
forall a b. CoArbitrary a => a -> Gen b -> Gen b
QC.coarbitrary [RE c]
rs
    coarbitrary (REUnion RSet c
cs Set (RE 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, c)], [RE c]) -> Gen b -> Gen b
forall b. ([(c, c)], [RE c]) -> Gen b -> Gen b
forall a b. CoArbitrary a => a -> Gen b -> Gen b
QC.coarbitrary (RSet c -> [(c, c)]
forall a. RSet a -> [(a, a)]
RSet.toRangeList RSet c
cs, Set (RE c) -> [RE c]
forall a. Set a -> [a]
Set.toList Set (RE c)
rs)
    coarbitrary (REStar RE 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
. RE c -> Gen b -> Gen b
forall a b. CoArbitrary a => a -> Gen b -> Gen b
forall b. RE c -> Gen b -> Gen b
QC.coarbitrary RE c
r

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

instance c ~ Char => Pretty (RE c) where
    prettyS :: RE c -> ShowS
prettyS RE c
x = Char -> ShowS
showChar Char
'^' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> RE Char -> ShowS
go Bool
False RE c
RE Char
x ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
'$'
      where
        go :: Bool -> RE Char -> ShowS
        go :: Bool -> RE Char -> ShowS
go Bool
p (REStar RE Char
a)
            = Bool -> ShowS -> ShowS
parens Bool
p
            (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Bool -> RE Char -> ShowS
go Bool
True RE Char
a ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
'*'
        go Bool
p (REAppend [RE Char]
rs)
            = Bool -> ShowS -> ShowS
parens Bool
p (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ShowS -> [RE Char] -> ShowS
goMany ShowS
forall a. a -> a
id [RE Char]
rs
        go Bool
p (REUnion RSet Char
cs Set (RE Char)
rs)
            | RSet Char -> Bool
forall a. RSet a -> Bool
RSet.null RSet Char
cs = Bool -> Set (RE Char) -> ShowS
goUnion Bool
p Set (RE Char)
rs
            | Set (RE Char) -> Bool
forall a. Set a -> Bool
Set.null Set (RE Char)
rs  = RSet Char -> ShowS
forall a. Pretty a => a -> ShowS
prettyS RSet Char
cs
            | Bool
otherwise    = Bool -> Set (RE Char) -> ShowS
goUnion Bool
p (RE Char -> Set (RE Char) -> Set (RE Char)
forall a. Ord a => a -> Set a -> Set a
Set.insert (RSet Char -> RE Char
forall c. RSet c -> RE c
REChars RSet Char
cs) Set (RE Char)
rs)
        go Bool
_ (REChars RSet Char
cs)
            = RSet Char -> ShowS
forall a. Pretty a => a -> ShowS
prettyS RSet Char
cs

        goUnion :: Bool -> Set (RE Char) -> ShowS
goUnion Bool
p Set (RE Char)
rs
            | RE Char -> Set (RE Char) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member RE Char
forall c. RE c
eps Set (RE Char)
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 Set (RE Char) -> [RE Char]
forall a. Set a -> [a]
Set.toList (RE Char -> Set (RE Char) -> Set (RE Char)
forall a. Ord a => a -> Set a -> Set a
Set.delete RE Char
forall c. RE c
eps Set (RE Char)
rs) of
                [] -> Bool -> RE Char -> ShowS
go Bool
True RE Char
forall c. RE c
empty
                [RE Char
r] -> Bool -> RE Char -> ShowS
go Bool
p' RE Char
r
                (RE Char
r:[RE Char]
rs') -> Bool -> ShowS -> ShowS
parens Bool
True (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ShowS -> RE Char -> [RE Char] -> ShowS
goSome1 (Char -> ShowS
showChar Char
'|') RE Char
r [RE Char]
rs'

        goMany :: ShowS -> [RE Char] -> ShowS
        goMany :: ShowS -> [RE Char] -> ShowS
goMany ShowS
sep = (RE Char -> ShowS -> ShowS) -> ShowS -> [RE Char] -> ShowS
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\RE Char
a ShowS
b -> Bool -> RE Char -> ShowS
go Bool
False RE Char
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 -> RE Char -> [RE Char] -> ShowS
        goSome1 :: ShowS -> RE Char -> [RE Char] -> ShowS
goSome1 ShowS
sep RE Char
r = (ShowS -> RE Char -> ShowS) -> ShowS -> [RE Char] -> 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 RE Char
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 -> RE Char -> ShowS
go Bool
False RE Char
b) (Bool -> RE Char -> ShowS
go Bool
False RE Char
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

-------------------------------------------------------------------------------
-- Latin1
-------------------------------------------------------------------------------

instance C.ToLatin1 RE where
    toLatin1 :: RE Char -> RE Word8
toLatin1 (REChars RSet Char
rs)    = RSet Word8 -> RE Word8
forall c k. FiniteKleene c k => RSet c -> k
C.fromRSet (RSet Char -> RSet Word8
forall (k :: * -> *). ToLatin1 k => k Char -> k Word8
C.toLatin1 RSet Char
rs)
    toLatin1 (REAppend [RE Char]
xs)   = [RE Word8] -> RE Word8
forall c. Eq c => [RE c] -> RE c
appends ((RE Char -> RE Word8) -> [RE Char] -> [RE Word8]
forall a b. (a -> b) -> [a] -> [b]
map RE Char -> RE Word8
forall (k :: * -> *). ToLatin1 k => k Char -> k Word8
C.toLatin1 [RE Char]
xs)
    toLatin1 (REUnion RSet Char
rs Set (RE Char)
xs) = RSet Word8 -> RE Word8
forall c k. FiniteKleene c k => RSet c -> k
C.fromRSet (RSet Char -> RSet Word8
forall (k :: * -> *). ToLatin1 k => k Char -> k Word8
C.toLatin1 RSet Char
rs) RE Word8 -> RE Word8 -> RE Word8
forall c. (Ord c, Enum c, Bounded c) => RE c -> RE c -> RE c
\/ [RE Word8] -> RE Word8
forall c. (Ord c, Enum c, Bounded c) => [RE c] -> RE c
unions ((RE Char -> RE Word8) -> [RE Char] -> [RE Word8]
forall a b. (a -> b) -> [a] -> [b]
map RE Char -> RE Word8
forall (k :: * -> *). ToLatin1 k => k Char -> k Word8
C.toLatin1 (Set (RE Char) -> [RE Char]
forall a. Set a -> [a]
Set.toList  Set (RE Char)
xs))
    toLatin1 (REStar RE Char
r)      = RE Word8 -> RE Word8
forall c. Ord c => RE c -> RE c
star (RE Char -> RE Word8
forall (k :: * -> *). ToLatin1 k => k Char -> k Word8
C.toLatin1 RE Char
r)