{-# LANGUAGE BangPatterns          #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE Safe                  #-}
{-# LANGUAGE ScopedTypeVariables   #-}
module Kleene.ERE (
    ERE (..),
    -- * Construction
    --
    -- | Binary operators are
    --
    -- * '<>' for append
    -- * '\/' for union
    -- * '/\' for intersection
    --
    empty,
    eps,
    everything,
    char,
    charRange,
    anyChar,
    appends,
    unions,
    intersections,
    star,
    string,
    complement,
    -- * Derivative
    nullable,
    derivate,
    -- * Conversion
    fromRE,
    -- * Transition map
    transitionMap,
    leadingChars,
    -- * Equivalence
    equivalent,
    -- * Other
    isEmpty,
    isEverything,
    ) where

import Algebra.Lattice
       (BoundedJoinSemiLattice (..), BoundedMeetSemiLattice (..), Lattice (..))
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 Kleene.Classes            as C
import qualified Kleene.Internal.Partition as P
import           Kleene.Internal.Pretty
import qualified Kleene.Internal.RE        as RE

-- $setup
-- >>> import Algebra.Lattice ((/\), (\/), top, bottom)
-- >>> import Data.Semigroup (Semigroup (..))
-- >>> import Control.Monad (void)
-- >>> import Data.Foldable (traverse_)
-- >>> import Data.List (sort)
-- >>> 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)
-- >>> let asEREChar :: ERE Char -> ERE Char; asEREChar = id

-- | Extended regular expression
--
-- It's both, /Kleene/ and /Boolean/ algebra. (If we add only intersections, it
-- wouldn't be /Boolean/).
--
-- /Note:/ we don't have special constructor for intersections.
-- We use de Morgan formula \(a \land b = \neg (\neg a \lor \neg b)\).
--
-- >>> putPretty $ asEREChar $ "a" /\ "b"
-- ^~(~a|~b)$
--
-- There is no generator, as 'intersections' makes it hard.
--
data ERE c
    = EREChars (RSet c)                -- ^ Single character
    | EREAppend [ERE c]                -- ^ Concatenation
    | EREUnion (RSet c) (Set (ERE c))  -- ^ Union
    | EREStar (ERE c)                  -- ^ Kleene star
    | ERENot (ERE c)                   -- ^ Complement
  deriving (ERE c -> ERE c -> Bool
(ERE c -> ERE c -> Bool) -> (ERE c -> ERE c -> Bool) -> Eq (ERE c)
forall c. Eq c => ERE c -> ERE c -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall c. Eq c => ERE c -> ERE c -> Bool
== :: ERE c -> ERE c -> Bool
$c/= :: forall c. Eq c => ERE c -> ERE c -> Bool
/= :: ERE c -> ERE c -> Bool
Eq, Eq (ERE c)
Eq (ERE c) =>
(ERE c -> ERE c -> Ordering)
-> (ERE c -> ERE c -> Bool)
-> (ERE c -> ERE c -> Bool)
-> (ERE c -> ERE c -> Bool)
-> (ERE c -> ERE c -> Bool)
-> (ERE c -> ERE c -> ERE c)
-> (ERE c -> ERE c -> ERE c)
-> Ord (ERE c)
ERE c -> ERE c -> Bool
ERE c -> ERE c -> Ordering
ERE c -> ERE c -> ERE 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 (ERE c)
forall c. Ord c => ERE c -> ERE c -> Bool
forall c. Ord c => ERE c -> ERE c -> Ordering
forall c. Ord c => ERE c -> ERE c -> ERE c
$ccompare :: forall c. Ord c => ERE c -> ERE c -> Ordering
compare :: ERE c -> ERE c -> Ordering
$c< :: forall c. Ord c => ERE c -> ERE c -> Bool
< :: ERE c -> ERE c -> Bool
$c<= :: forall c. Ord c => ERE c -> ERE c -> Bool
<= :: ERE c -> ERE c -> Bool
$c> :: forall c. Ord c => ERE c -> ERE c -> Bool
> :: ERE c -> ERE c -> Bool
$c>= :: forall c. Ord c => ERE c -> ERE c -> Bool
>= :: ERE c -> ERE c -> Bool
$cmax :: forall c. Ord c => ERE c -> ERE c -> ERE c
max :: ERE c -> ERE c -> ERE c
$cmin :: forall c. Ord c => ERE c -> ERE c -> ERE c
min :: ERE c -> ERE c -> ERE c
Ord, Int -> ERE c -> ShowS
[ERE c] -> ShowS
ERE c -> String
(Int -> ERE c -> ShowS)
-> (ERE c -> String) -> ([ERE c] -> ShowS) -> Show (ERE c)
forall c. Show c => Int -> ERE c -> ShowS
forall c. Show c => [ERE c] -> ShowS
forall c. Show c => ERE c -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall c. Show c => Int -> ERE c -> ShowS
showsPrec :: Int -> ERE c -> ShowS
$cshow :: forall c. Show c => ERE c -> String
show :: ERE c -> String
$cshowList :: forall c. Show c => [ERE c] -> ShowS
showList :: [ERE c] -> ShowS
Show)

-------------------------------------------------------------------------------
-- fromRE
-------------------------------------------------------------------------------

-- | Convert from ordinary regular expression, 'RE.RE'.
--
fromRE :: Ord c => RE.RE c -> ERE c
fromRE :: forall c. Ord c => RE c -> ERE c
fromRE (RE.REChars RSet c
rs)   = RSet c -> ERE c
forall c. RSet c -> ERE c
EREChars RSet c
rs
fromRE (RE.REAppend [RE c]
rs)  = [ERE c] -> ERE c
forall c. [ERE c] -> ERE c
EREAppend ((RE c -> ERE c) -> [RE c] -> [ERE c]
forall a b. (a -> b) -> [a] -> [b]
map RE c -> ERE c
forall c. Ord c => RE c -> ERE c
fromRE [RE c]
rs)
fromRE (RE.REUnion RSet c
r Set (RE c)
rs) = RSet c -> Set (ERE c) -> ERE c
forall c. RSet c -> Set (ERE c) -> ERE c
EREUnion RSet c
r ((RE c -> ERE c) -> Set (RE c) -> Set (ERE c)
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map RE c -> ERE c
forall c. Ord c => RE c -> ERE c
fromRE Set (RE c)
rs)
fromRE (RE.REStar RE c
r)     = ERE c -> ERE c
forall c. ERE c -> ERE c
EREStar (RE c -> ERE c
forall c. Ord c => RE c -> ERE c
fromRE RE c
r)

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

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

-- | Everything.
--
-- >>> putPretty (everything :: ERE Char)
-- ^~[]$
--
-- >>> putPretty (top :: ERE Char)
-- ^~[]$
--
-- prop> match (everything :: ERE Char) (s :: String) === True
--
everything :: ERE c
everything :: forall c. ERE c
everything = ERE c -> ERE c
forall c. ERE c -> ERE c
complement ERE c
forall c. ERE c
empty

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

-- |
--
-- >>> putPretty (char 'x')
-- ^x$
--
char :: c -> ERE c
char :: forall c. c -> ERE c
char = RSet c -> ERE c
forall c. RSet c -> ERE c
EREChars (RSet c -> ERE c) -> (c -> RSet c) -> c -> ERE 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 -> ERE c
charRange :: forall c. Ord c => c -> c -> ERE c
charRange c
c c
c' = RSet c -> ERE c
forall c. RSet c -> ERE c
EREChars (RSet c -> ERE c) -> RSet c -> ERE 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 => ERE c
anyChar :: forall c. Bounded c => ERE c
anyChar = RSet c -> ERE c
forall c. RSet c -> ERE c
EREChars RSet c
forall a. Bounded a => RSet a
RSet.full

-- | Concatenate regular expressions.
--
-- prop> asEREChar r <> empty === empty
-- prop> empty <> asEREChar r === empty
-- prop> (asEREChar r <> s) <> t === r <> (s <> t)
--
-- prop> asEREChar r <> eps === r
-- prop> eps <> asEREChar r === r
--
appends :: Eq c => [ERE c] -> ERE c
appends :: forall c. Eq c => [ERE c] -> ERE c
appends [ERE c]
rs0
    | ERE c -> [ERE c] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem ERE c
forall c. ERE c
empty [ERE c]
rs1 = ERE c
forall c. ERE c
empty
    | Bool
otherwise = case [ERE c]
rs1 of
        [ERE c
r] -> ERE c
r
        [ERE c]
rs  -> [ERE c] -> ERE c
forall c. [ERE c] -> ERE c
EREAppend [ERE c]
rs
  where
    -- flatten one level of EREAppend
    rs1 :: [ERE c]
rs1 = (ERE c -> [ERE c]) -> [ERE c] -> [ERE c]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ERE c -> [ERE c]
forall {c}. ERE c -> [ERE c]
f [ERE c]
rs0

    f :: ERE c -> [ERE c]
f (EREAppend [ERE c]
rs) = [ERE c]
rs
    f ERE c
r              = [ERE c
r]

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

    f :: ERE c -> (RSet c, Set (ERE c))
f (EREUnion RSet c
cs Set (ERE c)
rs) = (RSet c
cs, Set (ERE c)
rs)
    f (EREChars RSet c
cs)    = (RSet c
cs, Set (ERE c)
forall a. Set a
Set.empty)
    f ERE c
r                = (RSet c
forall a. Monoid a => a
mempty, ERE c -> Set (ERE c)
forall a. a -> Set a
Set.singleton ERE c
r)

-- | Intersection of regular expressions.
--
-- prop> asEREChar r /\ r === r
-- prop> asEREChar r /\ s === s /\ r
-- prop> (asEREChar r /\ s) /\ t === r /\ (s /\ t)
--
-- prop> empty /\ asEREChar r === empty
-- prop> asEREChar r /\ empty === empty
--
-- prop> everything /\ asEREChar r === r
-- prop> asEREChar r /\ everything === r
--
intersections :: (Ord c, Enum c) => [ERE c] -> ERE c
intersections :: forall c. (Ord c, Enum c) => [ERE c] -> ERE c
intersections = ERE c -> ERE c
forall c. ERE c -> ERE c
complement (ERE c -> ERE c) -> ([ERE c] -> ERE c) -> [ERE c] -> ERE c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ERE c] -> ERE c
forall c. (Ord c, Enum c) => [ERE c] -> ERE c
unions ([ERE c] -> ERE c) -> ([ERE c] -> [ERE c]) -> [ERE c] -> ERE c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ERE c -> ERE c) -> [ERE c] -> [ERE c]
forall a b. (a -> b) -> [a] -> [b]
map ERE c -> ERE c
forall c. ERE c -> ERE c
complement

-- | Complement.
--
-- prop> complement (complement r) === asEREChar r
--
complement :: ERE c -> ERE c
complement :: forall c. ERE c -> ERE c
complement ERE c
r = case ERE c
r of
    ERENot ERE c
r' -> ERE c
r'
    ERE c
_ -> ERE c -> ERE c
forall c. ERE c -> ERE c
ERENot ERE c
r

-- | Kleene star.
--
-- prop> star (star r) === star (asEREChar r)
--
-- prop> star eps     === asEREChar eps
-- prop> star empty   === asEREChar eps
-- prop> star anyChar === asEREChar everything
--
-- prop> star (asEREChar r \/ eps) === star r
-- prop> star (char c \/ eps) === star (char (c :: Char))
-- prop> star (empty \/ eps) === eps
--
star :: (Ord c, Bounded c) => ERE c -> ERE c
star :: forall c. (Ord c, Bounded c) => ERE c -> ERE c
star ERE c
r = case ERE c
r of
    EREStar ERE c
_                          -> ERE c
r
    EREAppend []                       -> ERE c
forall c. ERE c
eps
    EREChars RSet c
cs | RSet c -> Bool
forall a. RSet a -> Bool
RSet.null RSet c
cs         -> ERE c
forall c. ERE c
eps
    EREChars RSet c
cs | RSet c -> Bool
forall a. (Eq a, Bounded a) => RSet a -> Bool
RSet.isFull RSet c
cs       -> ERE c
forall c. ERE c
everything
    EREUnion RSet c
cs Set (ERE c)
rs | ERE c -> Set (ERE c) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member ERE c
forall c. ERE c
eps Set (ERE c)
rs -> case Set (ERE c) -> [ERE c]
forall a. Set a -> [a]
Set.toList Set (ERE c)
rs' of
        []                  -> ERE c -> ERE c
forall c. (Ord c, Bounded c) => ERE c -> ERE c
star (RSet c -> ERE c
forall c. RSet c -> ERE c
EREChars RSet c
cs)
        [ERE c
r'] | RSet c -> Bool
forall a. RSet a -> Bool
RSet.null RSet c
cs -> ERE c -> ERE c
forall c. (Ord c, Bounded c) => ERE c -> ERE c
star ERE c
r'
        [ERE c]
_                   -> ERE c -> ERE c
forall c. ERE c -> ERE c
EREStar (RSet c -> Set (ERE c) -> ERE c
forall c. RSet c -> Set (ERE c) -> ERE c
EREUnion RSet c
cs Set (ERE c)
rs')
      where
        rs' :: Set (ERE c)
rs' = ERE c -> Set (ERE c) -> Set (ERE c)
forall a. Ord a => a -> Set a -> Set a
Set.delete ERE c
forall c. ERE c
eps Set (ERE c)
rs
    ERE c
_                                  -> ERE c -> ERE c
forall c. ERE c -> ERE c
EREStar ERE c
r

-- | Literal string.
--
-- >>> putPretty ("foobar" :: ERE Char)
-- ^foobar$
--
-- >>> putPretty ("(.)" :: ERE Char)
-- ^\(\.\)$
--
string :: [c] -> ERE c
string :: forall c. [c] -> ERE c
string []  = ERE c
forall c. ERE c
eps
string [c
c] = RSet c -> ERE c
forall c. RSet c -> ERE c
EREChars (c -> RSet c
forall a. a -> RSet a
RSet.singleton c
c)
string [c]
cs  = [ERE c] -> ERE c
forall c. [ERE c] -> ERE c
EREAppend ([ERE c] -> ERE c) -> [ERE c] -> ERE c
forall a b. (a -> b) -> a -> b
$ (c -> ERE c) -> [c] -> [ERE c]
forall a b. (a -> b) -> [a] -> [b]
map (RSet c -> ERE c
forall c. RSet c -> ERE c
EREChars (RSet c -> ERE c) -> (c -> RSet c) -> c -> ERE 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 (ERE c) where
    empty :: ERE c
empty      = ERE c
forall c. ERE c
empty
    eps :: ERE c
eps        = ERE c
forall c. ERE c
eps
    appends :: [ERE c] -> ERE c
appends    = [ERE c] -> ERE c
forall c. Eq c => [ERE c] -> ERE c
appends
    unions :: [ERE c] -> ERE c
unions     = [ERE c] -> ERE c
forall c. (Ord c, Enum c) => [ERE c] -> ERE c
unions
    star :: ERE c -> ERE c
star       = ERE c -> ERE c
forall c. (Ord c, Bounded c) => ERE c -> ERE c
star

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

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

instance C.Complement c (ERE c) where
    complement :: ERE c -> ERE c
complement = ERE c -> ERE c
forall c. ERE c -> ERE c
complement

-------------------------------------------------------------------------------
-- 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 (complement eps)
-- False
--
nullable :: ERE c -> Bool
nullable :: forall c. ERE c -> Bool
nullable (EREChars RSet c
_)      = Bool
False
nullable (EREAppend [ERE c]
rs)    = (ERE c -> Bool) -> [ERE c] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ERE c -> Bool
forall c. ERE c -> Bool
nullable [ERE c]
rs
nullable (EREUnion RSet c
_cs Set (ERE c)
rs) = (ERE c -> Bool) -> Set (ERE c) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ERE c -> Bool
forall c. ERE c -> Bool
nullable Set (ERE c)
rs
nullable (EREStar ERE c
_)       = Bool
True
nullable (ERENot ERE c
r)        = Bool -> Bool
not (ERE c -> Bool
forall c. ERE c -> Bool
nullable ERE c
r)

-- | 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) => c -> ERE c -> ERE c
derivate :: forall c. (Ord c, Enum c) => c -> ERE c -> ERE c
derivate c
c (EREChars RSet c
cs)     = c -> RSet c -> ERE c
forall c. Ord c => c -> RSet c -> ERE c
derivateChars c
c RSet c
cs
derivate c
c (EREUnion RSet c
cs Set (ERE c)
rs)  = [ERE c] -> ERE c
forall c. (Ord c, Enum c) => [ERE c] -> ERE c
unions ([ERE c] -> ERE c) -> [ERE c] -> ERE c
forall a b. (a -> b) -> a -> b
$ c -> RSet c -> ERE c
forall c. Ord c => c -> RSet c -> ERE c
derivateChars c
c RSet c
cs ERE c -> [ERE c] -> [ERE c]
forall a. a -> [a] -> [a]
: [ c -> ERE c -> ERE c
forall c. (Ord c, Enum c) => c -> ERE c -> ERE c
derivate c
c ERE c
r | ERE c
r <- Set (ERE c) -> [ERE c]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Set (ERE c)
rs]
derivate c
c (EREAppend [ERE c]
rs)    = c -> [ERE c] -> ERE c
forall c. (Enum c, Ord c) => c -> [ERE c] -> ERE c
derivateAppend c
c [ERE c]
rs
derivate c
c rs :: ERE c
rs@(EREStar ERE c
r)    = c -> ERE c -> ERE c
forall c. (Ord c, Enum c) => c -> ERE c -> ERE c
derivate c
c ERE c
r ERE c -> ERE c -> ERE c
forall a. Semigroup a => a -> a -> a
<> ERE c
rs
derivate c
c (ERENot ERE c
r)        = ERE c -> ERE c
forall c. ERE c -> ERE c
complement (c -> ERE c -> ERE c
forall c. (Ord c, Enum c) => c -> ERE c -> ERE c
derivate c
c ERE c
r)

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

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

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

derivateChars :: Ord c =>  c -> RSet c -> ERE c
derivateChars :: forall c. Ord c => c -> RSet c -> ERE 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      = ERE c
forall c. ERE c
eps
    | Bool
otherwise               = ERE c
forall c. ERE c
empty

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

-- | Whether 'ERE' is (structurally) equal to 'empty'.
isEmpty :: ERE c -> Bool
isEmpty :: forall c. ERE c -> Bool
isEmpty (EREChars RSet c
rs) = RSet c -> Bool
forall a. RSet a -> Bool
RSet.null RSet c
rs
isEmpty ERE c
_            = Bool
False

-- | Whether 'ERE' is (structurally) equal to 'everything'.
isEverything :: ERE c -> Bool
isEverything :: forall c. ERE c -> Bool
isEverything (ERENot (EREChars RSet c
rs)) = RSet c -> Bool
forall a. RSet a -> Bool
RSet.null RSet c
rs
isEverything ERE 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" :: ERE 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)
    => ERE c
    -> Map (ERE c) (SF.SF c (ERE c))
transitionMap :: forall c.
(Ord c, Enum c, Bounded c) =>
ERE c -> Map (ERE c) (SF c (ERE c))
transitionMap ERE c
re = Map (ERE c) (SF c (ERE c)) -> [ERE c] -> Map (ERE c) (SF c (ERE c))
go Map (ERE c) (SF c (ERE c))
forall k a. Map k a
Map.empty [ERE c
re] where
    go :: Map (ERE c) (SF.SF c (ERE c))
       -> [ERE c]
       -> Map (ERE c) (SF.SF c (ERE c))
    go :: Map (ERE c) (SF c (ERE c)) -> [ERE c] -> Map (ERE c) (SF c (ERE c))
go !Map (ERE c) (SF c (ERE c))
acc [] = Map (ERE c) (SF c (ERE c))
acc
    go Map (ERE c) (SF c (ERE c))
acc (ERE c
r : [ERE c]
rs)
        | ERE c
r ERE c -> Map (ERE c) (SF c (ERE c)) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map (ERE c) (SF c (ERE c))
acc = Map (ERE c) (SF c (ERE c)) -> [ERE c] -> Map (ERE c) (SF c (ERE c))
go Map (ERE c) (SF c (ERE c))
acc [ERE c]
rs
        | Bool
otherwise = Map (ERE c) (SF c (ERE c)) -> [ERE c] -> Map (ERE c) (SF c (ERE c))
go (ERE c
-> SF c (ERE c)
-> Map (ERE c) (SF c (ERE c))
-> Map (ERE c) (SF c (ERE c))
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ERE c
r SF c (ERE c)
pm Map (ERE c) (SF c (ERE c))
acc) (SF c (ERE c) -> [ERE c]
forall k v. SF k v -> [v]
SF.values SF c (ERE c)
pm [ERE c] -> [ERE c] -> [ERE c]
forall a. [a] -> [a] -> [a]
++ [ERE c]
rs)
      where
        pm :: SF c (ERE c)
pm = (c -> ERE c) -> Partition c -> SF c (ERE c)
forall a b.
(Enum a, Bounded a, Ord a) =>
(a -> b) -> Partition a -> SF a b
P.toSF (\c
c -> c -> ERE c -> ERE c
forall c. (Ord c, Enum c) => c -> ERE c -> ERE c
derivate c
c ERE c
r) (ERE c -> Partition c
forall c. (Ord c, Enum c, Bounded c) => ERE c -> Partition c
leadingChars ERE c
r)

instance (Ord c, Enum c, Bounded c) => C.TransitionMap c (ERE c) where
    transitionMap :: ERE c -> Map (ERE c) (SF c (ERE c))
transitionMap = ERE c -> Map (ERE c) (SF c (ERE c))
forall c.
(Ord c, Enum c, Bounded c) =>
ERE c -> Map (ERE c) (SF c (ERE 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) => ERE c -> P.Partition c
leadingChars :: forall c. (Ord c, Enum c, Bounded c) => ERE c -> Partition c
leadingChars (EREChars 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 (EREUnion RSet c
cs Set (ERE 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
<> (ERE c -> Partition c) -> Set (ERE 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 ERE c -> Partition c
forall c. (Ord c, Enum c, Bounded c) => ERE c -> Partition c
leadingChars Set (ERE c)
rs
leadingChars (EREStar ERE c
r)      = ERE c -> Partition c
forall c. (Ord c, Enum c, Bounded c) => ERE c -> Partition c
leadingChars ERE c
r
leadingChars (EREAppend [ERE c]
rs)   = [ERE c] -> Partition c
forall c. (Ord c, Enum c, Bounded c) => [ERE c] -> Partition c
leadingCharsAppend [ERE c]
rs
leadingChars (ERENot ERE c
r)       = ERE c -> Partition c
forall c. (Ord c, Enum c, Bounded c) => ERE c -> Partition c
leadingChars ERE c
r

leadingCharsAppend :: (Ord c, Enum c, Bounded c) => [ERE c] -> P.Partition c
leadingCharsAppend :: forall c. (Ord c, Enum c, Bounded c) => [ERE c] -> Partition c
leadingCharsAppend [] = Partition c
forall a. Partition a
P.whole
leadingCharsAppend (ERE c
r : [ERE c]
rs)
    | ERE c -> Bool
forall c. ERE c -> Bool
nullable ERE c
r = ERE c -> Partition c
forall c. (Ord c, Enum c, Bounded c) => ERE c -> Partition c
leadingChars ERE c
r Partition c -> Partition c -> Partition c
forall a. Semigroup a => a -> a -> a
<> [ERE c] -> Partition c
forall c. (Ord c, Enum c, Bounded c) => [ERE c] -> Partition c
leadingCharsAppend [ERE c]
rs
    | Bool
otherwise  = ERE c -> Partition c
forall c. (Ord c, Enum c, Bounded c) => ERE c -> Partition c
leadingChars ERE 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) => ERE c -> ERE c -> Bool
equivalent :: forall c. (Ord c, Enum c, Bounded c) => ERE c -> ERE c -> Bool
equivalent ERE c
x0 ERE c
y0 = Set (ERE c, ERE c) -> [(ERE c, ERE c)] -> Bool
go Set (ERE c, ERE c)
forall a. Monoid a => a
mempty [(ERE c
x0, ERE c
y0)] where
    go :: Set (ERE c, ERE c) -> [(ERE c, ERE c)] -> Bool
    go :: Set (ERE c, ERE c) -> [(ERE c, ERE c)] -> Bool
go !Set (ERE c, ERE c)
_ [] = Bool
True
    go Set (ERE c, ERE c)
acc (p :: (ERE c, ERE c)
p@(ERE c
x, ERE c
y) : [(ERE c, ERE c)]
zs)
        | (ERE c, ERE c)
p (ERE c, ERE c) -> Set (ERE c, ERE c) -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set (ERE c, ERE c)
acc = Set (ERE c, ERE c) -> [(ERE c, ERE c)] -> Bool
go Set (ERE c, ERE c)
acc [(ERE c, ERE c)]
zs
        -- if two regexps are structurally the same, we don't need to recurse.
        | ERE c
x ERE c -> ERE c -> Bool
forall a. Eq a => a -> a -> Bool
== ERE c
y             = Set (ERE c, ERE c) -> [(ERE c, ERE c)] -> Bool
go ((ERE c, ERE c) -> Set (ERE c, ERE c) -> Set (ERE c, ERE c)
forall a. Ord a => a -> Set a -> Set a
Set.insert (ERE c, ERE c)
p Set (ERE c, ERE c)
acc) [(ERE c, ERE c)]
zs
        | ((ERE c, ERE c) -> Bool) -> [(ERE c, ERE c)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (ERE c, ERE c) -> Bool
agree [(ERE c, ERE c)]
ps       = Set (ERE c, ERE c) -> [(ERE c, ERE c)] -> Bool
go ((ERE c, ERE c) -> Set (ERE c, ERE c) -> Set (ERE c, ERE c)
forall a. Ord a => a -> Set a -> Set a
Set.insert (ERE c, ERE c)
p Set (ERE c, ERE c)
acc) ([(ERE c, ERE c)]
ps [(ERE c, ERE c)] -> [(ERE c, ERE c)] -> [(ERE c, ERE c)]
forall a. [a] -> [a] -> [a]
++ [(ERE c, ERE 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
$ ERE c -> Partition c
forall c. (Ord c, Enum c, Bounded c) => ERE c -> Partition c
leadingChars ERE c
x Partition c -> Partition c -> Partition c
forall a. Ord a => Partition a -> Partition a -> Partition a
`P.wedge` ERE c -> Partition c
forall c. (Ord c, Enum c, Bounded c) => ERE c -> Partition c
leadingChars ERE c
y
        ps :: [(ERE c, ERE c)]
ps = (c -> (ERE c, ERE c)) -> [c] -> [(ERE c, ERE c)]
forall a b. (a -> b) -> [a] -> [b]
map (\c
c -> (c -> ERE c -> ERE c
forall c. (Ord c, Enum c) => c -> ERE c -> ERE c
derivate c
c ERE c
x, c -> ERE c -> ERE c
forall c. (Ord c, Enum c) => c -> ERE c -> ERE c
derivate c
c ERE c
y)) [c]
cs

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

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

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

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

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

instance (Ord c, Enum c) => Lattice (ERE c) where
    ERE c
r \/ :: ERE c -> ERE c -> ERE c
\/ ERE c
r' = [ERE c] -> ERE c
forall c. (Ord c, Enum c) => [ERE c] -> ERE c
unions [ERE c
r, ERE c
r']
    ERE c
r /\ :: ERE c -> ERE c -> ERE c
/\ ERE c
r' = [ERE c] -> ERE c
forall c. (Ord c, Enum c) => [ERE c] -> ERE c
intersections [ERE c
r, ERE c
r']

instance (Ord c, Enum c) => BoundedJoinSemiLattice (ERE c) where
    bottom :: ERE c
bottom = ERE c
forall c. ERE c
empty

instance (Ord c, Enum c) => BoundedMeetSemiLattice (ERE c) where
    top :: ERE c
top = ERE c
forall c. ERE c
everything

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

instance (Ord c, Enum c, Bounded c, QC.Arbitrary c) => QC.Arbitrary (ERE c) where
    arbitrary :: Gen (ERE c)
arbitrary = (Int -> Gen (ERE c)) -> Gen (ERE c)
forall a. (Int -> Gen a) -> Gen a
QC.sized Int -> Gen (ERE c)
arb where
        c :: QC.Gen (ERE c)
        c :: Gen (ERE c)
c = RSet c -> ERE c
forall c. RSet c -> ERE c
EREChars (RSet c -> ERE c) -> ([(c, c)] -> RSet c) -> [(c, c)] -> ERE 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)] -> ERE c) -> Gen [(c, c)] -> Gen (ERE 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 (ERE c)
        arb :: Int -> Gen (ERE c)
arb Int
n | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0    = [Gen (ERE c)] -> Gen (ERE c)
forall a. [Gen a] -> Gen a
QC.oneof [Gen (ERE c)
c, (c -> ERE c) -> Gen c -> Gen (ERE c)
forall a b. (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap c -> ERE c
forall c. c -> ERE c
char Gen c
forall a. Arbitrary a => Gen a
QC.arbitrary, ERE c -> Gen (ERE c)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ERE c
forall c. ERE c
eps]
              | Bool
otherwise = [Gen (ERE c)] -> Gen (ERE c)
forall a. [Gen a] -> Gen a
QC.oneof
            [ Gen (ERE c)
c
            , ERE c -> Gen (ERE c)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ERE c
forall c. ERE c
eps
            , (c -> ERE c) -> Gen c -> Gen (ERE c)
forall a b. (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap c -> ERE c
forall c. c -> ERE c
char Gen c
forall a. Arbitrary a => Gen a
QC.arbitrary
            , (ERE c -> ERE c -> ERE c)
-> Gen (ERE c) -> Gen (ERE c) -> Gen (ERE 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 ERE c -> ERE c -> ERE c
forall a. Semigroup a => a -> a -> a
(<>) (Int -> Gen (ERE c)
arb Int
n2) (Int -> Gen (ERE c)
arb Int
n2)
            , (ERE c -> ERE c -> ERE c)
-> Gen (ERE c) -> Gen (ERE c) -> Gen (ERE 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 ERE c -> ERE c -> ERE c
forall a. Lattice a => a -> a -> a
(\/) (Int -> Gen (ERE c)
arb Int
n2) (Int -> Gen (ERE c)
arb Int
n2)
            , (ERE c -> ERE c) -> Gen (ERE c) -> Gen (ERE c)
forall a b. (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ERE c -> ERE c
forall c. (Ord c, Bounded c) => ERE c -> ERE c
star (Int -> Gen (ERE c)
arb Int
n2)
            , (ERE c -> ERE c) -> Gen (ERE c) -> Gen (ERE c)
forall a b. (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ERE c -> ERE c
forall c. ERE c -> ERE c
complement (Int -> Gen (ERE 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 (ERE c) where
    coarbitrary :: forall b. ERE c -> Gen b -> Gen b
coarbitrary (EREChars 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 (EREAppend [ERE 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
. [ERE c] -> Gen b -> Gen b
forall b. [ERE c] -> Gen b -> Gen b
forall a b. CoArbitrary a => a -> Gen b -> Gen b
QC.coarbitrary [ERE c]
rs
    coarbitrary (EREUnion RSet c
cs Set (ERE 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)], [ERE c]) -> Gen b -> Gen b
forall b. ([(c, c)], [ERE 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 (ERE c) -> [ERE c]
forall a. Set a -> [a]
Set.toList Set (ERE c)
rs)
    coarbitrary (EREStar ERE 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
. ERE c -> Gen b -> Gen b
forall a b. CoArbitrary a => a -> Gen b -> Gen b
forall b. ERE c -> Gen b -> Gen b
QC.coarbitrary ERE c
r
    coarbitrary (ERENot ERE c
r)       = Int -> Gen b -> Gen b
forall n a. Integral n => n -> Gen a -> Gen a
QC.variant (Int
4 :: Int) (Gen b -> Gen b) -> (Gen b -> Gen b) -> Gen b -> Gen b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ERE c -> Gen b -> Gen b
forall a b. CoArbitrary a => a -> Gen b -> Gen b
forall b. ERE c -> Gen b -> Gen b
QC.coarbitrary ERE c
r

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

instance c ~ Char => Pretty (ERE c) where
    prettyS :: ERE c -> ShowS
prettyS ERE c
x = Char -> ShowS
showChar Char
'^' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> ERE Char -> ShowS
go Bool
False ERE c
ERE Char
x ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
'$'
      where
        go :: Bool -> ERE Char -> ShowS
        go :: Bool -> ERE Char -> ShowS
go Bool
p (EREStar ERE Char
a)
            = Bool -> ShowS -> ShowS
parens Bool
p
            (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Bool -> ERE Char -> ShowS
go Bool
True ERE Char
a ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
'*'
        go Bool
p (EREAppend [ERE Char]
rs)
            = Bool -> ShowS -> ShowS
parens Bool
p (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ShowS -> [ERE Char] -> ShowS
goMany ShowS
forall a. a -> a
id [ERE Char]
rs
        go Bool
p (EREUnion RSet Char
cs Set (ERE Char)
rs)
            | RSet Char -> Bool
forall a. RSet a -> Bool
RSet.null RSet Char
cs = Bool -> Set (ERE Char) -> ShowS
goUnion Bool
p Set (ERE Char)
rs
            | Set (ERE Char) -> Bool
forall a. Set a -> Bool
Set.null Set (ERE Char)
rs  = RSet Char -> ShowS
forall a. Pretty a => a -> ShowS
prettyS RSet Char
cs
            | Bool
otherwise    = Bool -> Set (ERE Char) -> ShowS
goUnion Bool
p (ERE Char -> Set (ERE Char) -> Set (ERE Char)
forall a. Ord a => a -> Set a -> Set a
Set.insert (RSet Char -> ERE Char
forall c. RSet c -> ERE c
EREChars RSet Char
cs) Set (ERE Char)
rs)
        go Bool
_ (EREChars RSet Char
cs)
            = RSet Char -> ShowS
forall a. Pretty a => a -> ShowS
prettyS RSet Char
cs
        go Bool
p (ERENot ERE Char
r)
            = Bool -> ShowS -> ShowS
parens Bool
p (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Char -> ShowS
showChar Char
'~' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> ERE Char -> ShowS
go Bool
True ERE Char
r

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

        goMany :: ShowS -> [ERE Char] -> ShowS
        goMany :: ShowS -> [ERE Char] -> ShowS
goMany ShowS
sep = (ERE Char -> ShowS -> ShowS) -> ShowS -> [ERE 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 (\ERE Char
a ShowS
b -> Bool -> ERE Char -> ShowS
go Bool
False ERE 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 -> ERE Char -> [ERE Char] -> ShowS
        goSome1 :: ShowS -> ERE Char -> [ERE Char] -> ShowS
goSome1 ShowS
sep ERE Char
r = (ShowS -> ERE Char -> ShowS) -> ShowS -> [ERE 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 ERE 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 -> ERE Char -> ShowS
go Bool
False ERE Char
b) (Bool -> ERE Char -> ShowS
go Bool
False ERE 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 ERE where
    toLatin1 :: ERE Char -> ERE Word8
toLatin1 (EREChars RSet Char
rs)    = RSet Word8 -> ERE 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 (EREAppend [ERE Char]
xs)   = [ERE Word8] -> ERE Word8
forall c. Eq c => [ERE c] -> ERE c
appends ((ERE Char -> ERE Word8) -> [ERE Char] -> [ERE Word8]
forall a b. (a -> b) -> [a] -> [b]
map ERE Char -> ERE Word8
forall (k :: * -> *). ToLatin1 k => k Char -> k Word8
C.toLatin1 [ERE Char]
xs)
    toLatin1 (EREUnion RSet Char
rs Set (ERE Char)
xs) = RSet Word8 -> ERE 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) ERE Word8 -> ERE Word8 -> ERE Word8
forall a. Lattice a => a -> a -> a
\/ [ERE Word8] -> ERE Word8
forall c. (Ord c, Enum c) => [ERE c] -> ERE c
unions ((ERE Char -> ERE Word8) -> [ERE Char] -> [ERE Word8]
forall a b. (a -> b) -> [a] -> [b]
map ERE Char -> ERE Word8
forall (k :: * -> *). ToLatin1 k => k Char -> k Word8
C.toLatin1 (Set (ERE Char) -> [ERE Char]
forall a. Set a -> [a]
Set.toList  Set (ERE Char)
xs))
    toLatin1 (EREStar ERE Char
r)      = ERE Word8 -> ERE Word8
forall c. (Ord c, Bounded c) => ERE c -> ERE c
star (ERE Char -> ERE Word8
forall (k :: * -> *). ToLatin1 k => k Char -> k Word8
C.toLatin1 ERE Char
r)
    toLatin1 (ERENot ERE Char
r)       = ERE Word8 -> ERE Word8
forall c. ERE c -> ERE c
complement (ERE Char -> ERE Word8
forall (k :: * -> *). ToLatin1 k => k Char -> k Word8
C.toLatin1 ERE Char
r)