diff --git a/src/Control/Lens/Diopter.hs b/src/Control/Lens/Diopter.hs index c78b06c..e94584c 100644 --- a/src/Control/Lens/Diopter.hs +++ b/src/Control/Lens/Diopter.hs @@ -41,8 +41,7 @@ type Diopter s t a b = forall p f. (Distributor p, Applicative f) => p a (f b) -> p s (f t) -{- | If you see `ADiopter` in a signature for a function, -the function is expecting a `Diopter`. -} +{- | `ADiopter` is monomorphically a `Diopter`. -} type ADiopter s t a b = Dioptrice a b a (Identity b) -> Dioptrice a b s (Identity t) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index 27ce10b..f0aeff1 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -23,7 +23,7 @@ module Control.Lens.Grammar , RegBnf (..) , regbnfG , regbnfGrammar - -- * Context-sensitive grammar + -- * Unrestricted, context-sensitive grammar , CtxGrammar , printG , parseG @@ -57,7 +57,7 @@ import Witherable A regular grammar may be constructed using `Lexical` and `Alternator` combinators. Let's see an example using -[semantic versioning](https://semver.org/). +[semantic versioning](https://semver.org/) syntax. >>> import Numeric.Natural (Natural) >>> :{ @@ -78,7 +78,8 @@ Unfortunately, we can't use TemplateHaskell to generate it in [GHCi] which is used to test this documenation. Normally we would write `makeNestedPrisms` @''SemVer@, but here is equivalent explicit Haskell code instead. -Since @SemVer@ is a newtype, @_SemVer@ can be an `Control.Lens.Iso.Iso`. +Since @SemVer@ has only one constructor, +@_SemVer@ can be an `Control.Lens.Iso.Iso`. >>> :set -XRecordWildCards >>> import Control.Lens (Iso', iso) @@ -221,7 +222,7 @@ arithGrammar = ruleRec "arith" sumG _Num . iso show read >? someP (asIn @Char DecimalNumber) :} -We can generate a `RegBnf`, printers and parsers from @arithGrammar@. +We can generate grammar strings, printers and parsers from @arithGrammar@. >>> putStringLn (regbnfG arithGrammar) {start} = \q{arith} @@ -230,7 +231,6 @@ We can generate a `RegBnf`, printers and parsers from @arithGrammar@. {number} = \p{Nd}+ {product} = \q{factor}(\*\q{factor})* {sum} = \q{product}(\+\q{product})* - >>> [x | (x,"") <- parseG arithGrammar "1+2*3+4"] [Add (Add (Num 1) (Mul (Num 2) (Num 3))) (Num 4)] >>> unparseG arithGrammar (Add (Num 1) (Mul (Num 2) (Num 3))) "" :: Maybe String @@ -238,6 +238,13 @@ Just "1+2*3" >>> do pr <- printG arithGrammar (Num 69); return (pr "") :: Maybe String Just "69" +If all `rule`s are non-recursive, then a `Grammar` +can be rewritten as a `RegGrammar`. +Since Haskell permits general recursion, and `RegGrammar`s are +embedded in Haskell, you can define context-free grammars with them. +But it's recommended to use `Grammar`s for `rule` abstraction +and generator support for `ruleRec`. + -} type Grammar token a = forall p. ( Lexical token p @@ -245,19 +252,7 @@ type Grammar token a = forall p. , Alternator p ) => p a a -{- | -In addition to context-sensitivity via `Monadic` combinators, -`CtxGrammar`s adds general filtration via `Filtrator` to `Grammar`s. - ->>> :{ -palindromeG :: CtxGrammar Char String -palindromeG = rule "palindrome" $ - satisfied (\wrd -> reverse wrd == wrd) >?< manyP (anyToken @Char) -:} - -The `satisfied` pattern is used together with the `Choice` & -`Data.Profunctor.Cochoice` applicator `>?<` for general filtration. -For context-sensitivity, +{- | For context-sensitivity, the `Monadic` interface is used by importing "Data.Profunctor.Monadic" qualified and using a "bonding" notation which mixes "idiom" style with qualified do-notation. @@ -290,16 +285,16 @@ The qualified do-notation changes the signature of @P.@`Data.Profunctor.Monadic.>>=`, so that we must apply the constructor pattern @_LenVec@ to the do-block with the `>?` applicator. -Any bound named variable, @var <- action@, +Any scoped bound action, @var <- action@, gets "bonded" to the constructor pattern. Any unbound actions, except for the last action in the do-block, does not get bonded to the pattern. The last action does get bonded to the pattern. -Any unnamed bound action, @_ <- action@, +Any unscoped bound action, @_ <- action@, also gets bonded to the pattern, -but being unnamed means it isn't added to the context. -If all bound actions are unnamed, then a `CtxGrammar` can -be rewritten as a `Grammar` since it is context-free. +but being unscoped means it isn't added to the context. +If all bound actions are unscoped, and filtration isn't used, +then a `CtxGrammar` can be rewritten as a `Grammar` since it is context-free. We can't generate a `RegBnf` since the `rule`s of a `CtxGrammar` aren't static, but dynamic and contextual. We can generate parsers and printers as expected. @@ -312,8 +307,28 @@ We can generate parsers and printers as expected. ["2;6,7"] >>> [pr "" | pr <- printG lenvecGrammar (LenVec 200 [100])] :: [String] [] + +In addition to context-sensitivity via `Monadic` combinators, +`CtxGrammar`s add unrestricted filtration to `Grammar`s. +The `satisfy` combinator is an unrestricted token filter. +And the `satisfied` pattern is used together with the `Choice` & +`Data.Profunctor.Cochoice` applicator `>?<` for unrestricted filtration. + +>>> :{ +palindromeG :: CtxGrammar Char String +palindromeG = rule "palindrome" $ + satisfied (\wrd -> reverse wrd == wrd) >?< manyP (anyToken @Char) +:} + >>> [pal | word <- ["racecar", "word"], (pal, "") <- parseG palindromeG word] ["racecar"] + +Since `CtxGrammar`s are embedded in Haskell, permitting computable predicates, +and `Filtrator` has a default definition for `Monadic` `Alternator`s, +the context-sensitivity of `CtxGrammar` implies +unrestricted filtration of grammars by computable predicates, +which can recognize the class of recursively enumerable languages. + -} type CtxGrammar token a = forall p. ( Lexical token p @@ -336,8 +351,9 @@ type Lexical token p = ) :: Constraint {- | `RegString`s are an embedded domain specific language -of regular expression strings. Since they are strings, -they have a string-like interface. +of regular expression strings. + +Since they are strings, they have a string-like interface. >>> let rex = fromString "ab|c" :: RegString >>> putStringLn rex @@ -442,6 +458,14 @@ newtype RegString = RegString {runRegString :: RegEx Char} {- | `RegBnf`s are an embedded domain specific language of Backus-Naur forms extended by regular expression strings. + +A `RegBnf` consists of a distinguished `RegString` "start" rule, +and a set of named `RegString` `rule`s. + +>>> putStringLn (rule "baz" (terminal "foo" >|< terminal "bar") :: RegBnf) +{start} = \q{baz} +{baz} = foo|bar + Like `RegString`s they have a string-like interface. >>> let bnf = fromString "{start} = foo|bar" :: RegBnf @@ -449,6 +473,8 @@ Like `RegString`s they have a string-like interface. {start} = foo|bar >>> bnf "{start} = foo|bar" +>>> :type toList bnf +toList bnf :: [Char] `RegBnf`s can be generated from context-free `Grammar`s with `regbnfG`. @@ -458,6 +484,13 @@ regbnfG regbnfGrammar :: RegBnf Like `RegString`s, `RegBnf`s can be constructed using `Lexical`, `Monoid` and `KleeneStarAlgebra` combinators. But they also support `BackusNaurForm` `rule`s and `ruleRec`s. + +>>> putStringLn (rule "baz" (bnf >|< terminal "baz")) +{start} = \q{baz} +{baz} = foo|bar|baz +>>> putStringLn (ruleRec "∞" (\x -> x) :: RegBnf) +{start} = \q{∞} +{∞} = \q{∞} -} newtype RegBnf = RegBnf {runRegBnf :: Bnf RegString} deriving newtype diff --git a/src/Control/Lens/Grammar/Boole.hs b/src/Control/Lens/Grammar/Boole.hs index f5a5cef..3a5b2ec 100644 --- a/src/Control/Lens/Grammar/Boole.hs +++ b/src/Control/Lens/Grammar/Boole.hs @@ -74,8 +74,8 @@ allB f = foldl' (\b a -> b >&&< f a) (fromBool True) anyB :: (Foldable f, BooleanAlgebra b) => (a -> b) -> f a -> b anyB f = foldl' (\b a -> b >||< f a) (fromBool False) --- | `TokenTest` forms a closed `Tokenized` `BooleanAlgebra` --- of `Categorized` `tokenClass`es. +-- | `TokenTest` forms a closed `Tokenized` `BooleanAlgebra`, +-- for use an an argument to `tokenClass`. newtype TokenTest token = TokenTest (RegExam token (TokenTest token)) -- | `TokenAlgebra` extends `Tokenized` methods to support diff --git a/src/Control/Lens/Grammar/Kleene.hs b/src/Control/Lens/Grammar/Kleene.hs index f13a1f5..2884553 100644 --- a/src/Control/Lens/Grammar/Kleene.hs +++ b/src/Control/Lens/Grammar/Kleene.hs @@ -63,7 +63,7 @@ class Monoid k => KleeneStarAlgebra k where orK :: (Foldable f, KleeneStarAlgebra k) => f k -> k orK = foldl' (>|<) zeroK --- | universal +-- | existential anyK :: (Foldable f, KleeneStarAlgebra k) => (a -> k) -> f a -> k anyK f = foldl' (\b a -> b >|< f a) zeroK diff --git a/src/Control/Lens/Grate.hs b/src/Control/Lens/Grate.hs index 9db64ae..520065b 100644 --- a/src/Control/Lens/Grate.hs +++ b/src/Control/Lens/Grate.hs @@ -48,8 +48,7 @@ type Grate s t a b = forall p f. (Closed p, Monoidal p, Distributive f, Applicative f) => p a (f b) -> p s (f t) -{- | If you see `AGrate` in a signature for a function, -the function is expecting a `Grate`. -} +{- | `AGrate` is monomorphically a `Grate`. -} type AGrate s t a b = Grating a b a (Identity b) -> Grating a b s (Identity t) diff --git a/src/Control/Lens/Internal/NestedPrismTH.hs b/src/Control/Lens/Internal/NestedPrismTH.hs index 83e2520..f501976 100644 --- a/src/Control/Lens/Internal/NestedPrismTH.hs +++ b/src/Control/Lens/Internal/NestedPrismTH.hs @@ -33,21 +33,40 @@ import qualified Data.Set as Set import Data.Set (Set) import Prelude --- | Generate a `Control.Lens.Prism.Prism` +-- | Similar to `Control.Lens.Internal.PrismTH.makePrisms`, +-- `makeNestedPrisms` generates a `Control.Lens.Prism.Prism` -- for each constructor of a data type. --- `Control.Lens.Iso.Iso`s generated when possible. --- `Control.Lens.Review.Review`s are created for constructors with existentially --- quantified constructors and GADTs. --- --- See `Control.Lens.Internal.PrismTH.makePrisms` for details and examples. +-- `Control.Lens.Iso.Iso`s are generated when possible. +-- `Control.Lens.Review.Review`s are generated for constructors +-- with existentially quantified constructors and GADTs. -- The difference in `makeNestedPrisms` -- is that constructors with @n > 2@ arguments -- will use right-nested pairs, rather than a flat @n@-tuple. --- This makes them suitable for use on the left-hand-side of --- `Control.Lens.PartialIso.>~`, --- `Control.Lens.PartialIso.>?` and `Control.Lens.PartialIso.>?<`; --- with repeated use of `Data.Profunctor.Distributor.>*<` --- on the right-hand-side, resulting in right-nested pairs. +-- This makes them suitable for bonding, +-- by use of the applicator `Control.Lens.PartialIso.>?` +-- to `Data.Profunctor.Monoidal.Monoidal` idiom notation +-- with `Data.Profunctor.Monoidal.>*<`, +-- or to `Data.Profunctor.Monadic.Monadic` qualified do-notation. +-- +-- /e.g./ +-- +-- @ +-- data FooBarBazBux a +-- = Foo Int +-- | Bar a +-- | Baz Int Char +-- | Bux Double String Bool +-- makePrisms ''FooBarBazBux +-- @ +-- +-- will create +-- +-- @ +-- _Foo :: Prism' (FooBarBaz a) Int +-- _Bar :: Prism (FooBarBaz a) (FooBarBaz b) a b +-- _Baz :: Prism' (FooBarBaz a) (Int, Char) +-- _Bux :: Prism' (FooBarBaz a) (Double, (String, Bool)) +-- @ makeNestedPrisms :: Name -> DecsQ makeNestedPrisms typeName = do info <- D.reifyDatatype typeName diff --git a/src/Control/Lens/Monocle.hs b/src/Control/Lens/Monocle.hs index c2d055e..da093f7 100644 --- a/src/Control/Lens/Monocle.hs +++ b/src/Control/Lens/Monocle.hs @@ -19,6 +19,7 @@ module Control.Lens.Monocle , monocle , withMonocle , cloneMonocle + , imprism , mapMonocle , ditraversed , forevered @@ -42,8 +43,7 @@ type Monocle s t a b = forall p f. (Monoidal p, Applicative f) => p a (f b) -> p s (f t) -{- | If you see `AMonocle` in a signature for a function, -the function is expecting a `Monocle`. -} +{- | `AMonocle` is monomorphically a `Monocle`. -} type AMonocle s t a b = Monocular a b a (Identity b) -> Monocular a b s (Identity t) @@ -61,6 +61,16 @@ monomorphically typed `Monocle` for different purposes. cloneMonocle :: AMonocle s t a b -> Monocle s t a b cloneMonocle mon = unwrapPafb . mapMonocle mon . WrapPafb +{- | Convert a `Monocle` to an improper `Control.Lens.Prism.Prism`. + +>>> review (imprism ditraversed) 1 :: Complex Int +1 :+ 1 +>>> preview (imprism ditraversed) (1 :+ 2 :: Complex Int) +Just 1 +-} +imprism :: Monocle s t a b -> Prism s t a b +imprism mon = clonePrism mon + {- | Build a `Monocle` from a `Traversable` & `Distributive`, homogeneous, countable product. diff --git a/src/Control/Lens/PartialIso.hs b/src/Control/Lens/PartialIso.hs index 64c927a..6e581ee 100644 --- a/src/Control/Lens/PartialIso.hs +++ b/src/Control/Lens/PartialIso.hs @@ -117,8 +117,7 @@ some equivalence class of terms. -} type PartialIso' s a = PartialIso s s a a -{- | If you see `APartialIso` in a signature for a function, -the function is expecting a `PartialIso`. -} +{- | `APartialIso` is monomorphically a `PartialIso`. -} type APartialIso s t a b = PartialExchange a b a (Maybe b) -> PartialExchange a b s (Maybe t) @@ -222,7 +221,7 @@ infixl 4 >? (?<) pat = withPrism pat $ \f g -> unright . dimap (either id f) g infixl 4 ?< -{- | Action of `APartialIso` on `Choice` and `Cochoice` `Profunctor`s. -} +{- | Action of `APartialIso` on `Choice` & `Cochoice` partial profunctors. -} (>?<) :: (Choice p, Cochoice p) => APartialIso s t a b diff --git a/src/Control/Lens/Wither.hs b/src/Control/Lens/Wither.hs index 72dd0be..7b5d7c5 100644 --- a/src/Control/Lens/Wither.hs +++ b/src/Control/Lens/Wither.hs @@ -37,7 +37,6 @@ import Witherable {- | `Wither`s extends `Control.Lens.Traversal.Traversal`s by filtering. - Every one of the following is a `Wither`. * `Control.Lens.Iso.Iso` @@ -48,8 +47,7 @@ Every one of the following is a `Wither`. -} type Wither s t a b = forall f. Alternative f => (a -> f b) -> s -> f t -{- | If you see `AWither` in a signature for a function, -the function is expecting a `Wither`. -} +{- | `AWither` is monomorphically a `Wither`. -} type AWither s t a b = (a -> Altar a b b) -> s -> Altar a b t {- | `Witheroid`s generalize `Wither`s. diff --git a/src/Data/Profunctor/Distributor.hs b/src/Data/Profunctor/Distributor.hs index 1d2fd37..bc8d17d 100644 --- a/src/Data/Profunctor/Distributor.hs +++ b/src/Data/Profunctor/Distributor.hs @@ -15,8 +15,6 @@ module Data.Profunctor.Distributor , Alternator (..) , choice , option - -- * Homogeneous - , Homogeneous (..) -- * SepBy , SepBy (..) , sepBy @@ -26,6 +24,8 @@ module Data.Profunctor.Distributor , chain , chain1 , intercalateP + -- * Homogeneous + , Homogeneous (..) ) where import Control.Applicative hiding (WrappedArrow) @@ -93,7 +93,7 @@ class Monoidal p => Distributor p where {- | The zero structure morphism of a `Distributor`. - `zeroP` has a default for `Alternator`. + `zeroP` has a default for `Alternator`s. prop> zeroP = empty -} @@ -103,7 +103,7 @@ class Monoidal p => Distributor p where {- | The sum structure morphism of a `Distributor`. - `>+<` has a default for `Alternator`. + `>+<` has a default for `Alternator`s. prop> x >+< y = alternate (Left x) <|> alternate (Right y) -} @@ -315,7 +315,13 @@ instance Homogeneous Tree where {- | The `Alternator` class co-extends `Choice` and `Distributor`, as well as `Alternative`, adding the `alternate` method, -which is a lax monoidal structure morphism on sums. +which is a lax monoidal structure morphism on sums, with these +these laws relating them. + +prop> left' = alternate . Left +prop> right' = alternate . Right +prop> zeroP = empty +prop> x >+< y = alternate (Left x) <|> alternate (Right y) For the case of `Functor`s the analog of `alternate` can be defined without any other constraint, but the case of `Profunctor`s turns @@ -324,13 +330,8 @@ out to be slighly more complex. class (Choice p, Distributor p, forall x. Alternative (p x)) => Alternator p where - {- | - prop> left' = alternate . Left - prop> right' = alternate . Right - prop> zeroP = empty - prop> x >+< y = alternate (Left x) <|> alternate (Right y) - - `alternate` has a default for `Cochoice`. + {- | The structure morphism for an `Alternator`, + `alternate` has a default for `Choice` & `Cochoice` partial distributors. -} alternate :: Either (p a b) (p c d) @@ -346,7 +347,7 @@ class (Choice p, Distributor p, forall x. Alternative (p x)) {- | One or more. -} someP :: p a b -> p [a] [b] - someP p = _Cons >? p >*< manyP p + someP x = x >:< manyP x -- | Combines all `Alternative` choices in the specified list. choice :: (Foldable f, Alternative p) => f (p a) -> p a @@ -418,7 +419,7 @@ several (SepBy beg end sep) p = iso toList fromList . eotList >~ beg >* (oneP >+< p >*< manyP (sep >* p)) *< end {- | -prop> several1 noSep p = someP p +prop> several1 noSep = someP -} several1 :: (IsList s, IsList t, Distributor p, Choice p) @@ -451,9 +452,10 @@ chain1 association pat (SepBy beg end sep) = leftOrRight chainl1 chainr1 {- | `intercalateP` adds a `SepBy` to `replicateP`. -} intercalateP - :: (Monoidal p, Choice p, AsEmpty s, AsEmpty t, Cons s t a b) - => Int -> SepBy (p () ()) -> p a b -> p s t + :: (Monoidal p, Choice p, AsEmpty s, Cons s s a a) + => Int {- ^ number of repetitions -} + -> SepBy (p () ()) -> p a a -> p s s intercalateP n (SepBy beg end _) _ | n <= 0 = - beg >* lmap (const Empty) asEmpty *< end + beg >* asEmpty *< end intercalateP n (SepBy beg end comma) p = beg >* p >:< replicateP (n-1) (comma >* p) *< end diff --git a/src/Data/Profunctor/Filtrator.hs b/src/Data/Profunctor/Filtrator.hs index 75a1e42..0431d5d 100644 --- a/src/Data/Profunctor/Filtrator.hs +++ b/src/Data/Profunctor/Filtrator.hs @@ -41,8 +41,11 @@ class (Cochoice p, forall x. Filterable (p x)) prop> unright = snd . filtrate `filtrate` is a distant relative to `Data.Either.partitionEithers`. + `filtrate` can be given a default value for `Monadic` `Alternator`s via `mfiltrate`. - `filtrate` has a default for `Choice`. + prop> filtrate = mfiltrate + + `filtrate` has a default for `Choice` & `Cochoice` partial profunctors. -} filtrate :: p (Either a c) (Either b d) @@ -56,9 +59,9 @@ class (Cochoice p, forall x. Filterable (p x)) &&& dimapMaybe (Just . Right) (either (const Nothing) Just) --- | `mfiltrate` can be used as `filtrate`, for `Monadic` `Alternator`s. +-- | `Filtrator` has a default definition for `Monadic` `Alternator`s. -- --- prop> mfiltrate = filtrate +-- prop> filtrate = mfiltrate mfiltrate :: (Monadic p, Alternator p) => p (Either a c) (Either b d) diff --git a/src/Data/Profunctor/Monoidal.hs b/src/Data/Profunctor/Monoidal.hs index b1aefa7..7c6d163 100644 --- a/src/Data/Profunctor/Monoidal.hs +++ b/src/Data/Profunctor/Monoidal.hs @@ -25,6 +25,7 @@ import Control.Applicative qualified as Ap (WrappedArrow) import Control.Arrow import Control.Lens hiding (chosen) import Control.Lens.Internal.Context +import Control.Lens.Internal.Prism import Control.Lens.Internal.Profunctor import Control.Lens.PartialIso import Data.Bifunctor.Clown @@ -126,11 +127,13 @@ ditraverse ditraverse p = traverse (\f -> lmap f p) (distribute id) {- | `replicateP` is analagous to `Control.Monad.replicateM`, -for `Monoidal` & `Choice` `Profunctor`s. -} +for `Monoidal` & `Choice` `Profunctor`s. When the number +of repetitions is less than or equal to 0, it returns `asEmpty`. +-} replicateP - :: (Monoidal p, Choice p, AsEmpty s, AsEmpty t, Cons s t a b) - => Int -> p a b -> p s t -replicateP n _ | n <= 0 = lmap (const Empty) asEmpty + :: (Monoidal p, Choice p, AsEmpty s, Cons s s a a) + => Int {- ^ number of repetitions -} -> p a a -> p s s +replicateP n _ | n <= 0 = asEmpty replicateP n a = a >:< replicateP (n-1) a {- | For any `Monoidal`, `Choice` & `Strong` `Profunctor`, @@ -247,3 +250,14 @@ instance (Profunctor p, Alternative (p a)) empty = proreturn empty ab <|> cd = proreturn (proextract ab <|> proextract cd) many = proreturn . many . proextract +instance Applicative (Market a b s) where + pure t = Market (pure t) (pure (Left t)) + Market f0 g0 <*> Market f1 g1 = Market + (\b -> f0 b (f1 b)) + (\s -> + case g0 s of + Left bt -> case g1 s of + Left b -> Left (bt b) + Right a -> Right a + Right a -> Right a + ) diff --git a/test/Main.hs b/test/Main.hs index 06bb306..2b7079b 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -3,6 +3,7 @@ module Main (main) where import Data.Foldable hiding (toList) import Data.Maybe (listToMaybe) import Control.Lens.Grammar +import Control.Lens.Grammar.BackusNaur import Test.DocTest import Test.Hspec @@ -18,14 +19,14 @@ main :: IO () main = do doctests hspec $ do - testGrammar "regexGrammar" regexGrammar regexExamples - testGrammar "semverGrammar" semverGrammar semverExamples - testGrammar "semverCtxGrammar" semverCtxGrammar semverExamples - testGrammar "arithGrammar" arithGrammar arithExamples - testGrammar "jsonGrammar" jsonGrammar jsonExamples - testGrammar "sexprGrammar" sexprGrammar sexprExamples - testGrammar "lambdaGrammar" lambdaGrammar lambdaExamples - testGrammar "lenvecGrammar" lenvecGrammar lenvecExamples + describe "regexGrammar" $ for_ regexExamples $ testGrammarExample regexGrammar + describe "semverGrammar" $ for_ semverExamples $ testCtxGrammarExample semverGrammar + describe "semverCtxGrammar" $ for_ semverExamples $ testCtxGrammarExample semverCtxGrammar + describe "arithGrammar" $ for_ arithExamples $ testGrammarExample arithGrammar + describe "jsonGrammar" $ for_ jsonExamples $ testCtxGrammarExample jsonGrammar + describe "sexprGrammar" $ for_ sexprExamples $ testCtxGrammarExample sexprGrammar + describe "lambdaGrammar" $ for_ lambdaExamples $ testCtxGrammarExample lambdaGrammar + describe "lenvecGrammar" $ for_ lenvecExamples $ testCtxGrammarExample lenvecGrammar doctests :: IO () doctests = do @@ -77,16 +78,21 @@ doctests = do putStrLn modulePath doctest (modulePath : languageExtensions) -testGrammar :: (Show a, Eq a) => String -> CtxGrammar Char a -> [(a, String)] -> Spec -testGrammar name grammar examples = - describe name $ - for_ examples $ \(expectedSyntax, expectedString) -> do - it ("should parse from " <> expectedString <> " correctly") $ do - let actualSyntax = [parsed | (parsed, "") <- parseG grammar expectedString] - listToMaybe actualSyntax `shouldBe` Just expectedSyntax - it ("should unparse to " <> expectedString <> " correctly") $ do - let actualString = unparseG grammar expectedSyntax "" - actualString `shouldBe` Just expectedString - it ("should print to " <> expectedString <> " correctly") $ do - let actualString = ($ "") <$> printG grammar expectedSyntax - actualString `shouldBe` Just expectedString +testGrammarExample :: (Show a, Eq a) => Grammar Char a -> (a, String) -> Spec +testGrammarExample grammar (expectedSyntax, expectedString) = do + testCtxGrammarExample grammar (expectedSyntax, expectedString) + it ("should match " <> expectedString <> " correctly") $ do + let actualMatch = expectedString =~ regbnfG grammar + actualMatch `shouldBe` True + +testCtxGrammarExample :: (Show a, Eq a) => CtxGrammar Char a -> (a, String) -> Spec +testCtxGrammarExample grammar (expectedSyntax, expectedString) = do + it ("should parse from " <> expectedString <> " correctly") $ do + let actualSyntax = [parsed | (parsed, "") <- parseG grammar expectedString] + listToMaybe actualSyntax `shouldBe` Just expectedSyntax + it ("should unparse to " <> expectedString <> " correctly") $ do + let actualString = unparseG grammar expectedSyntax "" + actualString `shouldBe` Just expectedString + it ("should print to " <> expectedString <> " correctly") $ do + let actualString = ($ "") <$> printG grammar expectedSyntax + actualString `shouldBe` Just expectedString