diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,13 @@ +## 0.2 + +* Remove MChars constructor from Monad variant + +## 0.1.1 + +* Export `Kleene.Functor.NonEmpty.few1` +* Export `Kleene.RE.everything` and `Kleene.ERE.everything` +* Export `Equivalent` from `Kleene` + ## 0.1 * Drop superclasses from `Kleene`. diff --git a/kleene.cabal b/kleene.cabal --- a/kleene.cabal +++ b/kleene.cabal @@ -1,6 +1,6 @@ -cabal-version: 1.24 +cabal-version: 2.4 name: kleene -version: 0.1 +version: 0.2 synopsis: Kleene algebra category: Math description: @@ -16,41 +16,48 @@ bug-reports: https://github.com/phadej/kleene/issues author: Oleg Grenrus maintainer: Oleg Grenrus -license: BSD3 +license: BSD-3-Clause license-file: LICENSE build-type: Simple extra-source-files: CHANGELOG.md extra-doc-files: example.png tested-with: - GHC ==7.8.4 || ==7.10.3 || ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.1 + GHC ==8.6.5 + || ==8.8.4 + || ==8.10.7 + || ==9.0.2 + || ==9.2.8 + || ==9.4.8 + || ==9.6.7 + || ==9.8.4 + || ==9.10.3 + || ==9.12.4 + || ==9.14.1 source-repository head type: git location: https://github.com/phadej/kleene library + default-language: Haskell2010 + ghc-options: -Wall + hs-source-dirs: src + -- GHC boot libraries build-depends: - base >=4.7.0.2 && <4.13 - , bytestring >=0.10.4.0 && <0.11 - , containers >=0.5.5.1 && <0.7 - , text >=1.2.3.0 && <1.3 - , transformers >=0.3.0.0 && <0.6 - - if !impl(ghc >=8.0) - build-depends: semigroups >=0.18.5 && <0.19 + , base >=4.7.0.2 && <4.23 + , bytestring >=0.10.8.2 && <0.13 + , containers >=0.6.0.1 && <0.9 -- Other dependencies build-depends: - attoparsec - , base-compat >=0.10.5 && <0.11 - , lattices >=2 && <2.1 + , lattices >=2 && <2.3 , MemoTrie >=0.6.9 && <0.7 - , QuickCheck >=2.12.6.1 && <2.13 + , QuickCheck >=2.16.0.0 && <2.19 , range-set-list >=0.1.3 && <0.2 - , regex-applicative >=0.3.3 && <0.4 - , semigroupoids >=5.3.2 && <5.4 - , step-function >=0.2 && <0.3 + , regex-applicative >=0.3.4 && <0.4 + , semigroupoids >=5.3.2 && <6.1 + , step-function >=0.2.1 && <0.3 other-extensions: CPP @@ -70,8 +77,8 @@ Kleene Kleene.Classes Kleene.DFA - Kleene.ERE Kleene.Equiv + Kleene.ERE Kleene.Functor Kleene.Functor.NonEmpty Kleene.Monad @@ -79,14 +86,28 @@ -- "Internal-ish" modules exposed-modules: + Kleene.Internal.Functor Kleene.Internal.Partition Kleene.Internal.Pretty + Kleene.Internal.RE Kleene.Internal.Sets - other-modules: - Kleene.Internal.Functor - Kleene.Internal.RE + x-docspec-options: + -XOverloadedStrings --check-properties "--property-variables=c p r s t q" - ghc-options: -Wall - hs-source-dirs: src +test-suite kleene-utf8 default-language: Haskell2010 + ghc-options: -Wall + hs-source-dirs: tests + type: exitcode-stdio-1.0 + main-is: kleene-utf8.hs + build-depends: + , base + , bytestring + , kleene + + -- test dependencies + build-depends: + , tasty ^>=1.4.0.3 || ^>=1.5 + , tasty-hunit ^>=0.10.0.3 + , tasty-quickcheck ^>=0.11.1 diff --git a/src/Kleene.hs b/src/Kleene.hs --- a/src/Kleene.hs +++ b/src/Kleene.hs @@ -78,11 +78,11 @@ -- >>> import Kleene.RE (generate) -- -- >>> traverse_ print $ take 5 $ generate (curry QC.choose) 42 re --- "abcabcabcabcabcabcdefyz" --- "abcabcabcabcdefyz" --- "abcabcabcabcabcabcabcabcabcdefx" +-- "abcdefx" -- "abcabcdefx" --- "abcabcabcabcabcabcdefyz" +-- "abcdefyz" +-- "abcabcabcabcabcabcabcdefyz" +-- "abcabcabcabcabcabcabcdefyz" -- -- In addition to the "normal" regular expressions, there are /extended regular expressions/. -- Regular expressions which we can 'complement', and therefore intersect: @@ -164,6 +164,7 @@ FiniteKleene (..), Derivate (..), Match (..), + Equivalent (..), TransitionMap (..), Complement (..), ToLatin1 (..), diff --git a/src/Kleene/Classes.hs b/src/Kleene/Classes.hs --- a/src/Kleene/Classes.hs +++ b/src/Kleene/Classes.hs @@ -3,9 +3,6 @@ {-# LANGUAGE GADTs #-} module Kleene.Classes where -import Prelude () -import Prelude.Compat - import Data.Char (ord) import Data.Foldable (toList) import Data.Function.Step.Discrete.Closed (SF) diff --git a/src/Kleene/DFA.hs b/src/Kleene/DFA.hs --- a/src/Kleene/DFA.hs +++ b/src/Kleene/DFA.hs @@ -1,9 +1,9 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE Safe #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Kleene.DFA ( DFA (..), @@ -19,9 +19,6 @@ toDot', ) where -import Prelude () -import Prelude.Compat - import Algebra.Lattice (BoundedJoinSemiLattice (..), BoundedMeetSemiLattice (..), Lattice (..)) import Data.IntMap (IntMap) @@ -44,6 +41,29 @@ import Kleene.Internal.Pretty import qualified Kleene.Internal.RE as RE +-- $setup +-- >>> :set -XOverloadedStrings +-- >>> import Data.Foldable (traverse_) +-- >>> import Data.Semigroup (Semigroup (..)) +-- >>> import Algebra.Lattice ((/\)) +-- >>> import Kleene.Classes +-- >>> import Kleene.Internal.Pretty (putPretty) +-- >>> import Test.QuickCheck ((===)) +-- >>> import qualified Test.QuickCheck as QC +-- >>> import qualified Kleene.RE as RE +-- >>> import qualified Kleene.ERE as ERE +-- >>> import qualified Data.RangeSet.Map as RSet +-- +-- >>> 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) +-- +-- >>> let asREChar :: RE.RE Char -> RE.RE Char; asREChar = id + +------------------------------------------------------------------------------- +-- DFA +------------------------------------------------------------------------------- + -- | Deterministic finite automaton. -- -- A deterministic finite automaton (DFA) over an alphabet \(\Sigma\) (type @@ -234,7 +254,7 @@ -- -- For 'RE.string' regular expressions, @'toRE' . 'fromRE' = 'id'@: -- --- prop> let s = take 5 s' in RE.string (s :: String) === toRE (fromRE (RE.string s)) +-- prop> let s' = take 5 s in RE.string (s' :: String) === toRE (fromRE (RE.string s')) -- -- But in general it isn't: -- @@ -541,17 +561,3 @@ , let acc = if IntSet.member i (dfaAcceptable dfa) then "+" else "" , let bh = if IntSet.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) --- --- >>> let asREChar :: RE.RE Char -> RE.RE Char; asREChar = id diff --git a/src/Kleene/ERE.hs b/src/Kleene/ERE.hs --- a/src/Kleene/ERE.hs +++ b/src/Kleene/ERE.hs @@ -1,9 +1,9 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE Safe #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE ScopedTypeVariables #-} module Kleene.ERE ( ERE (..), -- * Construction @@ -16,6 +16,7 @@ -- empty, eps, + everything, char, charRange, anyChar, @@ -40,10 +41,6 @@ isEverything, ) where -import Data.Semigroup (Semigroup (..)) -import Prelude () -import Prelude.Compat - import Algebra.Lattice (BoundedJoinSemiLattice (..), BoundedMeetSemiLattice (..), Lattice (..)) import Control.Applicative (liftA2) @@ -65,6 +62,21 @@ import Kleene.Internal.Pretty import qualified Kleene.Internal.RE as RE +-- $setup +-- >>> import Algebra.Lattice ((/\), (\/), top, bottom) +-- >>> import Data.Semigroup (Semigroup (..)) +-- >>> import Control.Monad (void) +-- >>> import Data.Foldable (traverse_) +-- >>> import Data.List (sort) +-- >>> import Test.QuickCheck ((===)) +-- >>> import qualified Test.QuickCheck as QC +-- >>> import qualified Data.Map as Map +-- >>> import qualified Data.Function.Step.Discrete.Closed as SF +-- +-- >>> import Kleene.Classes (match) +-- >>> import Kleene.Internal.Pretty (putPretty, pretty) +-- >>> let asEREChar :: ERE Char -> ERE Char; asEREChar = id + -- | Extended regular expression -- -- It's both, /Kleene/ and /Boolean/ algebra. (If we add only intersections, it @@ -185,7 +197,7 @@ rs1 = concatMap f rs0 f (EREAppend rs) = rs - f r = [r] + f r = [r] -- | Union of regular expressions. -- @@ -614,19 +626,3 @@ toLatin1 (EREUnion rs xs) = C.fromRSet (C.toLatin1 rs) \/ unions (map C.toLatin1 (Set.toList xs)) toLatin1 (EREStar r) = star (C.toLatin1 r) toLatin1 (ERENot r) = complement (C.toLatin1 r) - -------------------------------------------------------------------------------- --- 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 --- a/src/Kleene/Equiv.hs +++ b/src/Kleene/Equiv.hs @@ -7,16 +7,21 @@ {-# LANGUAGE UndecidableInstances #-} module Kleene.Equiv where -import Prelude () -import Prelude.Compat - -import Algebra.Lattice (BoundedJoinSemiLattice (..), BoundedMeetSemiLattice (..), Lattice (..), joinLeq) +import Algebra.Lattice + (BoundedJoinSemiLattice (..), BoundedMeetSemiLattice (..), Lattice (..), + joinLeq) import Algebra.PartialOrd (PartialOrd (..)) import Data.Semigroup (Semigroup (..)) import Kleene.Classes import Kleene.Internal.Pretty +-- $setup +-- >>> import Kleene.RE (RE) +-- >>> import Kleene.Classes +-- >>> import Algebra.PartialOrd (leq) +-- >>> import Data.Semigroup (Semigroup (..)) + -- | Regular-expressions for which '==' is 'equivalent'. -- -- >>> let re1 = star "a" <> "a" :: RE Char @@ -56,6 +61,3 @@ 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 --- a/src/Kleene/Functor.hs +++ b/src/Kleene/Functor.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE Safe #-} +{-# LANGUAGE Safe #-} module Kleene.Functor ( K, Greediness (..), diff --git a/src/Kleene/Functor/NonEmpty.hs b/src/Kleene/Functor/NonEmpty.hs --- a/src/Kleene/Functor/NonEmpty.hs +++ b/src/Kleene/Functor/NonEmpty.hs @@ -6,6 +6,7 @@ Greediness (..), -- * Constructors some1, + few1, anyChar, oneof, char, @@ -25,9 +26,6 @@ nullableProof, ) where -import Prelude () -import Prelude.Compat - import Control.Applicative (Alternative (..), liftA2) import Data.Foldable (toList) import Data.Functor.Alt (()) @@ -46,6 +44,18 @@ import Kleene.Internal.Sets import qualified Kleene.RE as RE +-- $setup +-- +-- >>> import Control.Applicative (optional, Alternative (..)) +-- >>> import Data.Functor.Apply (Apply (..)) +-- >>> import Data.List.NonEmpty (NonEmpty (..)) +-- >>> import Kleene.Functor (Greediness (..), K (..)) +-- >>> import Data.Foldable (toList) +-- >>> import Kleene.Internal.Pretty (putPretty) +-- >>> import qualified Kleene.RE as RE +-- >>> import qualified Kleene.Classes as C +-- >>> import qualified Text.Regex.Applicative as R + -- | 'Applicative' 'Functor' regular expression. data K1 c a where K1Empty :: K1 c a @@ -276,12 +286,3 @@ -- instance c ~ Char => Pretty (K1 c a) where pretty = pretty . toRE - -------------------------------------------------------------------------------- --- Doctest -------------------------------------------------------------------------------- - --- $setup --- --- >>> :set -XOverloadedStrings --- >>> import Control.Applicative (optional) diff --git a/src/Kleene/Internal/Functor.hs b/src/Kleene/Internal/Functor.hs --- a/src/Kleene/Internal/Functor.hs +++ b/src/Kleene/Internal/Functor.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE Safe #-} +{-# OPTIONS_HADDOCK not-home #-} module Kleene.Internal.Functor ( K (..), Greediness (..), @@ -25,24 +26,35 @@ toRA, ) where -import Prelude () -import Prelude.Compat - import Control.Applicative (Alternative (..), liftA2) import Data.Foldable (toList) import Data.Functor.Apply (Apply (..)) import Data.RangeSet.Map (RSet) import Data.String (IsString (..)) +import qualified Data.Functor.Alt as Alt import qualified Data.RangeSet.Map as RSet import qualified Text.Regex.Applicative as R -import qualified Data.Functor.Alt as Alt import qualified Kleene.Classes as C import Kleene.Internal.Pretty import Kleene.Internal.Sets import qualified Kleene.RE as RE + +-- $setup +-- +-- >>> import Control.Applicative (Alternative (..), liftA2) +-- >>> import Data.Semigroup (Semigroup (..)) +-- >>> import Kleene.Internal.Pretty (putPretty) +-- >>> import qualified Kleene.Classes as C +-- >>> import qualified Kleene.RE as RE +-- >>> import qualified Text.Regex.Applicative as R + +------------------------------------------------------------------------------- +-- Functor RE +------------------------------------------------------------------------------- + -- | Star behaviour data Greediness = Greedy -- ^ 'many' @@ -70,7 +82,7 @@ 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 + fmap f k = KMap f k instance Apply (K c) where KEmpty <.> _ = KEmpty @@ -272,11 +284,3 @@ -- 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 --- a/src/Kleene/Internal/Partition.hs +++ b/src/Kleene/Internal/Partition.hs @@ -1,22 +1,29 @@ {-# LANGUAGE Safe #-} +{-# OPTIONS_HADDOCK not-home #-} module Kleene.Internal.Partition where -import Prelude () -import Prelude.Compat -import Data.Semigroup (Semigroup (..)) - import Data.Foldable (toList) import Data.List.NonEmpty (NonEmpty (..)) import Data.RangeSet.Map (RSet) import Data.Set (Set) import qualified Data.Function.Step.Discrete.Closed as SF -import qualified Data.List.NonEmpty as NE +import qualified Data.List.NonEmpty as NE import qualified Data.RangeSet.Map as RSet import qualified Data.Set as Set import Test.QuickCheck +-- $setup +-- >>> import Data.Word +-- >>> import Data.Semigroup (Semigroup (..)) +-- >>> import Test.QuickCheck (Arbitrary (..), (===), (==>)) +-- >>> import Data.RangeSet.Map (RSet) +-- >>> import qualified Data.RangeSet.Map as RSet +-- +-- >>> let asPartitionChar :: Partition Char -> Partition Char; asPartitionChar = id +-- >>> instance (Ord a, Enum a, Arbitrary a) => Arbitrary (RSet a) where arbitrary = fmap RSet.fromRangeList arbitrary + -- | 'Partition' devides type into disjoint connected partitions. -- -- /Note:/ we could have non-connecter partitions too, @@ -172,14 +179,3 @@ (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 --- a/src/Kleene/Internal/Pretty.hs +++ b/src/Kleene/Internal/Pretty.hs @@ -1,12 +1,10 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE Safe #-} +{-# OPTIONS_HADDOCK not-home #-} module Kleene.Internal.Pretty ( Pretty (..), putPretty, ) where - -import Prelude () -import Prelude.Compat import Data.Monoid (Endo (..)) import Data.RangeSet.Map (RSet) diff --git a/src/Kleene/Internal/RE.hs b/src/Kleene/Internal/RE.hs --- a/src/Kleene/Internal/RE.hs +++ b/src/Kleene/Internal/RE.hs @@ -4,6 +4,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE Safe #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_HADDOCK not-home #-} module Kleene.Internal.RE ( RE (..), -- * Construction @@ -15,6 +16,7 @@ -- empty, eps, + everything, char, charRange, anyChar, @@ -37,10 +39,6 @@ nullableProof, ) where -import Prelude () -import Prelude.Compat -import Data.Semigroup (Semigroup (..)) - import Control.Applicative (liftA2) import Data.Foldable (toList) import Data.List (foldl') @@ -61,6 +59,30 @@ import qualified Kleene.Internal.Partition as P import Kleene.Internal.Pretty +-- $setup +-- >>> :set -XOverloadedStrings +-- >>> import Control.Monad (void) +-- >>> import Data.Foldable (traverse_) +-- >>> import Data.List (sort) +-- >>> import Data.Maybe (isJust) +-- >>> import Data.Semigroup (Semigroup (..)) +-- +-- >>> import Test.QuickCheck ((===)) +-- >>> import qualified Test.QuickCheck as QC +-- >>> import qualified Data.Map as Map +-- >>> import qualified Data.Function.Step.Discrete.Closed as SF +-- +-- >>> import Kleene.Classes (match) +-- >>> import Kleene.Internal.Pretty (putPretty, pretty) +-- >>> import Algebra.Lattice (bottom, (\/)) +-- >>> import Kleene.RE () +-- +-- >>> let asREChar :: RE Char -> RE Char; asREChar = id + +------------------------------------------------------------------------------- +-- RE +------------------------------------------------------------------------------- + -- | Regular expression -- -- Constructors are exposed, but you should use @@ -165,10 +187,10 @@ [r] -> r rs -> REAppend rs where - -- flatten one level of REAppend rs1 = concatMap f rs0 - f (REAppend rs) = rs + f :: RE c -> [RE c] + f (REAppend rs) = concatMap f rs f r = [r] -- | Union of regular expressions. @@ -368,7 +390,7 @@ nullableProof (REStar r) | Just r' <- nullableProof r = Just (r' <> REStar r') - | otherwise = Just (r <> REStar r) + | otherwise = Just (r <> REStar r) ------------------------------------------------------------------------------- -- isEmpty @@ -527,9 +549,9 @@ -- "abc" -- -- >>> example $ star $ "a" \/ "b" --- "aaaaba" --- "bbba" --- "abbbbaaaa" +-- "" +-- "bbaabbaaba" +-- "b" -- -- >>> example empty -- @@ -654,23 +676,3 @@ toLatin1 (REAppend xs) = appends (map C.toLatin1 xs) toLatin1 (REUnion rs xs) = C.fromRSet (C.toLatin1 rs) \/ unions (map C.toLatin1 (Set.toList xs)) toLatin1 (REStar r) = star (C.toLatin1 r) - -------------------------------------------------------------------------------- --- Doctest -------------------------------------------------------------------------------- - --- $setup --- >>> :set -XOverloadedStrings --- >>> import Control.Monad (void) --- >>> import Data.Foldable (traverse_) --- >>> import Data.List (sort) --- >>> import Data.Maybe (isJust) --- --- >>> import Test.QuickCheck ((===)) --- >>> import qualified Test.QuickCheck as QC --- --- >>> import Kleene.Classes (match) --- >>> import Algebra.Lattice (bottom) --- >>> import Kleene.RE () --- --- >>> let asREChar :: RE Char -> RE Char; asREChar = id diff --git a/src/Kleene/Internal/Sets.hs b/src/Kleene/Internal/Sets.hs --- a/src/Kleene/Internal/Sets.hs +++ b/src/Kleene/Internal/Sets.hs @@ -1,8 +1,9 @@ {-# LANGUAGE Safe #-} +{-# OPTIONS_HADDOCK not-home #-} -- | Character sets. module Kleene.Internal.Sets ( dotRSet, - ) where +) where import Data.RangeSet.Map (RSet) diff --git a/src/Kleene/Monad.hs b/src/Kleene/Monad.hs --- a/src/Kleene/Monad.hs +++ b/src/Kleene/Monad.hs @@ -37,10 +37,6 @@ isEps, ) where -import Prelude () -import Prelude.Compat -import Data.Semigroup (Semigroup (..)) - import Control.Applicative (liftA2) import Control.Monad (ap) import Data.Foldable (toList) @@ -54,8 +50,21 @@ import qualified Kleene.Classes as C import Kleene.Internal.Pretty +-- $setup +-- >>> :set -XOverloadedStrings +-- >>> import Data.Foldable (traverse_) +-- >>> import Data.List (sort) +-- >>> import Kleene.Internal.Pretty (putPretty) +-- +-- >>> import Test.QuickCheck ((===)) +-- >>> import qualified Test.QuickCheck as QC +-- +-- >>> import Kleene.RE (RE) +-- >>> import Kleene.Classes (match) +-- >>> let asMBool :: M Bool -> M Bool; asMBool = id + -- | Regular expression which has no restrictions on the elements. --- Therefore we can have 'Monad' instance, i.e. have a regexp where +-- 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. @@ -71,23 +80,20 @@ -- ^..*.$ -- data M c - = MChars [c] -- ^ One of the characters - | MAppend [M c] -- ^ Concatenation + = 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 + pure = char (<*>) = 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)) + MUnion cs rs >>= k = unions (appends (map k cs) : map (>>= k) rs) MStar r >>= k = star (r >>= k) ------------------------------------------------------------------------------- @@ -102,7 +108,7 @@ -- prop> match (empty :: M Char) (s :: String) === False -- empty :: M c -empty = MChars [] +empty = MUnion [] [] -- | Empty string. /Note:/ different than 'empty'. -- @@ -123,7 +129,7 @@ -- ^x$ -- char :: c -> M c -char = MChars . pure +char c = MUnion [c] [] -- | /Note:/ we know little about @c@. -- @@ -131,7 +137,7 @@ -- ^[abcdefghijklmnopqrstuvwxyz]$ -- charRange :: Enum c => c -> c -> M c -charRange c c' = MChars [c .. c'] +charRange c c' = MUnion [c .. c'] [] -- | Any character. /Note:/ different than dot! @@ -140,7 +146,7 @@ -- ^[01]$ -- anyChar :: (Bounded c, Enum c) => M c -anyChar = MChars [minBound .. maxBound] +anyChar = MUnion [minBound .. maxBound] [] -- | Concatenate regular expressions. -- @@ -163,27 +169,19 @@ -- 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]) + mk [] [r] = r + mk cs rs = MUnion cs rs + -- | 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 @@ -203,8 +201,8 @@ -- string :: [c] -> M c string [] = eps -string [c] = MChars [c] -string cs = MAppend $ map (MChars . pure) cs +string [c] = char c +string cs = MAppend $ map char cs instance C.Kleene (M c) where empty = empty @@ -233,7 +231,6 @@ -- False -- nullable :: M c -> Bool -nullable (MChars _) = False nullable (MAppend rs) = all nullable rs nullable (MUnion _cs rs) = any nullable rs nullable (MStar _) = True @@ -252,7 +249,6 @@ -- ^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 @@ -285,8 +281,8 @@ -- | Whether 'M' is (structurally) equal to 'empty'. isEmpty :: M c -> Bool -isEmpty (MChars rs) = null rs -isEmpty _ = False +isEmpty (MUnion cs rs) = null cs && null rs +isEmpty _ = False -- | Whether 'M' is (structurally) equal to 'eps'. isEps :: M c -> Bool @@ -306,9 +302,9 @@ -- "abc" -- -- >>> example $ star $ unions ["a", "b"] --- "ababbb" --- "baab" --- "abbababaa" +-- "" +-- "aaababaaab" +-- "a" -- -- xx >>> example empty -- @@ -324,7 +320,6 @@ 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 ] @@ -349,7 +344,6 @@ -- ^[a-z]$ -- toKleene :: C.CharKleene 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) @@ -372,7 +366,7 @@ 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 + c = char <$> QC.arbitrary arb :: Int -> QC.Gen (M c) arb n | n <= 0 = QC.oneof [c, fmap char QC.arbitrary, pure eps] @@ -388,7 +382,6 @@ 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 @@ -407,11 +400,9 @@ 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 + | null cs = goUnion p rs + | otherwise = goUnion p (MUnion cs [] : rs) goUnion p rs | elem eps rs = parens p $ goUnion' True . showChar '?' @@ -435,19 +426,3 @@ 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 --- a/src/Kleene/RE.hs +++ b/src/Kleene/RE.hs @@ -9,6 +9,7 @@ -- empty, eps, + everything, char, charRange, anyChar, @@ -32,5 +33,5 @@ ) where -- This to include orphans. -import Kleene.Internal.RE import Kleene.DFA () +import Kleene.Internal.RE diff --git a/tests/kleene-utf8.hs b/tests/kleene-utf8.hs new file mode 100644 --- /dev/null +++ b/tests/kleene-utf8.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE CPP #-} +module Main (main) where + +import Data.Bits (shiftR, (.&.), (.|.)) +import Data.Char (ord) +import Data.Semigroup ((<>)) +import Data.Word (Word8) +import Test.Tasty (defaultMain, testGroup) +import Test.Tasty.HUnit (assertBool, testCase) + +import Kleene +import Kleene.DFA (fromRE, toRE) + +#if MIN_VERSION_bytestring(0,11,2) +import Test.Tasty.QuickCheck (label, testProperty, (===)) + +import qualified Data.ByteString as BS +#endif + +main :: IO () +main = do + -- print utf8char2 + -- print utf8char3 + -- print utf8char4 + defaultMain $ testGroup "kleene-utf8" + [ testCase "brute ≃ brute'" $ do + assertBool "not equiv" (equivalent utf8char1 utf8char2) + , testCase "brute' ≃ manual1" $ do + assertBool "not equiv" (equivalent utf8char2 utf8char3) + , testCase "manual1 ≃ manual2" $ do + assertBool "not equiv" (equivalent utf8char3 utf8char4) + , testCase "brute ≃ manual2" $ do + assertBool "not equiv" (equivalent utf8char1 utf8char4) + +#if MIN_VERSION_bytestring(0,11,2) + , testProperty "isValidUtf8" $ \w8s -> + let bs = BS.pack w8s + isValid = BS.isValidUtf8 bs + in label (show isValid) $ isValid === match (star utf8char4) w8s +#endif + ] + +------------------------------------------------------------------------------- +-- Bruteforce definition +------------------------------------------------------------------------------- + +utf8char1 :: RE Word8 +utf8char1 = unions + [ string (encodeStringUtf8 [c]) + | c <- [ '\0' .. maxBound ] + ] + +------------------------------------------------------------------------------- +-- Derived definition +------------------------------------------------------------------------------- + +utf8charDFA1 :: DFA Word8 +utf8charDFA1 = fromRE utf8char1 + +utf8char2 :: RE Word8 +utf8char2 = toRE utf8charDFA1 + +------------------------------------------------------------------------------- +-- Written out definition +------------------------------------------------------------------------------- + +utf8char3 :: RE Word8 +utf8char3 = unions + [ charRange 0x00 0x7F + , sub1 <> charRange 0x80 0xBF + ] + where + sub1 = unions + [ charRange 0xC2 0xDF + , charRange 0xE0 0xE0 <> charRange 0xa0 0xBF + , charRange 0xED 0xED <> charRange 0x80 0x9F + , sub2 <> charRange 0x80 0xBF + ] + + sub2 = unions + [ charRange 0xE1 0xEC + , charRange 0xEE 0xEF + , charRange 0xF0 0xF0 <> charRange 0x90 0xBF + , charRange 0xF1 0xF3 <> charRange 0x80 0xBF + , charRange 0xF4 0xF4 <> charRange 0x80 0x8f + ] + +------------------------------------------------------------------------------- +-- Manual definition, how human would written it +------------------------------------------------------------------------------- + +utf8char4 :: RE Word8 +utf8char4 = unions + [ charRange 0x00 0x7F + , charRange 0xC2 0xDF <> charRange 0x80 0xBF + , charRange 0xE0 0xE0 <> charRange 0xa0 0xBF <> charRange 0x80 0xBF + , charRange 0xE1 0xEC <> charRange 0x80 0xBF <> charRange 0x80 0xBF + , charRange 0xED 0xED <> charRange 0x80 0x9F <> charRange 0x80 0xBF + , charRange 0xEE 0xEF <> charRange 0x80 0xBF <> charRange 0x80 0xBF + , charRange 0xF0 0xF0 <> charRange 0x90 0xBF <> charRange 0x80 0xBF <> charRange 0x80 0xBF + , charRange 0xF1 0xF3 <> charRange 0x80 0xBF <> charRange 0x80 0xBF <> charRange 0x80 0xBF + , charRange 0xF4 0xF4 <> charRange 0x80 0x8f <> charRange 0x80 0xBF <> charRange 0x80 0xBF + ] + +------------------------------------------------------------------------------- +-- UTF8 encoding +------------------------------------------------------------------------------- + +encodeStringUtf8 :: String -> [Word8] +encodeStringUtf8 [] = [] +encodeStringUtf8 (c:cs) + | c <= '\x07F' = w8 + : encodeStringUtf8 cs + | c <= '\x7FF' = (0xC0 .|. w8ShiftR 6 ) + : (0x80 .|. (w8 .&. 0x3F)) + : encodeStringUtf8 cs + | c <= '\xD7FF'= (0xE0 .|. w8ShiftR 12 ) + : (0x80 .|. (w8ShiftR 6 .&. 0x3F)) + : (0x80 .|. (w8 .&. 0x3F)) + : encodeStringUtf8 cs + | c <= '\xDFFF'= 0xEF : 0xBF : 0xBD -- U+FFFD + : encodeStringUtf8 cs + | c <= '\xFFFF'= (0xE0 .|. w8ShiftR 12 ) + : (0x80 .|. (w8ShiftR 6 .&. 0x3F)) + : (0x80 .|. (w8 .&. 0x3F)) + : encodeStringUtf8 cs + | otherwise = (0xf0 .|. w8ShiftR 18 ) + : (0x80 .|. (w8ShiftR 12 .&. 0x3F)) + : (0x80 .|. (w8ShiftR 6 .&. 0x3F)) + : (0x80 .|. (w8 .&. 0x3F)) + : encodeStringUtf8 cs + where + w8 = fromIntegral (ord c) :: Word8 + w8ShiftR :: Int -> Word8 + w8ShiftR = fromIntegral . shiftR (ord c)