New version

distributors.cabal

@@ -127,6 +127,7 @@ test-suite test
   other-modules:
       Examples.Arithmetic
       Examples.Chain
+      Examples.Expression
       Examples.Json
       Examples.Lambda
       Examples.LenVec

src/Control/Lens/Grammar.hs

@@ -66,6 +66,8 @@ import Text.ParserCombinators.ReadP (ReadP, readP_to_S)
 import Witherable
 
 -- Re-exports
+import Control.Lens.Cons as X
+import Control.Lens.Empty as X
 import Control.Lens.Grammar.BackusNaur as X
 import Control.Lens.Grammar.Boole as X
 import Control.Lens.Grammar.Kleene as X
@@ -284,7 +286,7 @@ and generator support for `ruleRec`.
 type Grammar token a = forall p.
   ( Lexical token p
   , Alternator p
-  , forall x. BackusNaurForm (p x x)
+  , forall x y. BackusNaurForm (p x y)
   ) => p a a
 
 {- | For context-sensitivity,

src/Control/Lens/Grammar/Kleene.hs

@@ -47,26 +47,31 @@ import qualified Test.QuickCheck.Gen as Gen
 import Text.ParserCombinators.ReadP (ReadP)
 import qualified Text.ParserCombinators.ReadP as ReadP
 
-{- | A `KleeneStarAlgebra` is a ring
+{- | A `KleeneStarAlgebra` is a semiring
 with a generally non-commutative multiplication,
 the `Monoid` concatenation operator `<>` with identity `mempty`;
 and an idempotent addition, the alternation operator `>|<`
 with identity `zeroK`.
 
-It has three unary operators `optK`, `plusK` and the eponymous `starK`.
-
-prop> starK x = optK (plusK x)
-prop> plusK x = x <> starK x
-prop> optK x = mempty >|< x
-
-The following invariants should hold.
-
 prop> x >|< x = x
 prop> zeroK >|< x = x = x >|< zeroK
-prop> mempty >|< x = optK x = x >|< mempty
 prop> zeroK <> x = zeroK = x <> zeroK
 prop> mempty <> x = x = x <> mempty
 
+It also has three unary Kleene quantifier operators;
+
+* `optK`, zero or one,
+
+prop> optK x = mempty >|< x = x >|< mempty
+
+* `plusK`, one or more,
+
+prop> plusK x = x <> starK x = starK x <> x
+
+* and the eponymous `starK`, zero or more.
+
+prop> starK x = optK (plusK x)
+
 -}
 class Monoid k => KleeneStarAlgebra k where
   starK, plusK, optK :: k -> k
@@ -90,11 +95,9 @@ anyK :: (Foldable f, KleeneStarAlgebra k) => (a -> k) -> f a -> k
 anyK f = foldl' (\b a -> b >|< f a) zeroK
 
 {- | The `RegEx`pression type forms the prototypical `KleeneStarAlgebra`.
-It is also a `TokenAlgebra`, such that the following invariants hold.
-
-prop> zeroK = tokenClass falseB
-prop> tokenClass x >|< tokenClass y = tokenClass (x >||< y)
-
+It is also a `TokenAlgebra` and `tokenClass` acts homomorphically on disjunction.
+`RegEx`pressions may be understood as normalizations of
+`KleeneStarAlgebra` expressions generated by lexical token expressions.
 -}
 data RegEx token
   = SeqEmpty
@@ -105,8 +108,8 @@ data RegEx token
   | KleenePlus (RegEx token)
   | RegExam (RegExam token (RegEx token))
 
-{- | A component of both `RegEx`pressions and `TokenClass`es,
-so that the latter can be embedded in the former with `tokenClass`.
+{- | Both `RegEx`pressions and `TokenClass`es are algebras over the t`RegExam` endo-`Functor`.
+`TokenClass` is the fixed point of t`RegExam`.
 -}
 data RegExam token alg
   = OneOf (Set token)
@@ -127,7 +130,9 @@ isPassExam :: RegExam token alg -> Bool
 isPassExam (NotOneOf xs (AndNotAsIn ys)) = Set.null xs && Set.null ys
 isPassExam _ = False
 
-{- | `CategoryTest`s for `Categorized` tokens.-}
+{- | `CategoryTest`s for `Categorized` tokens,
+taken in conjunction with `NotOneOf` some `Set` of tokens.
+-}
 data CategoryTest token
   = AndAsIn (Categorize token)
   | AndNotAsIn (Set (Categorize token))
@@ -143,6 +148,10 @@ prop> notB . notOneOf = oneOf
 prop> notB . asIn = notAsIn
 prop> notB . notAsIn = asIn
 
+`TokenClass` is the fixed point algebra of t`RegExam`.
+`TokenClass`es may be understood as normalizations of
+`BooleanAlgebra` expressions generated by `Tokenized`
+expressions.
 -}
 newtype TokenClass token = TokenClass (RegExam token (TokenClass token))
 
@@ -154,6 +163,12 @@ then `tokenClass` is expected to act homomorphically on disjunction.
 prop> empty = tokenClass falseB
 prop> tokenClass x <|> tokenClass y = tokenClass (x >||< y)
 
+Likewise, when a `TokenAlgebra` is a `KleeneStarAlgebra`,
+then `tokenClass` is expected to act homorphically on disjunction.
+
+prop> zeroK = tokenClass falseB
+prop> tokenClass x >|< tokenClass y = tokenClass (x >||< y)
+
 -}
 class Tokenized token p => TokenAlgebra token p where
   tokenClass :: TokenClass token -> p

src/Control/Lens/Grammar/Machine.hs

@@ -242,7 +242,7 @@ parseForest et word = (concat (itemForests Set.empty Nothing 0 acceptedLen 0), d
   where
     (n, chart) = prefixGen et word
     relations = transducerRelations et
-    acceptedLen = maximum [j | j <- [0 .. n], acceptsChart j chart]
+    acceptedLen = maximum (0 : [j | j <- [0 .. n], acceptsChart j chart])
 
     acceptedWord = take acceptedLen word
     sliceAt start end = take (end - start) (drop start acceptedWord)
@@ -347,10 +347,12 @@ prefixGen
 prefixGen et word = go 0 (initialChart et) word
   where
     go j chart [] = (j, chart)
-    go j chart (x : xs) =
-      let scanned = scanFrom j x chart
-          closed = closeChartAt et (j + 1) (IntMap.insert (j + 1) scanned chart)
-      in go (j + 1) closed xs
+    go j chart (x : xs)
+      | IntMap.null scanned = (j + 1, closed)
+      | otherwise = go (j + 1) closed xs
+      where
+        scanned = scanFrom j x chart
+        closed = closeChartAt et (j + 1) (IntMap.insert (j + 1) scanned chart)
 
     scanFrom j input chart = IntMap.foldrWithKey advance IntMap.empty eJ
       where

src/Control/Lens/PartialIso.hs

@@ -298,16 +298,16 @@ difoldl1 pattern =
 
 {- | Right fold & unfold `APartialIso` to an `Control.Lens.Iso.Iso`. -}
 difoldr1
-  :: Cons s t a b
+  :: Snoc s t a b
   => APartialIso d c (b,d) (a,c)
   -> Iso (t,d) (s,c) (t,d) (s,c)
 difoldr1 pattern =
   let
     reorder = iso
-      (\((a,s),c) -> (s,(a,c)))
-      (\(t,(b,d)) -> ((b,t),d))
+      (\((s,a),c) -> (s,(a,c)))
+      (\(t,(b,d)) -> ((t,b),d))
     step
-      = crossPartialIso _Cons id
+      = crossPartialIso _Snoc id
       . reorder
       . crossPartialIso id (coPartialIso pattern)
   in from (iterating step)
@@ -323,7 +323,7 @@ difoldl pattern
 
 {- | Right fold & unfold `APartialIso` to a `Control.Lens.Prism.Prism`. -}
 difoldr
-  :: (AsEmpty t, Cons s t a b)
+  :: (AsEmpty t, Snoc s t a b)
   => APartialIso d c (b,d) (a,c)
   -> Prism d c (t,d) (s,c)
 difoldr pattern

src/Data/Profunctor/Distributor.hs

@@ -26,7 +26,7 @@ import Control.Lens.PartialIso
 import Data.Bifunctor.Clown
 import Data.Bifunctor.Joker
 import Data.Bifunctor.Product
-import Data.Foldable hiding (toList)
+import Data.Foldable (foldl')
 import Data.Functor.Adjunction
 import Data.Functor.Contravariant.Divisible
 import Data.Profunctor hiding (WrappedArrow)
@@ -248,6 +248,11 @@ class (Choice p, Distributor p, forall x. Alternative (p x))
 choice :: (Foldable f, Alternative p) => f (p a) -> p a
 choice = foldl' (<|>) empty
 
+instance Alternative f
+  => Alternator (Star f) where
+    alternate = either
+      (\(Star f) -> Star (either (fmap Left . f) (const empty)))
+      (\(Star f) -> Star (either (const empty) (fmap Right . f)))
 instance (Alternator p, Applicative f)
   => Alternator (WrappedPafb f p) where
     alternate =

src/Data/Profunctor/Monadic.hs

@@ -63,7 +63,7 @@ version of `pureP`.
 
 prop> pureP = P.return
 -}
-return :: (Monadic p, Choice p) => Prism a b () () -> p a b
+return :: (Monadic p, Choice p) => APrism a b () () -> p a b
 return = pureP
 
 {- | A `Profunctor` which is also a `MonadTry`. -}

src/Data/Profunctor/Monoidal.hs

@@ -1,4 +1,4 @@
-{-# OPTIONS_GHC -Wno-orphans #-}
+{-# OPTIONS_GHC -Wno-orphans -Wno-redundant-constraints #-}
 
 {-|
 Module      : Data.Profunctor.Monoidal
@@ -16,14 +16,17 @@ module Data.Profunctor.Monoidal
   , oneP, (>*<), (>*), (*<)
   , dimap2, foreverP, ditraverse
     -- * Monoidal & Choice
-  , pureP, asEmpty, (>:<), replicateP, onlyOne
-  , meander, eotFunList
+  , pureP, asEmpty, (>:<), snocP, replicateP, onlyOne
+    -- * Monoidal, Choice & Strong
+  , meander, traverseP, foldP
   ) where
 
 import Control.Lens
 import Control.Lens.Internal.Context
 import Control.Lens.PartialIso
 import Data.Distributive
+import Data.Profunctor
+import Data.Foldable (traverse_)
 import GHC.IsList
 
 -- Monoidal --
@@ -129,6 +132,10 @@ asEmpty = pureP _Empty
 x >:< xs = _Cons >? x >*< xs
 infixr 5 >:<
 
+{- | A `Monoidal` & `Choice` snoc combinator. -}
+snocP :: (Snoc s t a b, Monoidal p, Choice p) => p s t -> p a b -> p s t
+snocP xs x = _Snoc >? xs >*< x
+
 {- | Use when `IsList` with `onlyOne` `Item`. -}
 onlyOne
   :: (Monoidal p, Choice p, IsList s)
@@ -145,17 +152,25 @@ replicateP
 replicateP n _ | n <= 0 = asEmpty
 replicateP n a = a >:< replicateP (n-1) a
 
-{- | For any `Monoidal`, `Choice` & `Data.Profunctor.Strong` `Profunctor`,
+{- | For any `Monoidal`, `Choice` & `Strong` `Profunctor`,
 `meander` is invertible and gives a default implementation for the
 `Data.Profunctor.Traversing.wander`
 method of `Data.Profunctor.Traversing.Traversing`,
-though `Data.Profunctor.Strong` is not needed for its definition.
+though `Strong` isn't needed for its definition,
+but for its invertibility property.
+
+>>> :{
+traversalP :: (forall p. (Monoidal p, Choice p, Strong p) => p a b -> p s t) -> Traversal s t a b
+traversalP f = runStar . f . Star
+:}
+prop> traversalP . meander = id
+prop> meander . traversalP = id
 
 See Pickering, Gibbons & Wu,
 [Profunctor Optics - Modular Data Accessors](https://arxiv.org/abs/1703.10857)
 -}
 meander
-  :: (Monoidal p, Choice p)
+  :: (Monoidal p, Choice p, Strong p)
   => ATraversal s t a b -> p a b -> p s t
 meander f = dimap (f sell) iextract . meandering
   where
@@ -164,6 +179,26 @@ meander f = dimap (f sell) iextract . meandering
       => q u v -> q (Bazaar (->) u w x) (Bazaar (->) v w x)
     meandering q = eotFunList >~ right' (q >*< meandering q)
 
+{- | `traverseP` gives a default implementation for the
+`Data.Profunctor.Traversing.traverse'`
+method of `Data.Profunctor.Traversing.Traversing`.
+-}
+traverseP
+  :: (Traversable f, Monoidal p, Choice p, Strong p)
+  => p a b -> p (f a) (f b)
+traverseP = meander traverse
+
+{- | `foldP` gives a contravariant, profunctorial `Foldable` method.
+However, a `Profunctor` which is also `Contravariant` in its last argument
+is /constant/ over or /phantom/ in its last argument.
+
+prop> foldMap f = getConst . runStar (foldP (Star (Const . f)))
+-}
+foldP
+  :: (Foldable f, Monoidal p, Choice p, Strong p, forall x. (Contravariant (p x)))
+  => p a b -> p (f a) (f b)
+foldP = contramap (const ()) . meander traverse_
+
 {- |
 `eotFunList` is used to define `meander`.
 See van Laarhoven, [A non-regular data type challenge]