diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -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 diff --git a/kleene.cabal b/kleene.cabal new file mode 100644 --- /dev/null +++ b/kleene.cabal @@ -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 + + +homepage: https://github.com/phadej/kleene +bug-reports: https://github.com/phadej/kleene/issues +author: Oleg Grenrus +maintainer: Oleg Grenrus +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 diff --git a/src/Kleene.hs b/src/Kleene.hs new file mode 100644 --- /dev/null +++ b/src/Kleene.hs @@ -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 +-- . +-- +-- >>> :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 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) diff --git a/src/Kleene/Classes.hs b/src/Kleene/Classes.hs new file mode 100644 --- /dev/null +++ b/src/Kleene/Classes.hs @@ -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 diff --git a/src/Kleene/DFA.hs b/src/Kleene/DFA.hs new file mode 100644 --- /dev/null +++ b/src/Kleene/DFA.hs @@ -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 +-- 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) diff --git a/src/Kleene/ERE.hs b/src/Kleene/ERE.hs new file mode 100644 --- /dev/null +++ b/src/Kleene/ERE.hs @@ -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 diff --git a/src/Kleene/Equiv.hs b/src/Kleene/Equiv.hs new file mode 100644 --- /dev/null +++ b/src/Kleene/Equiv.hs @@ -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) diff --git a/src/Kleene/Functor.hs b/src/Kleene/Functor.hs new file mode 100644 --- /dev/null +++ b/src/Kleene/Functor.hs @@ -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 diff --git a/src/Kleene/Internal/Partition.hs b/src/Kleene/Internal/Partition.hs new file mode 100644 --- /dev/null +++ b/src/Kleene/Internal/Partition.hs @@ -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 diff --git a/src/Kleene/Internal/Pretty.hs b/src/Kleene/Internal/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/Kleene/Internal/Pretty.hs @@ -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 '.' diff --git a/src/Kleene/Internal/Sets.hs b/src/Kleene/Internal/Sets.hs new file mode 100644 --- /dev/null +++ b/src/Kleene/Internal/Sets.hs @@ -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' diff --git a/src/Kleene/Monad.hs b/src/Kleene/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Kleene/Monad.hs @@ -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 diff --git a/src/Kleene/RE.hs b/src/Kleene/RE.hs new file mode 100644 --- /dev/null +++ b/src/Kleene/RE.hs @@ -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