packages feed

kleene (empty) → 0

raw patch · 14 files changed

+3122/−0 lines, 14 filesdep +MemoTriedep +QuickCheckdep +basesetup-changed

Dependencies added: MemoTrie, QuickCheck, base, base-compat-batteries, containers, lattices, range-set-list, regex-applicative, step-function, text, transformers

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2017 Futurice Oy, 2017-2018 Oleg Grenrus++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Oleg Grenrus nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wall #-}+module Main (main) where++#ifndef MIN_VERSION_cabal_doctest+#define MIN_VERSION_cabal_doctest(x,y,z) 0+#endif++#if MIN_VERSION_cabal_doctest(1,0,0)++import Distribution.Extra.Doctest ( defaultMainWithDoctests )+main :: IO ()+main = defaultMainWithDoctests "doctests"++#else++#ifdef MIN_VERSION_Cabal+-- If the macro is defined, we have new cabal-install,+-- but for some reason we don't have cabal-doctest in package-db+--+-- Probably we are running cabal sdist, when otherwise using new-build+-- workflow+#warning You are configuring this package without cabal-doctest installed. \+         The doctests test-suite will not work as a result. \+         To fix this, install cabal-doctest before configuring.+#endif++import Distribution.Simple++main :: IO ()+main = defaultMain++#endif
+ kleene.cabal view
@@ -0,0 +1,84 @@+cabal-version:  2.0+name:           kleene+version:        0++synopsis:       Kleene algebra+category:       Math+description:+  Kleene algebra+  .+  Think: Regular expressions+  .+  Implements ideas from /Regular-expression derivatives re-examined/ by+  Scott Owens, John Reppy and Aaron Turon+  <https://doi.org/10.1017/S0956796808007090>++homepage:       https://github.com/phadej/kleene+bug-reports:    https://github.com/phadej/kleene/issues+author:         Oleg Grenrus <oleg.grenrus@iki.fi>+maintainer:     Oleg Grenrus <oleg.grenrus@iki.fi>+license:        BSD3+license-file:   LICENSE+build-type:     Simple++tested-with:+  GHC ==7.8.4+   || ==7.10.3+   || ==8.0.2+   || ==8.2.2+   || ==8.4.2++source-repository head+  type: git+  location: https://github.com/phadej/kleene++library+  -- GHC boot libraries+  build-depends:+    base                  >=4.7.0.2 && <4.12,+    containers            >=0.5.5.1 && <0.6,+    text                  >=1.2.3.0 && <1.3,+    transformers          >=0.3.0.0 && <0.6++  -- Other dependencies+  build-depends:+    base-compat-batteries >=0.10.1  && <0.11,+    lattices              >=1.7.1   && <1.8,+    MemoTrie              >=0.6.9   && <0.7,+    range-set-list        >=0.1.3   && <0.2,+    step-function         >=0.2     && <0.3,+    regex-applicative     >=0.3.3   && <0.4,+    QuickCheck            >=2.11.3  && <2.12++  other-extensions:+    CPP+    DeriveFunctor+    DeriveFoldable+    DeriveTraversable+    GADTs+    OverloadedStrings+    FlexibleInstances+    FunctionalDependencies+    GeneralizedNewtypeDeriving+    StandaloneDeriving+    UndecidableInstances++  exposed-modules:+    Kleene+    Kleene.Classes+    Kleene.DFA+    Kleene.ERE+    Kleene.Equiv+    Kleene.Functor+    Kleene.Monad+    Kleene.RE++  -- "Internal-ish" modules+  exposed-modules:+    Kleene.Internal.Partition+    Kleene.Internal.Pretty+    Kleene.Internal.Sets++  ghc-options: -Wall+  hs-source-dirs: src+  default-language: Haskell2010
+ src/Kleene.hs view
@@ -0,0 +1,170 @@+{-# LANGUAGE Safe #-}+-- | Kleene algebra.+--+-- This package provides means to work with kleene algebra,+-- at the moment specifically concentrating on regular expressions over 'Char'.+--+-- Implements ideas from /Regular-expression derivatives re-examined/ by+-- Scott Owens, John Reppy and Aaron Turon+-- <https://doi.org/10.1017/S0956796808007090>.+--+-- >>> :set -XOverloadedStrings+-- >>> import Algebra.Lattice+-- >>> import Algebra.PartialOrd+-- >>> import Data.Semigroup+-- >>> import Kleene.Internal.Pretty (putPretty)+--+-- "Kleene.RE" module provides 'RE' type. "Kleene.Classes" module provides various+-- classes to work with the type. All of that is re-exported from "Kleene" module.+--+-- First let's construct a regular expression value:+--+-- >>> let re = star "abc" <> "def" <> ("x" \/ "yz") :: RE Char+-- >>> putPretty re+-- ^(abc)*def(x|yz)$+--+-- We can convert it to 'DFA' (there are 8 states)+--+-- >>> putPretty $ fromTM re+-- 0 -> \x -> if+--     | x <= '`'  -> 8+--     | x <= 'a'  -> 5+--     | x <= 'c'  -> 8+--     | x <= 'd'  -> 3+--     | otherwise -> 8+-- 1 -> \x -> if+--     | x <= 'w'  -> 8+--     | x <= 'x'  -> 6+--     | x <= 'y'  -> 7+--     | otherwise -> 8+-- 2 -> ...+-- ...+--+-- And we can convert back from 'DFA' to 'RE':+--+-- >>> let re' = toKleene (fromTM re) :: RE Char+-- >>> putPretty re'+-- ^(a(bca)*bcdefx|defx|(a(bca)*bcdefy|defy)z)$+--+-- As you see, we don't get what we started with. Yet, these+-- regular expressions are 'equivalent';+--+-- >>> equivalent re re'+-- True+--+-- or using 'Equiv' wrapper+--+-- >>> Equiv re == Equiv re'+-- True+--+-- (The paper doesn't outline decision procedure for the equivalence, though+-- it's right there - seems to be fast enough at least for toy examples like+-- here).+--+-- We can use regular expressions to generate word examples in the language:+--+-- >>> import Data.Foldable+-- >>> import qualified Test.QuickCheck as QC+-- >>> import Kleene.RE (generate)+--+-- >>> traverse_ print $ take 5 $ generate (curry QC.choose) 42 re+-- "abcabcabcabcabcabcdefyz"+-- "abcabcabcabcdefyz"+-- "abcabcabcabcabcabcabcabcabcdefx"+-- "abcabcdefx"+-- "abcabcabcabcabcabcdefyz"+--+-- In addition to the "normal" regular expressions, there are /extended regular expressions/.+-- Regular expressions which we can 'complement', and therefore intersect:+--+-- >>> let ere = star "aa" /\ star "aaa" :: ERE Char+-- >>> putPretty ere+-- ^~(~((aa)*)|~((aaa)*))$+--+-- We can convert 'ERE' to 'RE' via 'DFA':+--+-- >>> let re'' = toKleene (fromTM ere) :: RE Char+-- >>> putPretty re''+-- ^(a(aaaaaa)*aaaaa)?$+--+-- Machine works own ways, we don't (always) get as pretty results as we'd like:+--+-- >>> equivalent re'' (star "aaaaaa")+-- True+--+-- Another feature of the library is an 'Applciative' 'Functor',+--+-- >>> import Control.Applicative+-- >>> import qualified Kleene.Functor as F+--+-- >>> let f = (,) <$> many (F.char 'x') <* F.few F.anyChar <*> many (F.char 'z')+-- >>> putPretty f+-- ^x*[^]*z*$+--+-- By relying on <regex-applicative http://hackage.haskell.org/package/regex-applicative> library,+-- we can match and /capture/ with regular expression.+--+-- >>> F.match f "xyyzzz"+-- Just ("x","zzz")+--+-- Where with 'RE' we can only get 'True' or 'False':+--+-- >>> match (F.toRE f) "xyyzzz"+-- True+--+-- Which in this case is not even interesting because:+--+-- >>> equivalent (F.toRE f) everything+-- True+--+-- Converting from 'RE' to 'K' is also possible, which may be handy:+--+-- >>> let g = (,) <$> F.few F.anyChar <*> F.fromRE re''+-- >>> putPretty g+-- ^[^]*(a(aaaaaa)*aaaaa)?$+--+-- >>> F.match g (replicate 20 'a')+-- Just ("aa","aaaaaaaaaaaaaaaaaa")+--+-- We got longest divisible by 6 prefix of as. That's because 'F.fromRE'+-- uses 'many' for 'star'.+--+module Kleene (+    -- * Regular expressions+    RE,+    ERE,++    -- * Equivalance (and partial order)+    Equiv (..),++    -- * Deterministic finite automaton+    DFA (..),+    fromTM,+    fromTMEquiv,+    toKleene,++    -- * Classes+    --+    -- | Most operations are defined in following type-classes.+    --+    -- See "Kleene.RE" module for a specific version with examples.+    Kleene (..),+    Derivate (..),+    Match (..),+    TransitionMap (..),+    Complement (..),++    -- * Functor+    --+    -- | Only the type is exported so it can be referred to.+    --+    -- See "Kleene.Functor" for operations.+    K,+    ) where++import Kleene.Classes+import Kleene.DFA     (DFA (..), fromTM, fromTMEquiv, toKleene)+import Kleene.Equiv+import Kleene.ERE     (ERE)+import Kleene.Functor (K)+import Kleene.RE      (RE)
+ src/Kleene/Classes.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs                  #-}+module Kleene.Classes where++import Prelude ()+import Prelude.Compat++import Algebra.Lattice                    (BoundedJoinSemiLattice (..), joins)+import Data.Foldable                      (toList)+import Data.Function.Step.Discrete.Closed (SF)+import Data.Map                           (Map)+import Data.RangeSet.Map                  (RSet)++import Kleene.Internal.Sets (dotRSet)++class (BoundedJoinSemiLattice k, Semigroup k, Monoid k) => Kleene c k | k -> c where+    -- | Empty regex. Doesn't accept anything.+    empty :: k+    empty = bottom++    -- | Empty string. /Note:/ different than 'empty'+    eps :: k+    eps = mempty++    -- | Single character+    char :: c -> k++    -- | Concatenation.+    appends :: [k] -> k+    appends = mconcat++    -- | Union.+    unions :: [k] -> k+    unions = joins++    -- | Kleene star+    star :: k -> k++-- | One of the characters.+oneof :: (Kleene c k, Foldable f) => f c -> k+oneof = unions . map char . toList++class Kleene c k => FiniteKleene c k | k -> c where+    -- | Everything. \(\Sigma^\star\).+    everything :: k+    everything = star anyChar++    -- | @'charRange' 'a' 'z' = ^[a-z]$@.+    charRange :: c -> c -> k++    -- | Generalisation of 'charRange'.+    fromRSet :: RSet c -> k++    -- | @.$. Every character except new line @\\n@.+    dot :: c ~ Char => k+    dot = fromRSet dotRSet++    -- | Any character. /Note:/ different than dot!+    anyChar :: k++class Derivate c k | k -> c where+    -- | Does language contain an empty string?+    nullable :: k -> Bool++    -- | Derivative of a language.+    derivate :: c -> k -> k++-- | An @f@ can be used to match on the input.+class Match c k | k -> c where+    match :: k -> [c] -> Bool++-- | Equivalence induced by 'Matches'.+--+-- /Law:/+--+-- @+-- 'equivalent' re1 re2 <=> forall s. 'matches' re1 s == 'matches' re1 s+-- @+--+class Match c k => Equivalent c k | k -> c  where+    equivalent :: k -> k -> Bool++-- | Transition map.+class Derivate c k => TransitionMap c k | k -> c where+    transitionMap :: k -> Map k (SF c k)++-- | Complement of the language.+--+-- /Law:/+--+-- @+-- 'matches' ('complement' f) xs = 'not' ('matches' f) xs+-- @+class Complement c k | k -> c where+    complement :: k -> k
+ src/Kleene/DFA.hs view
@@ -0,0 +1,426 @@+{-# LANGUAGE BangPatterns           #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs                  #-}+{-# LANGUAGE Safe                   #-}+{-# LANGUAGE ScopedTypeVariables    #-}+module Kleene.DFA (+    DFA (..),+    -- * Conversions+    fromRE,+    toRE,+    fromERE,+    toERE,+    fromTM,+    fromTMEquiv,+    toKleene,+    ) where++import Prelude ()+import Prelude.Compat++import Algebra.Lattice   ((\/))+import Data.IntMap       (IntMap)+import Data.IntSet       (IntSet)+import Data.List         (intercalate)+import Data.Map          (Map)+import Data.Maybe        (fromMaybe)+import Data.RangeSet.Map (RSet)++import qualified Data.Function.Step.Discrete.Closed as SF+import qualified Data.IntMap                        as IM+import qualified Data.IntSet                        as IS+import qualified Data.Map                           as Map+import qualified Data.MemoTrie                      as MT+import qualified Data.RangeSet.Map                  as RSet++import           Kleene.Classes+import qualified Kleene.ERE             as ERE+import           Kleene.Internal.Pretty+import qualified Kleene.RE              as RE++-- | Deterministic finite automaton.+--+-- A deterministic finite automaton (DFA) over an alphabet \(\Sigma\) (type+-- variable @c@) is 4-tuple \(Q\), \(q_0\) , \(F\), \(\delta\), where+--+-- * \(Q\) is a finite set of states (subset of 'Int'),+-- * \(q_0 \in Q\) is the distinguised start state (@0@),+-- * \(F \subset Q\) is a set of final (or  accepting) states ('dfaAcceptable'), and+-- * \(\delta : Q \times \Sigma \to Q\) is a function called the state+-- transition function ('dfaTransition').+--+data DFA c = DFA+    { dfaTransition   :: !(IntMap (SF.SF c Int))+      -- ^ transition function+    , dfaAcceptable   :: !IntSet+      -- ^ accept states+    , dfaBlackholes   :: !IntSet+      -- ^ states we cannot escape+    }+  deriving Show++-------------------------------------------------------------------------------+-- Construction+-------------------------------------------------------------------------------++-- | Convert 'RE.RE' to 'DFA'.+--+-- >>> putPretty $ fromRE $ RE.star "abc"+-- 0+ -> \x -> if+--     | x <= '`'  -> 3+--     | x <= 'a'  -> 2+--     | otherwise -> 3+-- 1 -> \x -> if+--     | x <= 'b'  -> 3+--     | x <= 'c'  -> 0+--     | otherwise -> 3+-- 2 -> \x -> if+--     | x <= 'a'  -> 3+--     | x <= 'b'  -> 1+--     | otherwise -> 3+-- 3 -> \_ -> 3 -- black hole+--+-- Everything and nothing result in blackholes:+--+-- >>> traverse_ (putPretty . fromRE) [RE.empty, RE.star RE.anyChar]+-- 0 -> \_ -> 0 -- black hole+-- 0+ -> \_ -> 0 -- black hole+--+-- Character ranges are effecient:+--+-- >>> putPretty $ fromRE $ RE.charRange 'a' 'z'+-- 0 -> \x -> if+--     | x <= '`'  -> 2+--     | x <= 'z'  -> 1+--     | otherwise -> 2+-- 1+ -> \_ -> 2+-- 2 -> \_ -> 2 -- black hole+--+-- An example with two blackholes:+--+-- >>> putPretty $ fromRE $ "c" <> RE.star RE.anyChar+-- 0 -> \x -> if+--     | x <= 'b'  -> 2+--     | x <= 'c'  -> 1+--     | otherwise -> 2+-- 1+ -> \_ -> 1 -- black hole+-- 2 -> \_ -> 2 -- black hole+--+fromRE :: forall c. (Ord c, Enum c, Bounded c) => RE.RE c -> DFA c+fromRE = fromTM++-- | Convert 'ERE.ERE' to 'DFA'.+--+-- We don't always generate minimal automata:+--+-- >>> putPretty $ fromERE $ "a" /\ "b"+-- 0 -> \_ -> 1+-- 1 -> \_ -> 1 -- black hole+--+-- Compare this to an @complement@ example+--+-- Using 'fromTMEquiv', we can get minimal automaton, for the cost of higher+-- complexity (slow!).+--+-- >>> putPretty $ fromTMEquiv $ ("a" /\ "b" :: ERE.ERE Char)+-- 0 -> \_ -> 0 -- black hole+--+-- >>> putPretty $ fromERE $ complement $ star "abc"+-- 0 -> \x -> if+--     | x <= '`'  -> 3+--     | x <= 'a'  -> 2+--     | otherwise -> 3+-- 1+ -> \x -> if+--     | x <= 'b'  -> 3+--     | x <= 'c'  -> 0+--     | otherwise -> 3+-- 2+ -> \x -> if+--     | x <= 'a'  -> 3+--     | x <= 'b'  -> 1+--     | otherwise -> 3+-- 3+ -> \_ -> 3 -- black hole+--+fromERE :: forall c. (Ord c, Enum c, Bounded c) => ERE.ERE c -> DFA c+fromERE = fromTM++-- | Create from 'TransitionMap'.+--+-- See 'fromRE' for a specific example.+fromTM :: forall k c. (Ord k, Ord c, TransitionMap c k) => k -> DFA c+fromTM = fromTMImpl Nothing++-- | Create from 'TransitonMap' minimising states with 'Equivalent'.+--+-- See 'fromERE' for an example.+--+fromTMEquiv :: forall k c. (Ord k, Ord c, TransitionMap c k, Equivalent c k) => k -> DFA c+fromTMEquiv = fromTMImpl (Just equivalent)++fromTMImpl :: forall k c. (Ord k, Ord c, TransitionMap c k)+    => Maybe (k ->  k -> Bool)+    -> k+    -> DFA c+fromTMImpl mequiv re = DFA+    { dfaTransition = transition+    , dfaAcceptable = IS.fromList+        [ i+        | (re', i) <- Map.toList lookupMap+        , nullable re'+        ]+    , dfaBlackholes = blackholes+    }+  where+    transition = IM.fromList+        [ (i, js)+        | (re', pm) <- Map.toList tm+        , let i  = fromMaybe 0 $ Map.lookup re' lookupMap+        , let js = SF.normalise $ fmap (\re'' -> fromMaybe 0 $ Map.lookup re'' lookupMap) pm+        ]++    blackholes = IS.fromList+        [ i+        | (i, sf) <- IM.toList transition+        , sf == pure i+        ]++    tm = transitionMap re++    -- reversing makes error state go last, usually+    lookupMap :: Map k Int+    lookupMap = makeLookup 1 lookupMap' (reverse $ Map.toList $ Map.delete re tm)++    lookupMap' :: Map k Int+    lookupMap' = case Map.lookup re tm of+        Nothing -> Map.empty+        Just _  -> Map.singleton re 0++    makeLookup :: Int -> Map k Int -> [(k, b)] -> Map k Int+    makeLookup = maybe makeLookupEq makeLookupEquiv mequiv++    makeLookupEq :: Int -> Map k Int -> [(k, b)] -> Map k Int+    makeLookupEq !_ !acc []            = acc+    makeLookupEq !n acc ((x, _) : xs) = makeLookup (n + 1) (Map.insert x n acc) xs++    -- this differs from makeLookupEq. We don't insert new states right away,+    -- but check whether equivalent state is already in the map.+    --+    -- This causes n^2 of exp m operations, where n = number of states and+    -- m size of @k@.+    makeLookupEquiv :: (k -> k -> Bool) ->  Int -> Map k Int -> [(k, b)] -> Map k Int+    makeLookupEquiv _  !_ !acc []           = acc+    makeLookupEquiv eq !n acc ((x, _) : xs) = case ys of+        []           -> makeLookup (n + 1) (Map.insert x n acc) xs+        ((_, i) : _) -> makeLookup n       (Map.insert x i acc) xs+      where+        ys = [ p | p@(y, _) <- Map.toList acc, eq x y ]++-------------------------------------------------------------------------------+-- Destruction+-------------------------------------------------------------------------------++-- | Convert 'DFA' to 'RE.RE'.+--+-- >>> putPretty $ toRE $ fromRE "foobar"+-- ^foobar$+--+-- For 'RE.string' regular expressions, @'toRE' . 'fromRE' = 'id'@:+--+-- prop> let s = take 5 s' in RE.string (s :: String) === toRE (fromRE (RE.string s))+--+-- But in general it isn't:+--+-- >>> let aToZ = RE.star $ RE.charRange 'a' 'z'+-- >>> traverse_ putPretty [aToZ, toRE $ fromRE aToZ]+-- ^[a-z]*$+-- ^([a-z]|[a-z]?[a-z]*[a-z]?)?$+--+-- @+-- not-prop> (re :: RE.RE Char) === toRE (fromRE re)+-- @+--+-- However, they are 'RE.equivalent':+--+-- >>> RE.equivalent aToZ (toRE (fromRE aToZ))+-- True+--+-- And so are others+--+-- >>> all (\re -> RE.equivalent re (toRE (fromRE re))) [RE.star "a", RE.star "ab"]+-- True+--+-- @+-- expensive-prop> RE.equivalent re (toRE (fromRE (re :: RE.RE Char)))+-- @+--+-- Note, that @'toRE' . 'fromRE'@ can, and usually makes regexp unrecognisable:+--+-- >>> putPretty $ toRE $ fromRE $ RE.star "ab"+-- ^(a(ba)*b)?$+--+-- We can 'complement' DFA, therefore we can complement 'RE.RE'.+-- For example. regular expression matching string containing an @a@:+--+-- >>> let withA = RE.star RE.anyChar <> "a" <> RE.star RE.anyChar+-- >>> let withoutA = toRE $ complement $ fromRE withA+-- >>> putPretty withoutA+-- ^([^a]|[^a]?[^a]*[^a]?)?$+--+-- >>> let withoutA' = RE.star $ RE.REChars $ RSet.complement $ RSet.singleton 'a'+-- >>> putPretty withoutA'+-- ^[^a]*$+--+-- >>> RE.equivalent withoutA withoutA'+-- True+--+-- Quite small, for example 2 state DFAs can result in big regular expressions:+--+-- >>> putPretty $ toRE $ complement $ fromRE $ star "ab"+-- ^([^]|a(ba)*(ba)?|a(ba)*([^b]|b[^a])|([^a]|a(ba)*([^b]|b[^a]))[^]*[^]?)$+--+-- We can use @'toRE' . 'fromERE'@ to convert 'ERE.ERE' to 'RE.RE':+--+-- >>> putPretty $ toRE $ fromERE $ complement $ star "ab"+-- ^([^]|a(ba)*(ba)?|a(ba)*([^b]|b[^a])|([^a]|a(ba)*([^b]|b[^a]))[^]*[^]?)$+--+-- >>> putPretty $ toRE $ fromERE $ "a" /\ "b"+-- ^[]$+--+-- See <https://mathoverflow.net/questions/45149/can-regular-expressions-be-made-unambiguous>+-- for the description of the algorithm used.+--+toRE :: forall c. (Ord c, Enum c, Bounded c) => DFA c -> RE.RE c+toRE = toKleene++-- | Convert 'DFA' to 'ERE.ERE'.+toERE :: forall c. (Ord c, Enum c, Bounded c) => DFA c -> ERE.ERE c+toERE = toKleene++-- | Convert to any 'Kleene'.+--+-- See 'toRE' for a specific example.+--+toKleene :: forall k c. (Ord c, Enum c, Bounded c, FiniteKleene c k) => DFA c -> k+toKleene (DFA tr acc _) = unions+    [ re 0 j maxN+    | j <- IS.toList acc+    ]+  where+    maxN | IM.null tr = 1+         | otherwise = succ $ fst $ IM.findMax tr++    {-+    -- this is useful for debug+    table =+      [ show i ++ " " ++ show j ++ " " ++ show k ++ " = " ++ pretty (re i j k)+      | k <- [0..pred maxN]+      , i <- [0..pred maxN]+      , j <- [0..pred maxN]+      ]+    -}++    re i j k = MT.memo re' (i, j, k)+    re' (i, j, k)+        | k <= 0    = if i == j then eps \/ r else r+        | otherwise = re i j k' \/ (re i k' k' <> star (re k' k' k') <> re k' j k')+      where+        r = maybe empty fromRSet $ Map.lookup (i, j) re0map+        k' = k - 1++    re0map :: Map (Int, Int) (RSet c)+    re0map = Map.fromListWith RSet.union+        [ ((i, j), RSet.singletonRange (lo, hi))+        | (i, tr') <- IM.toList tr+        , (lo, hi, j) <- toPieces tr'+        ]++toPieces :: (Enum a, Bounded a, Ord a) => SF.SF a b -> [(a, a, b)]+toPieces (SF.SF m v)+    | maxBound `Map.member` m = toPieces' m+    | otherwise               = toPieces' (Map.insert maxBound v m)++toPieces' :: (Enum a, Bounded a) => Map a b -> [(a, a, b)]+toPieces' = go minBound . Map.toList where+    go _lo []            = []+    go  lo ((k, v) : kv) = (lo, k, v) : go (succ k) kv++-------------------------------------------------------------------------------+-- Operations+-------------------------------------------------------------------------------++-- | Run 'DFA' on the input.+--+-- Because we have analysed a language, in some cases we can determine an input+-- without traversing all of the input.+-- That's not the cases with 'RE.RE' 'match'.+--+-- >>> let dfa = fromRE $ RE.star "abc"+-- >>> map (match dfa) ["", "abc", "abcabc", "aa", 'a' : 'a' : undefined]+-- [True,True,True,False,False]+--+-- Holds:+--+-- @+-- 'match' ('fromRE' re) xs == 'match' re xs+-- @+--+-- prop> all (match (fromRE r)) $ take 10 $ RE.generate (curry QC.choose) 42 (r :: RE.RE Char)+--+instance Ord c => Match c (DFA c) where+    match (DFA tr acc bh) = go (0 :: Int) where+        go s _ | IS.member s bh = IS.member s acc+        go s []                 = IS.member s acc+        go s (c : cs)           = case IM.lookup s tr of+            Nothing -> False+            Just sf -> go (sf SF.! c) cs++-- | Complement DFA.+--+-- Complement of 'DFA' is way easier than of 'RE.RE': complement accept states.+--+-- >>> let dfa = complement $ fromRE $ RE.star "abc"+-- >>> putPretty dfa+-- 0 -> \x -> if+--     | x <= '`'  -> 3+--     | x <= 'a'  -> 2+--     | otherwise -> 3+-- 1+ -> \x -> if+--     | x <= 'b'  -> 3+--     | x <= 'c'  -> 0+--     | otherwise -> 3+-- 2+ -> \x -> if+--     | x <= 'a'  -> 3+--     | x <= 'b'  -> 1+--     | otherwise -> 3+-- 3+ -> \_ -> 3 -- black hole+--+-- >>> map (match dfa) ["", "abc", "abcabc", "aa","abca", 'a' : 'a' : undefined]+-- [False,False,False,True,True,True]+--+instance Complement c (DFA c) where+    complement (DFA tr acc err) = DFA tr acc' err where+        acc' = IS.difference (IM.keysSet tr) acc++-------------------------------------------------------------------------------+-- Debug+-------------------------------------------------------------------------------++instance Show c => Pretty (DFA c) where+    pretty dfa = intercalate "\n"+        [ show i ++ acc ++ " -> " ++ SF.showSF sf ++ bh+        | (i, sf) <- IM.toList (dfaTransition dfa)+        , let acc = if IS.member i (dfaAcceptable dfa) then "+" else ""+        , let bh = if IS.member i $ dfaBlackholes dfa then " -- black hole" else ""+        ]++-- $setup+-- >>> :set -XOverloadedStrings+-- >>> import Data.Foldable (traverse_)+-- >>> import Algebra.Lattice ((/\))+--+-- >>> import Test.QuickCheck ((===))+-- >>> import qualified Test.QuickCheck as QC+--+-- >>> newtype Smaller a = Smaller a deriving (Show)+-- >>> let intLog2 = (`div` 10)+-- >>> instance QC.Arbitrary a => QC.Arbitrary (Smaller a) where arbitrary = QC.scale intLog2 QC.arbitrary; shrink (Smaller a) = map Smaller (QC.shrink a)
+ src/Kleene/ERE.hs view
@@ -0,0 +1,610 @@+{-# LANGUAGE BangPatterns           #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs                  #-}+{-# LANGUAGE Safe                   #-}+{-# LANGUAGE ScopedTypeVariables    #-}+module Kleene.ERE (+    ERE (..),+    -- * Construction+    --+    -- | Binary operators are+    --+    -- * '<>' for append+    -- * '\/' for union+    -- * '/\' for intersection+    --+    empty,+    eps,+    char,+    charRange,+    anyChar,+    appends,+    unions,+    intersections,+    star,+    string,+    complement,+    -- * Derivative+    nullable,+    derivate,+    -- * Transition map+    transitionMap,+    leadingChars,+    -- * Equivalence+    equivalent,+    -- * Other+    isEmpty,+    isEverything,+    ) where++import Prelude ()+import Prelude.Compat++import Algebra.Lattice+       (BoundedJoinSemiLattice (..), BoundedLattice,+       BoundedMeetSemiLattice (..), JoinSemiLattice (..), Lattice,+       MeetSemiLattice (..))+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++-- | 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 (Eq, Ord, Show)++-------------------------------------------------------------------------------+-- 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 = EREChars RSet.empty++-- | Everything.+--+-- >>> putPretty (everything :: ERE Char)+-- ^~[]$+--+-- >>> putPretty (top :: ERE Char)+-- ^~[]$+--+-- prop> match (everything :: ERE Char) (s :: String) === True+--+everything :: ERE c+everything = complement 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 = EREAppend []++-- |+--+-- >>> putPretty (char 'x')+-- ^x$+--+char :: c -> ERE c+char = EREChars . RSet.singleton++-- |+--+-- >>> putPretty $ charRange 'a' 'z'+-- ^[a-z]$+--+charRange :: Ord c => c -> c -> ERE c+charRange c c' = EREChars $ RSet.singletonRange (c, c')++-- | Any character. /Note:/ different than dot!+--+-- >>> putPretty anyChar+-- ^[^]$+--+anyChar :: Bounded c => ERE c+anyChar = EREChars 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 rs0+    | elem empty rs1 = empty+    | otherwise = case rs1 of+        [r] -> r+        rs  -> EREAppend rs+  where+    -- flatten one level of EREAppend+    rs1 = concatMap f rs0++    f (EREAppend rs) = rs+    f r             = [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 \/ asREChar r === everything+-- prop> asREChar r \/ everything === everything+--+unions :: (Ord c, Enum c) => [ERE c] -> ERE c+unions = uncurry mk . foldMap f where+    mk cs rss+        | Set.null rss = EREChars cs+        | Set.member everything rss = everything+        | RSet.null cs = case Set.toList rss of+            []  -> empty+            [r] -> r+            _   -> EREUnion cs rss+        | otherwise    = EREUnion cs rss++    f (EREUnion cs rs) = (cs, rs)+    f (EREChars cs)    = (cs, Set.empty)+    f r                = (mempty, Set.singleton 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 /\ asREChar r === r+-- prop> asREChar r /\ everything === r+--+intersections :: (Ord c, Enum c) => [ERE c] -> ERE c+intersections = complement . unions . map complement++-- | Complement.+--+-- prop> complement (complement r) === asEREChar r+--+complement :: ERE c -> ERE c+complement r = case r of+    ERENot r' -> r'+    _ -> ERENot 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 (asREChar 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 r = case r of+    EREStar _                          -> r+    EREAppend []                       -> eps+    EREChars cs | RSet.null cs         -> eps+    EREChars cs | RSet.isFull cs       -> everything+    EREUnion cs rs | Set.member eps rs -> case Set.toList rs' of+        []                  -> star (EREChars cs)+        [r'] | RSet.null cs -> star r'+        _                   -> EREStar (EREUnion cs rs')+      where+        rs' = Set.delete eps rs+    _                                  -> EREStar r++-- | Literal string.+--+-- >>> putPretty ("foobar" :: ERE Char)+-- ^foobar$+--+-- >>> putPretty ("(.)" :: ERE Char)+-- ^\(\.\)$+--+string :: [c] -> ERE c+string []  = eps+string [c] = EREChars (RSet.singleton c)+string cs  = EREAppend $ map (EREChars . RSet.singleton) cs++instance (Ord c, Enum c, Bounded c) => C.Kleene c (ERE c) where+    empty      = empty+    eps        = eps+    char       = char+    appends    = appends+    unions     = unions+    star       = star++instance (Ord c, Enum c, Bounded c) => C.FiniteKleene c (ERE c) where+    everything = everything+    charRange  = charRange+    fromRSet   = EREChars+    anyChar    = anyChar++instance C.Complement c (ERE c) where+    complement = 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 (EREChars _)      = False+nullable (EREAppend rs)    = all nullable rs+nullable (EREUnion _cs rs) = any nullable rs+nullable (EREStar _)       = True+nullable (ERENot r)        = not (nullable 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 c (EREChars cs)     = derivateChars c cs+derivate c (EREUnion cs rs)  = unions $ derivateChars c cs : [ derivate c r | r <- toList rs]+derivate c (EREAppend rs)    = derivateAppend c rs+derivate c rs@(EREStar r)    = derivate c r <> rs+derivate c (ERENot r)        = complement (derivate c r)++instance (Ord c, Enum c) => C.Derivate c (ERE c) where+    nullable = nullable+    derivate = derivate++instance (Ord c, Enum c) => C.Match c (ERE c) where+    match r = nullable . foldl' (flip derivate) r++derivateAppend :: (Enum c, Ord c) => c -> [ERE c] -> ERE c+derivateAppend _ []      = empty+derivateAppend c [r]     = derivate c r+derivateAppend c (r:rs)+    | nullable r         = unions [r' <> appends rs, rs']+    | otherwise          = r' <> appends rs+  where+    r'  = derivate c r+    rs' = derivateAppend c rs++derivateChars :: Ord c =>  c -> RSet c -> ERE c+derivateChars c cs+    | c `RSet.member` cs      = eps+    | otherwise               = empty++-------------------------------------------------------------------------------+-- isEmpty+-------------------------------------------------------------------------------++-- | Whether 'ERE' is (structurally) equal to 'empty'.+isEmpty :: ERE c -> Bool+isEmpty (EREChars rs) = RSet.null rs+isEmpty _            = False++-- | Whether 'ERE' is (structurally) equal to 'everything'.+isEverything :: ERE c -> Bool+isEverything (ERENot (EREChars rs)) = RSet.null rs+isEverything _                      = 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 re = go Map.empty [re] where+    go :: Map (ERE c) (SF.SF c (ERE c))+       -> [ERE c]+       -> Map (ERE c) (SF.SF c (ERE c))+    go !acc [] = acc+    go acc (r : rs)+        | r `Map.member` acc = go acc rs+        | otherwise = go (Map.insert r pm acc) (SF.values pm ++ rs)+      where+        pm = P.toSF (\c -> derivate c r) (leadingChars r)++instance (Ord c, Enum c, Bounded c) => C.TransitionMap c (ERE c) where+    transitionMap = 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 (EREChars cs)    = P.fromRSet cs+leadingChars (EREUnion cs rs) = P.fromRSet cs <> foldMap leadingChars rs+leadingChars (EREStar r)      = leadingChars r+leadingChars (EREAppend rs)   = leadingCharsAppend rs+leadingChars (ERENot r)       = leadingChars r++leadingCharsAppend :: (Ord c, Enum c, Bounded c) => [ERE c] -> P.Partition c+leadingCharsAppend [] = P.whole+leadingCharsAppend (r : rs)+    | nullable r = leadingChars r <> leadingCharsAppend rs+    | otherwise  = leadingChars 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 x0 y0 = go mempty [(x0, y0)] where+    go :: Set (ERE c, ERE c) -> [(ERE c, ERE c)] -> Bool+    go !_ [] = True+    go acc (p@(x, y) : zs)+        | p `Set.member` acc = go acc zs+        -- if two regexps are structurally the same, we don't need to recurse.+        | x == y             = go (Set.insert p acc) zs+        | all agree ps       = go (Set.insert p acc) (ps ++ zs)+        | otherwise = False+      where+        cs = toList $ P.examples $ leadingChars x `P.wedge` leadingChars y+        ps = map (\c -> (derivate c x, derivate c y)) cs++    agree :: (ERE c, ERE c) -> Bool+    agree (x, y) = nullable x == nullable y++instance (Ord c, Enum c, Bounded c) => C.Equivalent c (ERE c) where+    equivalent = equivalent++-------------------------------------------------------------------------------+-- Instances+-------------------------------------------------------------------------------++instance Eq c => Semigroup (ERE c) where+    r <> r' = appends [r, r']++instance Eq c => Monoid (ERE c) where+    mempty  = eps+    mappend = (<>)+    mconcat = appends++instance (Ord c, Enum c) => JoinSemiLattice (ERE c) where+    r \/ r' = unions [r, r']++instance (Ord c, Enum c) => BoundedJoinSemiLattice (ERE c) where+    bottom = empty++instance (Ord c, Enum c) => MeetSemiLattice (ERE c) where+    r /\ r' = intersections [r, r']++instance (Ord c, Enum c) => BoundedMeetSemiLattice (ERE c) where+    top = everything++instance  (Ord c, Enum c) => Lattice (ERE c)+instance  (Ord c, Enum c) => BoundedLattice (ERE c)++instance c ~ Char => IsString (ERE c) where+    fromString = string++instance (Ord c, Enum c, Bounded c, QC.Arbitrary c) => QC.Arbitrary (ERE c) where+    arbitrary = QC.sized arb where+        c :: QC.Gen (ERE c)+        c = EREChars . RSet.fromRangeList <$> QC.arbitrary++        arb :: Int -> QC.Gen (ERE c)+        arb n | n <= 0    = QC.oneof [c, fmap char QC.arbitrary, pure eps]+              | otherwise = QC.oneof+            [ c+            , pure eps+            , fmap char QC.arbitrary+            , liftA2 (<>) (arb n2) (arb n2)+            , liftA2 (\/) (arb n2) (arb n2)+            , fmap star (arb n2)+            , fmap complement (arb n2)+            ]+          where+            n2 = n `div` 2++instance (QC.CoArbitrary c) => QC.CoArbitrary (ERE c) where+    coarbitrary (EREChars cs)    = QC.variant (0 :: Int) . QC.coarbitrary (RSet.toRangeList cs)+    coarbitrary (EREAppend rs)   = QC.variant (1 :: Int) . QC.coarbitrary rs+    coarbitrary (EREUnion cs rs) = QC.variant (2 :: Int) . QC.coarbitrary (RSet.toRangeList cs, Set.toList rs)+    coarbitrary (EREStar r)      = QC.variant (3 :: Int) . QC.coarbitrary r+    coarbitrary (ERENot r)       = QC.variant (4 :: Int) . QC.coarbitrary r++-------------------------------------------------------------------------------+-- JavaScript+-------------------------------------------------------------------------------++instance c ~ Char => Pretty (ERE c) where+    prettyS x = showChar '^' . go False x . showChar '$'+      where+        go :: Bool -> ERE Char -> ShowS+        go p (EREStar a)+            = parens p+            $ go True a . showChar '*'+        go p (EREAppend rs)+            = parens p $ goMany id rs+        go p (EREUnion cs rs)+            | RSet.null cs = goUnion p rs+            | Set.null rs  = prettyS cs+            | otherwise    = goUnion p (Set.insert (EREChars cs) rs)+        go _ (EREChars cs)+            = prettyS cs+        go p (ERENot r)+            = parens p $ showChar '~' . go True r++        goUnion p rs+            | Set.member eps rs = parens p $ goUnion' True . showChar '?'+            | otherwise         = goUnion' p+          where+            goUnion' p' = case Set.toList (Set.delete eps rs) of+                [] -> go True empty+                [r] -> go p' r+                (r:rs') -> parens True $ goSome1 (showChar '|') r rs'++        goMany :: ShowS -> [ERE Char] -> ShowS+        goMany sep = foldr (\a b -> go False a . sep . b) id++        goSome1 :: ShowS -> ERE Char -> [ERE Char] -> ShowS+        goSome1 sep r = foldl (\a b -> a . sep . go False b) (go False r)++        parens :: Bool -> ShowS -> ShowS+        parens True  s = showString "(" . s . showChar ')'+        parens False s = s++-------------------------------------------------------------------------------+-- Doctest+-------------------------------------------------------------------------------++-- $setup+-- >>> :set -XOverloadedStrings+-- >>> import Control.Monad (void)+-- >>> import Data.Foldable (traverse_)+-- >>> import Data.List (sort)+--+-- >>> import Test.QuickCheck ((===))+-- >>> import qualified Test.QuickCheck as QC+--+-- >>> import Kleene.Classes (match)+-- >>> let asEREChar :: ERE Char -> ERE Char; asEREChar = id
+ src/Kleene/Equiv.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE FunctionalDependencies     #-}+{-# LANGUAGE GADTs                      #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StandaloneDeriving         #-}+{-# LANGUAGE Trustworthy                #-}+{-# LANGUAGE UndecidableInstances       #-}+module Kleene.Equiv where++import Prelude ()+import Prelude.Compat++import Algebra.Lattice+       (BoundedJoinSemiLattice (..), JoinSemiLattice (..), joinLeq)+import Algebra.PartialOrd (PartialOrd (..))++import Kleene.Classes+import           Kleene.Internal.Pretty++-- | Regular-expressions for which '==' is 'equivalent'.+--+-- >>> let re1 = star "a" <> "a" :: RE Char+-- >>> let re2 = "a" <> star "a" :: RE Char+--+-- >>> re1 == re2+-- False+--+-- >>> Equiv re1 == Equiv re2+-- True+--+-- 'Equiv' is also a 'PartialOrd' (but not 'Ord'!)+--+-- >>> Equiv "a" `leq` Equiv (star "a" :: RE Char)+-- True+--+-- Not all regular expessions are 'comparable':+--+-- >>> let reA = Equiv "a" :: Equiv RE Char+-- >>> let reB = Equiv "b" :: Equiv RE Char+-- >>> (leq reA reB, leq reB reA)+-- (False,False)+--+newtype Equiv r c = Equiv (r c)+  deriving (Show, Semigroup, Monoid, BoundedJoinSemiLattice, JoinSemiLattice, Pretty)++instance Equivalent c (r c) => Eq (Equiv r c) where+    (==) = equivalent++-- | \(a \preceq b := a \lor b = b \)+instance (JoinSemiLattice (r c), Equivalent c (r c)) => PartialOrd (Equiv r c) where+    leq = joinLeq++deriving instance Kleene     c (r c) => Kleene     c (Equiv r c)+deriving instance Derivate   c (r c) => Derivate   c (Equiv r c)+deriving instance Match      c (r c) => Match      c (Equiv r c)+deriving instance Equivalent c (r c) => Equivalent c (Equiv r c)+deriving instance Complement c (r c) => Complement c (Equiv r c)++-- $setup+-- >>> import Kleene.RE (RE)
+ src/Kleene/Functor.hs view
@@ -0,0 +1,273 @@+{-# LANGUAGE CPP   #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE Safe  #-}+module Kleene.Functor (+    K,+    Greediness (..),+    -- * Constructors+    few,+    anyChar,+    oneof,+    char,+    charRange,+    dot,+    everything,+    everything1,+    -- * Queries+    isEmpty,+    isEverything,+    -- * Matching+    match,+    -- * Conversions+    toRE,+    toKleene,+    fromRE,+    toRA,+    ) where++import Prelude ()+import Prelude.Compat++import Algebra.Lattice     ((\/))+import Control.Applicative (Alternative (..), liftA2)+import Data.Foldable       (toList)+import Data.RangeSet.Map   (RSet)+import Data.String         (IsString (..))++import qualified Data.RangeSet.Map      as RSet+import qualified Text.Regex.Applicative as R++import qualified Kleene.Classes         as C+import           Kleene.Internal.Pretty+import           Kleene.Internal.Sets+import qualified Kleene.RE              as RE++-- | Star behaviour+data Greediness+    = Greedy    -- ^ 'many'+    | NonGreedy -- ^ 'few'+  deriving (Eq, Ord, Show, Enum, Bounded)++-- | 'Applicative' 'Functor' regular expression.+data K c a where+    KEmpty  :: K c a+    KPure   :: a -> K c a+    KChar   :: (Ord c, Enum c) => RSet c -> K c c+    KAppend :: (a -> b -> r) -> K c a -> K c b -> K c r+    KUnion  :: K c a -> K c a -> K c a+    KStar   :: Greediness -> K c a -> K c [a]++    -- optimisations+    KMap    :: (a -> b) -> K c a -> K c b -- could use Pure and Append+    KString :: Eq c => [c] -> K c [c]     -- could use Char and Append++instance (c ~ Char, IsString a) => IsString (K c a) where+    fromString s = KMap fromString (KString s)++instance Functor (K c) where+    fmap _ KEmpty          = KEmpty+    fmap f (KPure x)       = KPure (f x)+    fmap f (KMap g k)      = KMap (f . g) k+    fmap f (KAppend g a b) = KAppend (\x y -> f (g x y)) a b+    fmap f k                    = KMap f k++instance Applicative (K c) where+    pure = KPure++    KEmpty <*> _ = KEmpty+    _ <*> KEmpty = KEmpty++    KPure f <*> k = fmap f k+    k <*> KPure x = fmap ($ x) k++    f <*> x = KAppend ($) f x++#if MIN_VERSION_base(4,10,0)+    liftA2 = KAppend+#endif++instance Alternative (K c) where+    empty = KEmpty++    KEmpty <|> k = k+    k <|> KEmpty = k+    KChar a <|> KChar b = KChar (RSet.union a b)++    a <|> b = KUnion a b++    many KEmpty      = KPure []+    many (KStar _ k) = KMap pure (KStar Greedy k)+    many k           = KStar Greedy k++    some KEmpty      = KEmpty+    some (KStar _ k) = KMap pure (KStar Greedy k)+    some k           = liftA2 (:) k (KStar Greedy k)++-- | 'few', not 'many'.+--+-- Let's define two similar regexps+--+-- >>> let re1 = liftA2 (,) (few  $ char 'a') (many $ char 'a')+-- >>> let re2 = liftA2 (,) (many $ char 'a') (few  $ char 'a')+--+-- Their 'RE' behaviour is the same:+--+-- >>> C.equivalent (toRE re1) (toRE re2)+-- True+--+-- >>> map (C.match $ toRE re1) ["aaa","bbb"]+-- [True,False]+--+-- However, the 'RA' behaviour is different!+--+-- >>> R.match (toRA re1) "aaaa"+-- Just ("","aaaa")+--+-- >>> R.match (toRA re2) "aaaa"+-- Just ("aaaa","")+--+few :: K c a -> K c [a]+few KEmpty      = KPure []+few (KStar _ k) = KMap pure (KStar NonGreedy k)+few k           = KStar NonGreedy k++-------------------------------------------------------------------------------+--+-------------------------------------------------------------------------------++-- | >>> putPretty anyChar+-- ^[^]$+anyChar :: (Ord c, Enum c, Bounded c) => K c c+anyChar = KChar RSet.full++-- | >>> putPretty $ oneof ("foobar" :: [Char])+-- ^[a-bfor]$+oneof :: (Ord c, Enum c, Foldable f) => f c -> K c c+oneof = KChar . RSet.fromList . toList++-- | >>> putPretty $ char 'x'+-- ^x$+char :: (Ord c, Enum c) => c -> K c c+char = KChar . RSet.singleton++-- | >>> putPretty $ charRange 'a' 'z'+-- ^[a-z]$+charRange :: (Enum c, Ord c) => c -> c -> K c c+charRange a b = KChar (RSet.singletonRange (a, b))++-- | >>> putPretty dot+-- ^.$+dot :: K Char Char+dot = KChar dotRSet++-- | >>> putPretty everything+-- ^[^]*$+everything :: (Ord c, Enum c, Bounded c) => K c [c]+everything = many anyChar++-- | >>> putPretty everything1+-- ^[^][^]*$+everything1 :: (Ord c, Enum c, Bounded c) => K c [c]+everything1 = some anyChar++-- | Matches nothing?+isEmpty :: (Ord c, Enum c, Bounded c) => K c a -> Bool+isEmpty k = C.equivalent (toRE k) C.empty++-- | Matches whole input?+isEverything :: (Ord c, Enum c, Bounded c) => K c a -> Bool+isEverything k = C.equivalent (toRE k) C.everything++-------------------------------------------------------------------------------+-- Matching+-------------------------------------------------------------------------------++-- | Match using @regex-applicative@+match :: K c a -> [c] -> Maybe a+match = R.match . toRA++-------------------------------------------------------------------------------+-- RE+-------------------------------------------------------------------------------++-- | Convert to 'RE'.+--+-- >>> putPretty (toRE $ many "foo" :: RE.RE Char)+-- ^(foo)*$+--+toRE :: (Ord c, Enum c, Bounded c) => K c a -> RE.RE c+toRE = toKleene++-- | Convert to any 'Kleene'+toKleene :: C.FiniteKleene c k => K c a -> k+toKleene (KMap _ a)      = toKleene a+toKleene (KUnion a b)    = toKleene a \/ toKleene b+toKleene (KAppend _ a b) = toKleene a <> toKleene b+toKleene (KStar _ a)     = C.star (toKleene a)+toKleene (KString s)     = C.appends (map C.char s)+toKleene KEmpty          = C.empty+toKleene (KPure _)       = C.eps+toKleene (KChar cs)      = C.fromRSet cs++-- | Convert from 'RE'.+--+-- /Note:/ all 'RE.REStar's are converted to 'Greedy' ones,+-- it doesn't matter, as we don't capture anything.+--+-- >>> match (fromRE "foobar") "foobar"+-- Just "foobar"+--+-- >>> match (fromRE $ C.star "a" <> C.star "a") "aaaa"+-- Just "aaaa"+--+fromRE :: (Ord c, Enum c) => RE.RE c -> K c [c]+fromRE (RE.REChars cs)    = pure <$> KChar cs+fromRE (RE.REAppend rs)   = concat <$> traverse fromRE rs+fromRE (RE.REUnion cs rs) = foldr (KUnion . fromRE) (pure <$> KChar cs) (toList rs)+fromRE (RE.REStar r)      = concat <$> KStar Greedy (fromRE r)++-------------------------------------------------------------------------------+-- regex-applicative+-------------------------------------------------------------------------------++-- | Convert 'K' to 'R.RE' from @regex-applicative@.+--+-- >>> R.match (toRA ("xx" *> everything <* "zz" :: K Char String)) "xxyyyzz"+-- Just "yyy"+--+-- See also 'match'.+--+toRA :: K c a -> R.RE c a+toRA KEmpty              = empty+toRA (KPure x)           = pure x+toRA (KChar cs)          = R.psym (\c -> RSet.member c cs)+toRA (KAppend f a b)     = liftA2 f (toRA a) (toRA b)+toRA (KUnion a b)        = toRA a <|> toRA b+toRA (KStar Greedy a)    = many (toRA a)+toRA (KStar NonGreedy a) = R.few (toRA a)+toRA (KMap f a)          = fmap f (toRA a)+toRA (KString s)         = R.string s++-------------------------------------------------------------------------------+-- JavaScript+-------------------------------------------------------------------------------++-- | Convert to non-matching JavaScript string which can be used+-- as an argument to @new RegExp@+--+-- >>> putPretty ("foobar" :: K Char String)+-- ^foobar$+--+-- >>> putPretty $ many ("foobar" :: K Char String)+-- ^(foobar)*$+--+instance c ~ Char => Pretty (K c a) where+    pretty = pretty . toRE++-------------------------------------------------------------------------------+-- Doctest+-------------------------------------------------------------------------------++-- $setup+--+-- >>> :set -XOverloadedStrings
+ src/Kleene/Internal/Partition.hs view
@@ -0,0 +1,184 @@+{-# LANGUAGE Safe #-}+module Kleene.Internal.Partition where++import Prelude ()+import Prelude.Compat++import Data.Foldable             (toList)+import Data.List.NonEmpty.Compat (NonEmpty (..))+import Data.RangeSet.Map         (RSet)+import Data.Set                  (Set)++import qualified Data.Function.Step.Discrete.Closed as SF+import qualified Data.List.NonEmpty.Compat          as NE+import qualified Data.RangeSet.Map                  as RSet+import qualified Data.Set                           as Set++import Test.QuickCheck++-- | 'Partition' devides type into disjoint connected partitions.+--+-- /Note:/ we could have non-connecter partitions too,+-- but that would be more complicated.+-- This variant is correct by construction, but less precise.+--+-- It's enought to store last element of each piece.+--+-- @'Partition' (fromList [x1, x2, x3]) :: 'Partition' s@ describes a partition of /Set/ @s@, as+--+-- \[+-- \{ x \mid x \le x_1 \} \cup+-- \{ x \mid x_1 < x \le x_2 \} \cup+-- \{ x \mid x_2 < x \le x_3 \} \cup+-- \{ x \mid x_3 < x \}+-- \]+--+-- /Note:/ it's enough to check upper bound conditions only if checks are performed in order.+--+-- /Invariant:/ 'maxBound' is not in the set.+--+newtype Partition a  = Partition { unPartition :: Set a }+  deriving (Eq, Ord)++-- | Check invariant.+invariant :: (Ord a, Bounded a) => Partition a -> Bool+invariant (Partition xs) = Set.notMember maxBound xs++-------------------------------------------------------------------------------+-- Instances+-------------------------------------------------------------------------------++instance Show a => Show (Partition a) where+    showsPrec d (Partition xs)+        = showParen (d > 10)+        $ showString "fromSeparators "+        . showsPrec 11 (Set.toList xs)++-- | prop> invariant (asPartitionChar p)+instance (Enum a, Bounded a, Ord a, Arbitrary a) => Arbitrary (Partition a) where+    arbitrary = fromSeparators <$> arbitrary++-- | See 'wedge'.+instance (Enum a, Bounded a, Ord a) => Semigroup (Partition a) where+    (<>) = wedge++instance (Enum a, Bounded a, Ord a) => Monoid (Partition a) where+    mempty = whole+    mappend = (<>)++-------------------------------------------------------------------------------+-- Constructors+-------------------------------------------------------------------------------++fromSeparators :: (Enum a, Bounded a, Ord a) => [a] -> Partition a+fromSeparators = Partition . Set.fromList . filter (/= maxBound)++-- | Construct 'Partition' from list of 'RSet's.+--+-- RSet intervals are closed on both sides.+fromRSets :: (Enum a, Bounded a, Ord a) => [RSet a] -> Partition a+fromRSets rs = Partition $ Set.fromList $ concat+    [ (if x == minBound then [] else [pred x]) +++      (if y == maxBound then [] else [y])+    | r <- rs+    , (x, y) <- RSet.toRangeList r+    ]++fromRSet :: (Enum a, Bounded a, Ord a) => RSet a -> Partition a+fromRSet r+    | r == RSet.empty = whole+    | r == RSet.full  = whole+    | otherwise       = fromRSets [r]++whole :: Partition a+whole = Partition Set.empty++-------------------------------------------------------------------------------+-- Querying+-------------------------------------------------------------------------------++-- | Count of sets in a 'Partition'.+--+-- >>> size whole+-- 1+--+-- >>> size $ split (10 :: Word8)+-- 2+--+-- prop> size (asPartitionChar p) >= 1+--+size :: Partition a -> Int+size (Partition xs) = 1 + length xs++-- | Extract examples from each subset in a 'Partition'.+--+-- >>> examples $ split (10 :: Word8)+-- fromList [10,255]+--+-- >>> examples $ split (10 :: Word8) <> split 20+-- fromList [10,20,255]+--+-- prop> invariant p ==> size (asPartitionChar p) === length (examples p)+--+examples :: (Bounded a, Enum a, Ord a) => Partition a -> Set a+examples (Partition xs) = Set.insert maxBound xs++-- |+--+-- prop> all (curry (<=)) $ intervals $ asPartitionChar p+intervals :: (Enum a, Bounded a, Ord a) => Partition a -> NonEmpty (a, a)+intervals (Partition xs) = go minBound (toList xs) where+    go x []       = (x, maxBound) :| []+    go x (y : ys) = (x, y) `NE.cons` go y ys++-------------------------------------------------------------------------------+--+-- Operations+-------------------------------------------------------------------------------++-- | Wedge partitions.+--+-- >>> split (10 :: Word8) <> split 20+-- fromSeparators [10,20]+--+-- prop> whole `wedge` (p :: Partition Char) === p+-- prop> (p :: Partition Char) <> whole === p+-- prop> asPartitionChar p <> q === q <> p+-- prop> asPartitionChar p <> p === p+-- prop> invariant $ asPartitionChar p <> q+--+wedge :: Ord a => Partition a -> Partition a -> Partition a+wedge (Partition as) (Partition bs) = Partition (Set.union as bs)++-- | Simplest partition: given @x@ partition space into @[min..x) and [x .. max]@+--+-- >>> split (128 :: Word8)+-- fromSeparators [128]+--+split :: (Enum a, Bounded a, Eq a) => a -> Partition a+split x+    | x == minBound = Partition Set.empty+    | otherwise     = Partition (Set.singleton x)++-------------------------------------------------------------------------------+-- Conversion+-------------------------------------------------------------------------------++-- | Make a step function.+toSF :: (Enum a, Bounded a, Ord a) => (a -> b) -> Partition a -> SF.SF a b+toSF f (Partition p) = SF.fromList+    (map (\k -> (k, f k)) $ toList as)+    (f maxBound)+  where+    as = toList p++-------------------------------------------------------------------------------+-- Doctest+-------------------------------------------------------------------------------++-- $setup+-- >>> import Data.Word+-- >>> import Test.QuickCheck ((===))+--+-- >>> let asPartitionChar :: Partition Char -> Partition Char; asPartitionChar = id+-- >>> instance (Ord a, Enum a, Arbitrary a) => Arbitrary (RSet a) where arbitrary = fmap RSet.fromRangeList arbitrary
+ src/Kleene/Internal/Pretty.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE Safe  #-}+module Kleene.Internal.Pretty (+    Pretty (..),+    putPretty,+    ) where++import Prelude ()+import Prelude.Compat++import Data.Monoid          (Endo (..))+import Data.RangeSet.Map    (RSet)+import Kleene.Internal.Sets (dotRSet)++import qualified Data.RangeSet.Map as RSet++-------------------------------------------------------------------------------+-- Pretty+-------------------------------------------------------------------------------++-- | Pretty class.+--+-- For @'pretty' :: 'Kleene.RE.RE' -> 'String'@ gives a+-- representation accepted by many regex engines.+--+class Pretty a where+    pretty :: a -> String+    pretty x = prettyS x ""++    prettyS :: a -> ShowS+    prettyS = showString . pretty++    {-# MINIMAL pretty | prettyS #-}++-- | @'putStrLn' . 'pretty'@+putPretty :: Pretty a => a -> IO ()+putPretty = putStrLn . pretty++instance c ~ Char => Pretty (RSet c) where+    prettyS cs+        | RSet.size cs == 1 = prettyS (head (RSet.elems cs))+        | cs == dotRSet  = showChar '.'+        | ics == dotRSet = showString "[^.]"+        | RSet.size cs < RSet.size ics = prettyRSet True cs+        | otherwise                    = prettyRSet False ics+      where+        ics = RSet.complement cs++prettyRSet :: Bool -> RSet Char -> ShowS+prettyRSet c cs+    = showChar '['+    . (if c then id else showChar '^')+    . appEndo (foldMap (Endo . f) (RSet.toRangeList cs))+    . showChar ']'+  where+    f (a, b)+      | a == b = prettyS a+      | otherwise = prettyS a . showChar '-' . prettyS b++-- | Escapes special regexp characters+instance Pretty Char where+    prettyS '.' = showString "\\."+    prettyS '-' = showString "\\-"+    prettyS '^' = showString "\\^"+    prettyS '*' = showString "\\*"+    prettyS '+' = showString "\\+"+    prettyS '?' = showString "\\?"+    prettyS '(' = showString "\\("+    prettyS ')' = showString "\\)"+    prettyS '[' = showString "\\["+    prettyS ']' = showString "\\]"+    prettyS '\r' = showString "\\r"+    prettyS '\n' = showString "\\n"+    prettyS '\t' = showString "\\t"+    prettyS c   = showChar c++instance Pretty Bool where+    prettyS True  = showChar '1'+    prettyS False = showChar '0'++instance Pretty () where+    prettyS _ = showChar '.'
+ src/Kleene/Internal/Sets.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE Safe #-}+-- | Character sets.+module Kleene.Internal.Sets (+    dotRSet,+    ) where++import Data.RangeSet.Map (RSet)++import qualified Data.RangeSet.Map as RSet++-- | All but the newline.+dotRSet :: RSet Char+dotRSet = RSet.full RSet.\\ RSet.singleton '\n'
+ src/Kleene/Monad.hs view
@@ -0,0 +1,459 @@+{-# LANGUAGE DeriveFoldable         #-}+{-# LANGUAGE DeriveFunctor          #-}+{-# LANGUAGE DeriveTraversable      #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs                  #-}+{-# LANGUAGE Safe                   #-}+{-# LANGUAGE ScopedTypeVariables    #-}+module Kleene.Monad (+    M (..),+    -- * Construction+    --+    -- | Binary operators are+    --+    -- * '<>' for append+    -- * '\/' for union+    --+    empty,+    eps,+    char,+    charRange,+    anyChar,+    appends,+    unions,+    star,+    string,+    -- * Derivative+    nullable,+    derivate,+    -- * Generation+    generate,+    -- * Conversion+    toKleene,+    -- * Other+    isEmpty,+    isEps,+    ) where++import Prelude ()+import Prelude.Compat++import Algebra.Lattice     (BoundedJoinSemiLattice (..), JoinSemiLattice (..))+import Control.Applicative (liftA2)+import Control.Monad       (ap)+import Data.Foldable       (toList)+import Data.List           (foldl')+import Data.String         (IsString (..))++import qualified Test.QuickCheck        as QC+import qualified Test.QuickCheck.Gen    as QC (unGen)+import qualified Test.QuickCheck.Random as QC (mkQCGen)++import qualified Kleene.Classes         as C+import           Kleene.Internal.Pretty++-- | Regular expression which has no restrictions on the elements.+-- Therefore we can have 'Monad' instance, i.e. have a regexp where +-- characters are regexps themselves.+--+-- Because there are no optimisations, it's better to work over small alphabets.+-- On the other hand, we can work over infinite alphabets, if we only+-- use small amount of symbols!+--+-- >>> putPretty $ string [True, False]+-- ^10$+--+-- >>> let re  = string [True, False, True]+-- >>> let re' = re >>= \b -> if b then char () else star (char ())+-- >>> putPretty re'+-- ^..*.$+--+data M c+    = MChars [c]        -- ^ One of the characters+    | MAppend [M c]     -- ^ Concatenation+    | MUnion [c] [M c]  -- ^ Union+    | MStar (M c)       -- ^ Kleene star+  deriving (Eq, Ord, Show, Functor, Foldable, Traversable)++instance Applicative M where+    pure = MChars . pure+    (<*>) = ap++instance Monad M where+    return = pure++    MChars []    >>= _  = MChars []+    MChars cs    >>= k  = appends (map k cs)+    MAppend rs   >>= k  = appends (map (>>= k) rs)+    MUnion cs rs >>= k  = unions (map (>>= k) (MChars cs : rs))+    MStar r      >>= k  = star (r >>= k)++-------------------------------------------------------------------------------+-- Smart constructor+-------------------------------------------------------------------------------++-- | Empty regex. Doesn't accept anything.+--+-- >>> putPretty (empty :: M Bool)+-- ^[]$+--+-- >>> putPretty (bottom :: M Bool)+-- ^[]$+--+-- prop> match (empty :: M Bool) (s :: String) === False+--+empty :: M c+empty = MChars []++-- | Empty string. /Note:/ different than 'empty'.+--+-- >>> putPretty (eps :: M Bool)+-- ^$+--+-- >>> putPretty (mempty :: M Bool)+-- ^$+--+-- prop> match (eps :: M Bool) s === null (s :: String)+--+eps :: M c+eps = MAppend []++-- |+--+-- >>> putPretty (char 'x')+-- ^x$+--+char :: c -> M c+char = MChars . pure++-- | /Note:/ we know little about @c@.+--+-- >>> putPretty $ charRange 'a' 'z'+-- ^[abcdefghijklmnopqrstuvwxyz]$+--+charRange :: Enum c => c -> c -> M c+charRange c c' = MChars [c .. c']+++-- | Any character. /Note:/ different than dot!+--+-- >>> putPretty (anyChar :: M Bool)+-- ^[01]$+--+anyChar :: (Bounded c, Enum c) => M c+anyChar = MChars [minBound .. maxBound]++-- | Concatenate regular expressions.+--+appends :: [M c] -> M c+appends rs0+    | any isEmpty rs1 = empty+    | otherwise = case rs1 of+        [r] -> r+        rs  -> MAppend rs+  where+    -- flatten one level of MAppend+    rs1 = concatMap f rs0++    f (MAppend rs) = rs+    f r             = [r]++-- | Union of regular expressions.+--+-- Lattice laws don't hold structurally:+--+unions :: [M c] -> M c+unions = uncurry mk . foldMap f where+    mk cs rss+        | null rss = MChars cs+        | null cs = case rss of+            []  -> empty+            [r] -> r+            _   -> MUnion cs rss+        | otherwise    = MUnion cs rss++    f (MUnion cs rs) = (cs, rs)+    f (MChars cs)    = (cs, [])+    f r              = ([], [r])++-- | Kleene star.+--+star :: M c -> M c+star r = case r of+    MStar _                    -> r+    MAppend []                 -> eps+    MChars cs | null cs        -> eps+    MUnion cs rs | any isEps rs -> case rs' of+        []             -> star (MChars cs)+        [r'] | null cs -> star r'+        _              -> MStar (MUnion cs rs')+      where+        rs' = filter (not . isEps) rs+    _                          -> MStar r++-- | Literal string.+--+-- >>> putPretty ("foobar" :: M Char)+-- ^foobar$+--+-- >>> putPretty ("(.)" :: M Char)+-- ^\(\.\)$+--+-- >>> putPretty $ string [False, True]+-- ^01$+--+string :: [c] -> M c+string []  = eps+string [c] = MChars [c]+string cs  = MAppend $ map (MChars . pure) cs++instance C.Kleene c (M c) where+    empty      = empty+    eps        = eps+    char       = char+    appends    = appends+    unions     = unions+    star       = star++-------------------------------------------------------------------------------+-- derivative+-------------------------------------------------------------------------------++-- | We say that a regular expression r is nullable if the language it defines+-- contains the empty string.+--+-- >>> nullable eps+-- True+--+-- >>> nullable (star "x")+-- True+--+-- >>> nullable "foo"+-- False+--+nullable :: M c -> Bool+nullable (MChars _)      = False+nullable (MAppend rs)    = all nullable rs+nullable (MUnion _cs rs) = any nullable rs+nullable (MStar _)       = 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 :: (Eq c, Enum c, Bounded c) => c -> M c -> M c+derivate c (MChars cs)     = derivateChars c cs+derivate c (MUnion cs rs)  = unions $ derivateChars c cs : [ derivate c r | r <- toList rs]+derivate c (MAppend rs)    = derivateAppend c rs+derivate c rs@(MStar r)    = derivate c r <> rs++derivateAppend :: (Eq c, Enum c, Bounded c) => c -> [M c] -> M c+derivateAppend _ []      = empty+derivateAppend c [r]     = derivate c r+derivateAppend c (r:rs)+    | nullable r         = unions [r' <> appends rs, rs']+    | otherwise          = r' <> appends rs+  where+    r'  = derivate c r+    rs' = derivateAppend c rs++derivateChars :: Eq c =>  c -> [c] -> M c+derivateChars c cs+    | c `elem` cs = eps+    | otherwise   = empty++instance (Eq c, Enum c, Bounded c) => C.Derivate c (M c) where+    nullable = nullable+    derivate = derivate++instance (Eq c, Enum c, Bounded c) => C.Match c (M c) where+    match r = nullable . foldl' (flip derivate) r++-------------------------------------------------------------------------------+-- isEmpty+-------------------------------------------------------------------------------++-- | Whether 'M' is (structurally) equal to 'empty'.+isEmpty :: M c -> Bool+isEmpty (MChars rs) = null rs+isEmpty _           = False++-- | Whether 'M' is (structurally) equal to 'eps'.+isEps :: M c -> Bool+isEps (MAppend rs) = null rs+isEps _            = False++-------------------------------------------------------------------------------+-- Generation+-------------------------------------------------------------------------------++-- | Generate random strings of the language @M c@ describes.+--+-- >>> let example = traverse_ print . take 3 . generate 42+-- >>> example "abc"+-- "abc"+-- "abc"+-- "abc"+--+-- >>> example $ star $ "a" \/ "b"+-- "ababbb"+-- "baab"+-- "abbababaa"+--+-- xx >>> example empty+--+-- expensive-prop> all (match r) $ take 10 $ generate 42 (r :: M Bool)+--+generate+    :: Int    -- ^ seed+    -> M c+    -> [[c]]  -- ^ infinite list of results+generate seed re+    | isEmpty re = []+    | otherwise  = QC.unGen (QC.infiniteListOf (generator re)) (QC.mkQCGen seed) 10++generator :: M c -> QC.Gen [c]+generator = go where+    go (MChars cs)    = goChars cs+    go (MAppend rs)   = concat <$> traverse go rs+    go (MUnion cs rs)+        | null cs   = QC.oneof [ go r | r <- toList rs ]+        | otherwise = QC.oneof $ goChars cs : [ go r | r <- toList rs ]+    go (MStar r)      = QC.sized $ \n -> do+        n' <- QC.choose (0, n)+        concat <$> sequence (replicate n' (go r))++    goChars cs = pure <$> QC.elements cs++-------------------------------------------------------------------------------+-- Conversion+-------------------------------------------------------------------------------++-- | Convert to 'Kleene'+--+-- >>> let re = charRange 'a' 'z'+-- >>> putPretty re+-- ^[abcdefghijklmnopqrstuvwxyz]$+--+-- >>> putPretty (toKleene re :: RE Char)+-- ^[a-z]$+--+toKleene :: C.Kleene c k => M c -> k+toKleene (MChars cs)    = C.oneof cs+toKleene (MAppend rs)   = C.appends (map toKleene rs)+toKleene (MUnion cs rs) = C.unions (C.oneof cs : map toKleene rs)+toKleene (MStar r)      = C.star (toKleene r)++-------------------------------------------------------------------------------+-- Instances+-------------------------------------------------------------------------------++instance Semigroup (M c) where+    r <> r' = appends [r, r']++instance Monoid (M c) where+    mempty  = eps+    mappend = (<>)+    mconcat = appends++instance JoinSemiLattice (M c) where+    r \/ r' = unions [r, r']++instance BoundedJoinSemiLattice (M c) where+    bottom = empty++instance c ~ Char => IsString (M c) where+    fromString = string++instance (Eq c, Enum c, Bounded c, QC.Arbitrary c) => QC.Arbitrary (M c) where+    arbitrary = QC.sized arb where+        c :: QC.Gen (M c)+        c = MChars <$> QC.arbitrary++        arb :: Int -> QC.Gen (M c)+        arb n | n <= 0    = QC.oneof [c, fmap char QC.arbitrary, pure eps]+              | otherwise = QC.oneof+            [ c+            , pure eps+            , fmap char QC.arbitrary+            , liftA2 (<>) (arb n2) (arb n2)+            , liftA2 (\/) (arb n2) (arb n2)+            , fmap star (arb n2)+            ]+          where+            n2 = n `div` 2++instance (QC.CoArbitrary c) => QC.CoArbitrary (M c) where+    coarbitrary (MChars cs)    = QC.variant (0 :: Int) . QC.coarbitrary cs+    coarbitrary (MAppend rs)   = QC.variant (1 :: Int) . QC.coarbitrary rs+    coarbitrary (MUnion cs rs) = QC.variant (2 :: Int) . QC.coarbitrary (cs, rs)+    coarbitrary (MStar r)      = QC.variant (3 :: Int) . QC.coarbitrary r++-------------------------------------------------------------------------------+-- JavaScript+-------------------------------------------------------------------------------++instance (Pretty c, Eq c) => Pretty (M c) where+    prettyS x = showChar '^' . go False x . showChar '$'+      where+        go :: Bool -> M c -> ShowS+        go p (MStar a)+            = parens p+            $ go True a . showChar '*'+        go p (MAppend rs)+            = parens p $ goMany id rs+        go p (MUnion cs rs)+            | null cs   = goUnion p rs+            | null rs   = prettySList cs+            | otherwise = goUnion p (MChars cs : rs)+        go _ (MChars cs)+            = prettySList cs++        goUnion p rs+            | elem eps rs = parens p $ goUnion' True . showChar '?'+            | otherwise   = goUnion' p+          where+            goUnion' p' = case filter (/= eps) rs of+                []      -> go True empty+                [r]     -> go p' r+                (r:rs') -> parens True $ goSome1 (showChar '|') r rs'++        goMany :: ShowS -> [M c] -> ShowS+        goMany sep = foldr (\a b -> go False a . sep . b) id++        goSome1 :: ShowS -> M c -> [M c] -> ShowS+        goSome1 sep r = foldl (\a b -> a . sep . go False b) (go False r)++        parens :: Bool -> ShowS -> ShowS+        parens True  s = showString "(" . s . showChar ')'+        parens False s = s++        prettySList :: [c] -> ShowS+        prettySList [c] = prettyS c+        prettySList xs  = showChar '[' . foldr (\a b -> prettyS a . b) (showChar ']') xs++-------------------------------------------------------------------------------+-- Doctest+-------------------------------------------------------------------------------++-- $setup+-- >>> :set -XOverloadedStrings+-- >>> import Data.Foldable (traverse_)+-- >>> import Data.List (sort)+--+-- >>> import Test.QuickCheck ((===))+-- >>> import qualified Test.QuickCheck as QC+--+-- >>> import Kleene.RE (RE)+-- >>> import Kleene.Classes (match)+-- >>> let asMBool :: M Bool -> M Bool; asMBool = id
+ src/Kleene/RE.hs view
@@ -0,0 +1,603 @@+{-# LANGUAGE BangPatterns           #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs                  #-}+{-# LANGUAGE Safe                   #-}+{-# LANGUAGE ScopedTypeVariables    #-}+module Kleene.RE (+    RE (..),+    -- * Construction+    --+    -- | Binary operators are+    --+    -- * '<>' for append+    -- * '\/' for union+    --+    empty,+    eps,+    char,+    charRange,+    anyChar,+    appends,+    unions,+    star,+    string,+    -- * Derivative+    nullable,+    derivate,+    -- * Transition map+    transitionMap,+    leadingChars,+    -- * Equivalence+    equivalent,+    -- * Generation+    generate,+    -- * Other+    isEmpty,+    ) where++import Prelude ()+import Prelude.Compat++import Algebra.Lattice     (BoundedJoinSemiLattice (..), JoinSemiLattice (..))+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++-- | 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 (Eq, Ord, 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 = REChars RSet.empty++-- | Everything.+--+-- >>> putPretty everything+-- ^[^]*$+--+-- prop> match (everything :: RE Char) (s :: String) === True+--+everything :: Bounded c => RE c+everything = REStar (REChars 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 = REAppend []++-- |+--+-- >>> putPretty (char 'x')+-- ^x$+--+char :: c -> RE c+char = REChars . RSet.singleton++-- |+--+-- >>> putPretty $ charRange 'a' 'z'+-- ^[a-z]$+--+charRange :: Ord c => c -> c -> RE c+charRange c c' = REChars $ RSet.singletonRange (c, c')++-- | Any character. /Note:/ different than dot!+--+-- >>> putPretty anyChar+-- ^[^]$+--+anyChar :: Bounded c => RE c+anyChar = REChars 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 rs0+    | elem empty rs1 = empty+    | otherwise = case rs1 of+        [r] -> r+        rs  -> REAppend rs+  where+    -- flatten one level of REAppend+    rs1 = concatMap f rs0++    f (REAppend rs) = rs+    f r             = [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 = uncurry mk . foldMap f where+    mk cs rss+        | Set.null rss = REChars cs+        | Set.member everything rss = everything+        | RSet.null cs = case Set.toList rss of+            []  -> empty+            [r] -> r+            _   -> REUnion cs rss+        | otherwise    = REUnion cs rss++    f (REUnion cs rs) = (cs, rs)+    f (REChars cs)    = (cs, Set.empty)+    f r               = (mempty, Set.singleton 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 r = case r of+    REStar _                          -> r+    REAppend []                       -> eps+    REChars cs | RSet.null cs         -> eps+    REUnion cs rs | Set.member eps rs -> case Set.toList rs' of+        []                  -> star (REChars cs)+        [r'] | RSet.null cs -> star r'+        _                   -> REStar (REUnion cs rs')+      where+        rs' = Set.delete eps rs+    _                                 -> REStar r++-- | Literal string.+--+-- >>> putPretty ("foobar" :: RE Char)+-- ^foobar$+--+-- >>> putPretty ("(.)" :: RE Char)+-- ^\(\.\)$+--+string :: [c] -> RE c+string []  = eps+string [c] = REChars (RSet.singleton c)+string cs  = REAppend $ map (REChars . RSet.singleton) cs++instance (Ord c, Enum c, Bounded c) => C.Kleene c (RE c) where+    empty      = empty+    eps        = eps+    char       = char+    appends    = appends+    unions     = unions+    star       = star++instance (Ord c, Enum c, Bounded c) => C.FiniteKleene c (RE c) where+    everything = everything+    charRange  = charRange+    fromRSet   = REChars+    anyChar    = anyChar++-------------------------------------------------------------------------------+-- 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 (REChars _)      = False+nullable (REAppend rs)    = all nullable rs+nullable (REUnion _cs rs) = any nullable rs+nullable (REStar _)       = 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 c (REChars cs)     = derivateChars c cs+derivate c (REUnion cs rs)  = unions $ derivateChars c cs : [ derivate c r | r <- toList rs]+derivate c (REAppend rs)    = derivateAppend c rs+derivate c rs@(REStar r)    = derivate c r <> rs++derivateAppend :: (Ord c, Enum c, Bounded c) => c -> [RE c] -> RE c+derivateAppend _ []      = empty+derivateAppend c [r]     = derivate c r+derivateAppend c (r:rs)+    | nullable r         = unions [r' <> appends rs, rs']+    | otherwise          = r' <> appends rs+  where+    r'  = derivate c r+    rs' = derivateAppend c rs++derivateChars :: Ord c =>  c -> RSet c -> RE c+derivateChars c cs+    | c `RSet.member` cs      = eps+    | otherwise               = empty++instance (Ord c, Enum c, Bounded c) => C.Derivate c (RE c) where+    nullable = nullable+    derivate = derivate++instance (Ord c, Enum c, Bounded c) => C.Match c (RE c) where+    match r = nullable . foldl' (flip derivate) 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 (REChars rs) = RSet.null rs+isEmpty _            = 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 re = go Map.empty [re] where+    go :: Map (RE c) (SF.SF c (RE c))+       -> [RE c]+       -> Map (RE c) (SF.SF c (RE c))+    go !acc [] = acc+    go acc (r : rs)+        | r `Map.member` acc = go acc rs+        | otherwise = go (Map.insert r pm acc) (SF.values pm ++ rs)+      where+        pm = P.toSF (\c -> derivate c r) (leadingChars r)++instance (Ord c, Enum c, Bounded c) => C.TransitionMap c (RE c) where+    transitionMap = 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 (REChars cs)    = P.fromRSet cs+leadingChars (REUnion cs rs) = P.fromRSet cs <> foldMap leadingChars rs+leadingChars (REStar r)      = leadingChars r+leadingChars (REAppend rs)   = leadingCharsAppend rs++leadingCharsAppend :: (Ord c, Enum c, Bounded c) => [RE c] -> P.Partition c+leadingCharsAppend [] = P.whole+leadingCharsAppend (r : rs)+    | nullable r = leadingChars r <> leadingCharsAppend rs+    | otherwise  = leadingChars 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 x0 y0 = go mempty [(x0, y0)] where+    go :: Set (RE c, RE c) -> [(RE c, RE c)] -> Bool+    go !_ [] = True+    go acc (p@(x, y) : zs)+        | p `Set.member` acc = go acc zs+        -- if two regexps are structurally the same, we don't need to recurse.+        | x == y             = go (Set.insert p acc) zs+        | all agree ps       = go (Set.insert p acc) (ps ++ zs)+        | otherwise = False+      where+        cs = toList $ P.examples $ leadingChars x `P.wedge` leadingChars y+        ps = map (\c -> (derivate c x, derivate c y)) cs++    agree :: (RE c, RE c) -> Bool+    agree (x, y) = nullable x == nullable y++instance (Ord c, Enum c, Bounded c) => C.Equivalent c (RE c) where+    equivalent = 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"+-- "aaaaba"+-- "bbba"+-- "abbbbaaaa"+--+-- >>> 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 c seed re+    | isEmpty re = []+    | otherwise  = QC.unGen (QC.infiniteListOf (generator c re)) (QC.mkQCGen seed) 10++generator+    :: (c -> c -> QC.Gen c)+    -> RE c+    -> QC.Gen [c]+generator c = go where+    go (REChars cs)    = goChars cs+    go (REAppend rs)   = concat <$> traverse go rs+    go (REUnion cs rs)+        | RSet.null  cs = QC.oneof [ go r | r <- toList rs ]+        | otherwise     = QC.oneof $ goChars cs : [ go r | r <- toList rs ]+    go (REStar r)      = QC.sized $ \n -> do+        n' <- QC.choose (0, n)+        concat <$> sequence (replicate n' (go r))++    goChars cs = pure <$> QC.oneof [ c x y | (x,y) <- RSet.toRangeList cs ]++-------------------------------------------------------------------------------+-- Instances+-------------------------------------------------------------------------------++instance Eq c => Semigroup (RE c) where+    r <> r' = appends [r, r']++instance Eq c => Monoid (RE c) where+    mempty  = eps+    mappend = (<>)+    mconcat = appends++instance (Ord c, Enum c, Bounded c) => JoinSemiLattice (RE c) where+    r \/ r' = unions [r, r']++instance (Ord c, Enum c, Bounded c) => BoundedJoinSemiLattice (RE c) where+    bottom = empty++instance c ~ Char => IsString (RE c) where+    fromString = string++instance (Ord c, Enum c, Bounded c, QC.Arbitrary c) => QC.Arbitrary (RE c) where+    arbitrary = QC.sized arb where+        c :: QC.Gen (RE c)+        c = REChars . RSet.fromRangeList <$> QC.arbitrary++        arb :: Int -> QC.Gen (RE c)+        arb n | n <= 0    = QC.oneof [c, fmap char QC.arbitrary, pure eps]+              | otherwise = QC.oneof+            [ c+            , pure eps+            , fmap char QC.arbitrary+            , liftA2 (<>) (arb n2) (arb n2)+            , liftA2 (\/) (arb n2) (arb n2)+            , fmap star (arb n2)+            ]+          where+            n2 = n `div` 2++instance (QC.CoArbitrary c) => QC.CoArbitrary (RE c) where+    coarbitrary (REChars cs)    = QC.variant (0 :: Int) . QC.coarbitrary (RSet.toRangeList cs)+    coarbitrary (REAppend rs)   = QC.variant (1 :: Int) . QC.coarbitrary rs+    coarbitrary (REUnion cs rs) = QC.variant (2 :: Int) . QC.coarbitrary (RSet.toRangeList cs, Set.toList rs)+    coarbitrary (REStar r)      = QC.variant (3 :: Int) . QC.coarbitrary r++-------------------------------------------------------------------------------+-- JavaScript+-------------------------------------------------------------------------------++instance c ~ Char => Pretty (RE c) where+    prettyS x = showChar '^' . go False x . showChar '$'+      where+        go :: Bool -> RE Char -> ShowS+        go p (REStar a)+            = parens p+            $ go True a . showChar '*'+        go p (REAppend rs)+            = parens p $ goMany id rs+        go p (REUnion cs rs)+            | RSet.null cs = goUnion p rs+            | Set.null rs  = prettyS cs+            | otherwise    = goUnion p (Set.insert (REChars cs) rs)+        go _ (REChars cs)+            = prettyS cs++        goUnion p rs+            | Set.member eps rs = parens p $ goUnion' True . showChar '?'+            | otherwise         = goUnion' p+          where+            goUnion' p' = case Set.toList (Set.delete eps rs) of+                [] -> go True empty+                [r] -> go p' r+                (r:rs') -> parens True $ goSome1 (showChar '|') r rs'++        goMany :: ShowS -> [RE Char] -> ShowS+        goMany sep = foldr (\a b -> go False a . sep . b) id++        goSome1 :: ShowS -> RE Char -> [RE Char] -> ShowS+        goSome1 sep r = foldl (\a b -> a . sep . go False b) (go False r)++        parens :: Bool -> ShowS -> ShowS+        parens True  s = showString "(" . s . showChar ')'+        parens False s = s++-------------------------------------------------------------------------------+-- Doctest+-------------------------------------------------------------------------------++-- $setup+-- >>> :set -XOverloadedStrings+-- >>> import Control.Monad (void)+-- >>> import Data.Foldable (traverse_)+-- >>> import Data.List (sort)+--+-- >>> import Test.QuickCheck ((===))+-- >>> import qualified Test.QuickCheck as QC+--+-- >>> import Kleene.Classes (match)+-- >>> let asREChar :: RE Char -> RE Char; asREChar = id