folds 0.6.3 → 0.7

raw patch · 13 files changed

+593/−26 lines, 13 filesdep +adjunctionsdep +bifunctorsdep +constraintsdep ~mtldep ~profunctorsdep ~semigroupsPVP ok

version bump matches the API change (PVP)

Dependencies added: adjunctions, bifunctors, constraints, data-reify, distributive, unordered-containers

Dependency ranges changed: mtl, profunctors, semigroups, vector

API changes (from Hackage documentation)

Files

• .travis.yml +102/−12
• CHANGELOG.markdown +4/−0
• README.markdown +1/−1
• folds.cabal +16/−4
• src/Data/Fold/Internal.hs +121/−5
• src/Data/Fold/L'.hs +44/−0
• src/Data/Fold/L.hs +44/−0
• src/Data/Fold/L1'.hs +40/−1
• src/Data/Fold/L1.hs +40/−0
• src/Data/Fold/M.hs +45/−3
• src/Data/Fold/M1.hs +47/−0
• src/Data/Fold/R.hs +44/−0
• src/Data/Fold/R1.hs +45/−0

@@ -1,19 +1,108 @@-language: haskell-before_install:-  # Uncomment whenever hackage is down.-  # - mkdir -p ~/.cabal && cp travis/config ~/.cabal/config && cabal update-  - cabal update+# This file has been generated -- see https://github.com/hvr/multi-ghc-travis+language: c+sudo: false -  # Try installing some of the build-deps with apt-get for speed.-  - travis/cabal-apt-install --enable-tests+cache:+  directories:+    - $HOME/.cabsnap+    - $HOME/.cabal/packages+    - $HOME/.stack +before_cache:+  - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log+  - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.tar++matrix:+  include:+    - env: CABALVER=1.16 GHCVER=7.6.3 BUILD=cabal+      compiler: ": #GHC 7.6.3"+      addons: {apt: {packages: [cabal-install-1.16,ghc-7.6.3,alex-3.1.4,happy-1.19.5], sources: [hvr-ghc]}}++    - env: CABALVER=1.18 GHCVER=7.8.4 BUILD=cabal+      compiler: ": #GHC 7.8.4"+      addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.4,alex-3.1.4,happy-1.19.5], sources: [hvr-ghc]}}++    - env: CABALVER=1.22 GHCVER=7.10.1 BUILD=cabal+      compiler: ": #GHC 7.10.1"+      addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.1,alex-3.1.4,happy-1.19.5], sources: [hvr-ghc]}}++    - env: CABALVER=1.22 GHCVER=7.10.2 BUILD=cabal+      compiler: ": #GHC 7.10.2"+      addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.2,alex-3.1.4,happy-1.19.5], sources: [hvr-ghc]}}++    - env: BUILD=stack STACK_YAML=stack-7.10.yaml STACK_OPTIONS=--skip-ghc-check+      addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.2,alex-3.1.4,happy-1.19.5], sources: [hvr-ghc]}}++    - env: BUILD=stack STACK_YAML=stack-7.10.yaml+      os: osx+++before_install:+ - unset CC+ - case "$BUILD" in+     stack)+       export STACK_VERSION=0.1.3.0;+       export PATH=~/bin:$PATH;+       mkdir -p ~/bin;+       travis_retry curl -L https://github.com/commercialhaskell/stack/releases/download/v$STACK_VERSION/stack-$STACK_VERSION-x86_64-$TRAVIS_OS_NAME.gz | gunzip > ~/bin/stack;+       chmod a+x ~/bin/stack;+       scripts/travis_long stack --no-terminal setup;;+     cabal)+       export HAPPYVER=1.19.5+       export ALEXVER=3.1.4+       export PATH=~/.cabal/bin:/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:/opt/happy/$HAPPYVER/bin:/opt/alex/$ALEXVER/bin:$PATH;;+   esac install:-  - cabal configure --enable-tests-  - cabal build-  - cabal install+ - case "$BUILD" in+     stack)+       scripts/travis_long stack --no-terminal $STACK_OPTIONS build --only-snapshot -j2;;+     cabal)+       echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]"+       cabal --version;+       if [ -f $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz ];+       then+         zcat $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz >+              $HOME/.cabal/packages/hackage.haskell.org/00-index.tar;+       fi;+       travis_retry cabal update;+       cabal install --only-dependencies --enable-tests --enable-benchmarks --dry -v > installplan.txt;+       sed -i -e '1,/^Resolving /d' installplan.txt; cat installplan.txt;+       if diff -u installplan.txt $HOME/.cabsnap/installplan.txt; then+         echo "cabal build-cache HIT";+         rm -rfv .ghc;+         cp -a $HOME/.cabsnap/ghc $HOME/.ghc;+         cp -a $HOME/.cabsnap/lib $HOME/.cabsnap/share $HOME/.cabsnap/bin $HOME/.cabal/;+       else+         echo "cabal build-cache MISS";+         rm -rf $HOME/.cabsnap;+         mkdir -p $HOME/.ghc $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin;+         cabal install --only-dependencies --enable-tests --enable-benchmarks;+         if [ "$GHCVER" = "7.10.1" ]; then cabal install Cabal-1.22.4.0; fi;+       fi;+       if [ ! -d $HOME/.cabsnap ]; then+         echo "snapshotting package-db to build-cache";+         mkdir $HOME/.cabsnap;+         cp -a $HOME/.ghc $HOME/.cabsnap/ghc;+         cp -a $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin installplan.txt $HOME/.cabsnap/;+       fi;;+   esac +# snapshot package-db on cache miss++# Here starts the actual work to be performed for the package under test;+# any command which exits with a non-zero exit code causes the build to fail. script:-  - cabal test --show-details=always+ - case "$BUILD" in+     stack)+       scripts/travis_long stack --no-terminal $STACK_OPTIONS build -j2;;+     cabal)+       cabal configure --enable-tests -v2;+       cabal build;+       cabal test;+       cabal bench || true;+       cabal sdist || true;+       SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz && (cd dist && cabal install --force-reinstalls "$SRC_TGZ");;+   esac  notifications:   irc:@@ -21,4 +110,5 @@       - "irc.freenode.org#haskell-lens"     skip_join: true     template:-      - "\x0313folds\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}"+      - "\x0313folds\x0f/\x0306%{branch}\x0f \x0314%{commit}\x0f %{message} \x0302\x1f%{build_url}\x0f"+# EOF

@@ -1,3 +1,7 @@+0.7+-----+* Folds are closed, corepresentable profunctors. This observation supplies us with many additional useful instances.+ 0.6.3 ------- * `reflection` 2 support

@@ -1,7 +1,7 @@ folds ====== -[![Build Status](https://secure.travis-ci.org/ekmett/folds.png?branch=master)](http://travis-ci.org/ekmett/folds)+[![Hackage](https://img.shields.io/hackage/v/folds.svg)](https://hackage.haskell.org/package/folds) [![Build Status](https://secure.travis-ci.org/ekmett/folds.png?branch=master)](http://travis-ci.org/ekmett/folds)  A playground for working with different kinds of comonadic folds. 

@@ -1,6 +1,6 @@ name:          folds category:      Data, Comonads, Enumerator-version:       0.6.3+version:       0.7 license:       BSD3 cabal-version: >= 1.8 license-file:  LICENSE@@ -50,17 +50,29 @@  library   build-depends:+    adjunctions       >= 4.2   && < 5,     base              >= 4     && < 5,+    bifunctors        >= 4     && < 6,     comonad           >= 4     && < 5,+    constraints       >= 0.4   && < 1,     contravariant     >= 0.4.2 && < 2,+    data-reify        >= 0.6   && < 0.7,+    distributive      >= 0.3   && < 1,     lens              >= 4     && < 5,+    mtl               >= 2.2   && < 2.3,     pointed           >= 4     && < 5,-    profunctors       >= 4     && < 6,+    profunctors       >= 5     && < 6,     reflection        >= 1.3   && < 3,     semigroupoids     >= 4     && < 6,-    tagged            >= 0.7   && < 1,     transformers      >= 0.3   && < 0.5,-    vector            >= 0.10  && < 0.11+    unordered-containers >= 0.2 && < 0.3,+    vector            >= 0.10  && < 0.12++  if impl(ghc < 7.8)+    build-depends: tagged >= 0.7 && < 1++  if impl(ghc < 7.11)+    build-depends: semigroups >= 0.8 && < 1    hs-source-dirs: src 

@@ -1,8 +1,15 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UndecidableInstances #-} module Data.Fold.Internal   ( SnocList(..)   , SnocList1(..)@@ -10,25 +17,44 @@   , Maybe'(..), maybe'   , Pair'(..)   , N(..)+  , S(..)   , Tree(..)   , Tree1(..)   , An(..)   , Box(..)+  , FreeMonoid(..)+  , foldDeRef+  , FreeSemigroup(..)+  , foldDeRef1   ) where  #if __GLASGOW_HASKELL__ < 710 import Control.Applicative #endif+import Control.Monad.Fix+import Data.Bifunctor+import Data.Bifoldable+import Data.Bitraversable+import Data.Constraint import Data.Data (Data, Typeable)+import Data.Semigroup hiding (Last, First) #if __GLASGOW_HASKELL__ < 710 import Data.Foldable-import Data.Monoid hiding (First, Last) #endif+import Data.Functor.Bind+import Data.HashMap.Lazy as HM+import Data.Profunctor.Unsafe import Data.Proxy (Proxy(Proxy)) import Data.Reflection+import Data.Reify+import Data.Semigroup.Foldable+import Data.Semigroup.Bifoldable+import Data.Semigroup.Bitraversable+ #if __GLASGOW_HASKELL__ < 710 import Data.Traversable #endif+import System.IO.Unsafe  -- | Reversed '[]' data SnocList a = Snoc (SnocList a) a | Nil@@ -79,8 +105,6 @@   traverse f (First a) = First <$> f a   {-# INLINABLE traverse #-} -- -- | Strict 'Maybe' data Maybe' a = Nothing' | Just' !a   deriving (Eq,Ord,Show,Read,Typeable,Data)@@ -126,6 +150,13 @@   traverse f (One a) = One <$> f a   traverse f (Two a b) = Two <$> traverse f a <*> traverse f b +-- | A reified 'Semigroup'.+newtype S a s = S { runS :: a }+  deriving (Eq,Ord,Show,Read,Typeable,Data)++instance Reifies s (a -> a -> a) => Semigroup (S a s) where+  S a <> S b = S $ reflect (Proxy :: Proxy s) a b+ -- | Strict Pair data Pair' a b = Pair' !a !b deriving (Eq,Ord,Show,Read,Typeable,Data) @@ -197,3 +228,88 @@ instance Traversable Tree1 where   traverse f (Bin1 as bs) = Bin1 <$> traverse f as <*> traverse f bs   traverse f (Tip1 a) = Tip1 <$> f a++newtype FreeMonoid a = FreeMonoid { runFreeMonoid :: forall m. Monoid m => (a -> m) -> m } deriving Functor++instance Foldable FreeMonoid where+  foldMap f m = runFreeMonoid m f++newtype FreeSemigroup a = FreeSemigroup { runFreeSemigroup :: forall m. Semigroup m => (a -> m) -> m } deriving Functor++instance Foldable FreeSemigroup where+  foldMap f (FreeSemigroup m) = unwrapMonoid $ m (WrapMonoid #. f)++instance Foldable1 FreeSemigroup where+  foldMap1 f (FreeSemigroup m) = m f++data T a b = T0 | T1 a | T2 b b deriving (Functor, Foldable, Traversable)++instance MuRef (Tree a) where+  type DeRef (Tree a) = T a+  mapDeRef _ Zero    = pure T0+  mapDeRef _ (One a) = pure (T1 a)+  mapDeRef f (Two x y) = T2 <$> f x <*> f y++class MuRef1 (f :: * -> *) where+  type DeRef1 f :: * -> * -> *+  muRef1 :: proxy (f a) -> Dict (MuRef (f a), DeRef (f a) ~ DeRef1 f a)++foldDeRef :: forall f a. (MuRef1 f, Bifoldable (DeRef1 f)) => f a -> FreeMonoid a+foldDeRef m = case muRef1 (undefined :: Proxy (f a)) of+  Dict -> case unsafePerformIO (reifyGraph m) of+    Graph xs i | hm <- HM.fromList xs -> FreeMonoid $ \ f -> fix (\mm -> fmap (bifoldMap f (mm !)) hm) ! i++instance MuRef1 Tree where+  type DeRef1 Tree = T+  muRef1 _ = Dict++instance Bifunctor T where+  bimap _ _ T0 = T0+  bimap f _ (T1 a) = T1 (f a)+  bimap _ g (T2 b c) = T2 (g b) (g c)++instance Bifoldable T where+  bifoldMap _ _ T0 = mempty+  bifoldMap f _ (T1 a) = f a+  bifoldMap _ g (T2 b c) = g b `mappend` g c++instance Bitraversable T where+  bitraverse _ _ T0 = pure T0+  bitraverse f _ (T1 a) = T1 <$> f a+  bitraverse _ g (T2 b c) = T2 <$> g b <*> g c++data T1 a b = A a | B b b deriving (Functor, Foldable, Traversable)++instance MuRef (Tree1 a) where+  type DeRef (Tree1 a) = T1 a+  mapDeRef _ (Tip1 a) = pure (A a)+  mapDeRef f (Bin1 b c) = B <$> f b <*> f c++instance MuRef1 Tree1 where+  type DeRef1 Tree1 = T1+  muRef1 _ = Dict++instance Bifunctor T1 where+  bimap f _ (A a) = A (f a)+  bimap _ g (B b c) = B (g b) (g c)++instance Bifoldable T1 where+  bifoldMap f _ (A a) = f a+  bifoldMap _ g (B b c) = g b `mappend` g c++instance Bitraversable T1 where+  bitraverse f _ (A a) = A <$> f a+  bitraverse _ g (B b c) = B <$> g b <*> g c++foldDeRef1 :: forall f a. (MuRef1 f, Bifoldable1 (DeRef1 f)) => f a -> FreeSemigroup a+foldDeRef1 m = case muRef1 (undefined :: Proxy (f a)) of+  Dict -> case unsafePerformIO (reifyGraph m) of+    Graph xs i | hm <- HM.fromList xs -> FreeSemigroup $ \ f -> fix (\mm -> fmap (bifoldMap1 f (mm !)) hm) ! i++instance Bifoldable1 T1 where+  bifoldMap1 f _ (A a) = f a+  bifoldMap1 _ g (B b c) = g b <> g c++instance Bitraversable1 T1 where+  bitraverse1 f _ (A a) = A <$> f a+  bitraverse1 _ g (B b c) = B <$> g b <.> g c

@@ -1,7 +1,9 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ExistentialQuantification #-} module Data.Fold.L'@@ -12,12 +14,20 @@ import Control.Applicative import Control.Comonad import Control.Lens+import Control.Monad.Reader.Class+import Control.Monad.Fix import Control.Monad.Zip+import Data.Distributive import Data.Foldable import Data.Fold.Class import Data.Fold.Internal import Data.Functor.Extend import Data.Functor.Bind+import Data.Functor.Rep as Functor+import Data.Profunctor+import Data.Profunctor.Closed+import Data.Profunctor.Rep as Profunctor+import Data.Profunctor.Sieve import Data.Profunctor.Unsafe import Unsafe.Coerce import Prelude hiding (foldl)@@ -164,3 +174,37 @@    _ @> m = m   {-# INLINE (@>) #-}++instance Distributive (L' a) where+  distribute = L' (fmap extract) (\fm a -> fmap (prefix1 a) fm)+  {-# INLINE distribute #-}++instance Functor.Representable (L' a) where+  type Rep (L' a) = [a]+  index = cosieve+  tabulate = cotabulate++instance Costrong L' where+  unfirst = unfirstCorep+  unsecond = unsecondCorep++instance Closed L' where+  closed (L' k h z) = L' (\f x -> k (f x)) (liftA2 h) (pure z)++instance Profunctor.Corepresentable L' where+  type Corep L' = []+  cotabulate f = L' (f . reverse) (flip (:)) []+  {-# INLINE cotabulate #-}++instance Cosieve L' [] where+  cosieve (L' k0 h0 z0) as0 = go k0 h0 z0 as0 where+    go k _ z [] = k z+    go k h z (a:as) = go k h (h z a) as+  {-# INLINE cosieve #-}++instance MonadReader [a] (L' a) where+  ask = askRep+  local = localRep++instance MonadFix (L' a) where+  mfix = mfixRep

@@ -2,8 +2,10 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE TypeFamilies #-} module Data.Fold.L   ( L(..)   , unfoldL@@ -12,12 +14,20 @@ import Control.Applicative import Control.Comonad import Control.Lens+import Control.Monad.Reader.Class+import Control.Monad.Fix import Control.Monad.Zip+import Data.Distributive import Data.Foldable import Data.Fold.Class import Data.Fold.Internal import Data.Functor.Extend import Data.Functor.Bind+import Data.Functor.Rep as Functor+import Data.Profunctor+import Data.Profunctor.Closed+import Data.Profunctor.Sieve+import Data.Profunctor.Rep as Profunctor import Data.Profunctor.Unsafe import Unsafe.Coerce import Prelude hiding (foldl)@@ -169,3 +179,37 @@    _ @> m = m   {-# INLINE (@>) #-}++instance Distributive (L a) where+  distribute = L (fmap extract) (\fm a -> fmap (prefix1 a) fm)+  {-# INLINE distribute #-}++instance Functor.Representable (L a) where+  type Rep (L a) = [a]+  index = cosieve+  tabulate = cotabulate++instance MonadReader [a] (L a) where+  ask = askRep+  local = localRep++instance Costrong L where+  unfirst = unfirstCorep+  unsecond = unsecondCorep++instance Cosieve L [] where+  cosieve (L k0 h0 z0) as0 = go k0 h0 z0 as0 where+    go k _ z [] = k z+    go k h z (a:as) = go k h (h z a) as+  {-# INLINE cosieve #-}++instance Closed L where+  closed (L k h z) = L (\f x -> k (f x)) (liftA2 h) (pure z)++instance Profunctor.Corepresentable L where+  type Corep L = []+  cotabulate f = L (f . reverse) (flip (:)) []+  {-# INLINE cotabulate #-}++instance MonadFix (L a) where+  mfix = mfixRep

@@ -1,5 +1,6 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ExistentialQuantification #-} module Data.Fold.L1'   ( L1'(..)@@ -8,12 +9,20 @@ import Control.Applicative import Control.Arrow import Control.Category+import Control.Monad.Fix+import Control.Monad.Reader.Class import Control.Lens+import Data.Distributive import Data.Fold.Class import Data.Fold.Internal import Data.Functor.Apply+import Data.Functor.Rep as Functor+import Data.List.NonEmpty as NonEmpty import Data.Pointed import Data.Profunctor+import Data.Profunctor.Closed+import Data.Profunctor.Rep as Profunctor+import Data.Profunctor.Sieve import Data.Profunctor.Unsafe import Data.Semigroupoid import Prelude hiding (id,(.))@@ -147,3 +156,33 @@   go (First a) = z a   go (Snoc1 as a) = h (go as) a {-# INLINE walk #-}++instance Cosieve L1' NonEmpty where+  cosieve (L1' k h z) (a :| as) = k (foldl h (z a) as) where++instance Costrong L1' where+  unfirst = unfirstCorep+  unsecond = unsecondCorep++instance Profunctor.Corepresentable L1' where+  type Corep L1' = NonEmpty+  cotabulate f = L1' (f . NonEmpty.fromList . Prelude.reverse) (flip (:)) pure+  {-# INLINE cotabulate #-}++instance Distributive (L1' a) where+  distribute = distributeRep++instance Functor.Representable (L1' a) where+  type Rep (L1' a) = NonEmpty a+  tabulate = cotabulate+  index = cosieve++instance Closed L1' where+  closed (L1' k h z) = L1' (\f x -> k (f x)) (liftA2 h) (fmap z)++instance MonadReader (NonEmpty a) (L1' a) where+  ask = askRep+  local = localRep++instance MonadFix (L1' a) where+  mfix = mfixRep

@@ -1,5 +1,7 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE Trustworthy #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-} module Data.Fold.L1   ( L1(..)   ) where@@ -8,12 +10,20 @@ import Control.Arrow import Control.Category import Control.Lens+import Control.Monad.Fix+import Control.Monad.Reader.Class import Control.Monad.Zip+import Data.Distributive import Data.Fold.Class import Data.Fold.Internal import Data.Functor.Apply+import Data.Functor.Rep as Functor+import Data.List.NonEmpty as NonEmpty import Data.Pointed import Data.Profunctor+import Data.Profunctor.Closed+import Data.Profunctor.Rep as Profunctor+import Data.Profunctor.Sieve import Data.Profunctor.Unsafe import Data.Semigroupoid import Prelude hiding (id,(.))@@ -151,3 +161,33 @@   go (First a) = z a   go (Snoc1 as a) = h (go as) a {-# INLINE walk #-}++instance Cosieve L1 NonEmpty where+  cosieve (L1 k h z) (a :| as) = k (foldl h (z a) as) where++instance Costrong L1 where+  unfirst = unfirstCorep+  unsecond = unsecondCorep++instance Profunctor.Corepresentable L1 where+  type Corep L1 = NonEmpty+  cotabulate f = L1 (f . NonEmpty.fromList . Prelude.reverse) (flip (:)) pure+  {-# INLINE cotabulate #-}++instance Distributive (L1 a) where+  distribute = distributeRep++instance Functor.Representable (L1 a) where+  type Rep (L1 a) = NonEmpty a+  tabulate = cotabulate+  index = cosieve++instance Closed L1 where+  closed (L1 k h z) = L1 (\f x -> k (f x)) (liftA2 h) (fmap z)++instance MonadReader (NonEmpty a) (L1 a) where+  ask = askRep+  local = localRep++instance MonadFix (L1 a) where+  mfix = mfixRep

@@ -1,8 +1,11 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE Rank2Types #-} {-# LANGUAGE Trustworthy #-}-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ExistentialQuantification #-} -- | -- Unlike 'Data.Fold.L' and 'Data.Fold.R' this 'Comonad'@@ -15,12 +18,20 @@ import Control.Applicative import Control.Comonad import Control.Lens+import Control.Monad.Fix+import Control.Monad.Reader.Class import Control.Monad.Zip+import Data.Distributive import Data.Fold.Class import Data.Fold.Internal import Data.Foldable hiding (sum, product)-import Data.Functor.Extend import Data.Functor.Bind+import Data.Functor.Extend+import Data.Functor.Rep as Functor+import Data.Profunctor+import Data.Profunctor.Closed+import Data.Profunctor.Rep as Profunctor+import Data.Profunctor.Sieve import Data.Profunctor.Unsafe import Data.Proxy import Data.Reflection@@ -137,6 +148,7 @@   return = pure   {-# INLINE return #-} +  -- TODO: exploit observable sharing?   m >>= f = M (\xs a -> run xs (f a)) One Two Zero <*> m   {-# INLINE (>>=) #-} @@ -173,3 +185,33 @@    _ @> m = m   {-# INLINE (@>) #-}++instance Distributive (M a) where+  distribute fm = M (\t -> let g = foldDeRef t in run g <$> fm) One Two Zero+  {-# INLINE distribute #-}++instance Closed M where+  closed (M k h m z) = M (\f x -> k (f x)) (fmap h) (liftA2 m) (pure z)++instance Cosieve M FreeMonoid where+  cosieve = flip run++instance Profunctor.Corepresentable M where+  type Corep M = FreeMonoid+  cotabulate f = M (f . foldDeRef) One Two Zero++instance MonadReader (FreeMonoid a) (M a) where+  ask = askRep+  local = localRep++instance Functor.Representable (M a) where+  type Rep (M a) = FreeMonoid a+  tabulate = cotabulate+  index = cosieve++instance Costrong M where+  unfirst = unfirstCorep+  unsecond = unsecondCorep++instance MonadFix (M a) where+  mfix = mfixRep

@@ -1,20 +1,34 @@ {-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ExistentialQuantification #-} module Data.Fold.M1   ( M1(..)+  , runM1   ) where  import Control.Applicative import Control.Arrow import Control.Category import Control.Lens+import Control.Monad.Fix+import Control.Monad.Reader.Class import Control.Monad.Zip+import Data.Distributive import Data.Fold.Class import Data.Fold.Internal import Data.Functor.Apply+import Data.Functor.Rep as Functor import Data.Pointed import Data.Profunctor+import Data.Profunctor.Closed+import Data.Profunctor.Sieve+import Data.Profunctor.Rep as Profunctor import Data.Profunctor.Unsafe+import Data.Proxy+import Data.Reflection+import Data.Semigroup.Foldable import Data.Semigroupoid import Prelude hiding (id,(.)) import Unsafe.Coerce@@ -154,3 +168,36 @@   go (Tip1 a) = h a   go (Bin1 xs ys) = m (go xs) (go ys) {-# INLINE walk #-}++runM1 :: Foldable1 f => f a -> M1 a b -> b+runM1 p (M1 k h (m :: m -> m -> m)) = reify m $ \ (_ :: Proxy s) -> k $ runS (foldMap1 (S #. h) p :: S m s)++instance Closed M1 where+  closed (M1 k h m) = M1 (\f x -> k (f x)) (fmap h) (liftA2 m)++instance Distributive (M1 a) where+  distribute fm = M1 (\t -> let g = foldDeRef1 t in runM1 g <$> fm) Tip1 Bin1+  {-# INLINE distribute #-}++instance Cosieve M1 FreeSemigroup where+  cosieve = flip runM1++instance Profunctor.Corepresentable M1 where+  type Corep M1 = FreeSemigroup+  cotabulate f = M1 (f . foldDeRef1) Tip1 Bin1++instance Functor.Representable (M1 a) where+  type Rep (M1 a) = FreeSemigroup a+  tabulate = cotabulate+  index = cosieve++instance Costrong M1 where+  unfirst = unfirstCorep+  unsecond = unsecondCorep++instance MonadReader (FreeSemigroup a) (M1 a) where+  ask = askRep+  local = localRep++instance MonadFix (M1 a) where+  mfix = mfixRep

@@ -4,6 +4,8 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MultiParamTypeClasses #-} module Data.Fold.R   ( R(..)   ) where@@ -11,12 +13,20 @@ import Control.Applicative import Control.Comonad import Control.Lens+import Control.Monad.Fix+import Control.Monad.Reader.Class import Control.Monad.Zip+import Data.Distributive import Data.Foldable hiding (sum, product) import Data.Fold.Class import Data.Fold.Internal import Data.Functor.Extend import Data.Functor.Bind+import Data.Functor.Rep as Functor+import Data.Profunctor+import Data.Profunctor.Closed+import Data.Profunctor.Rep as Profunctor+import Data.Profunctor.Sieve import Data.Profunctor.Unsafe import Unsafe.Coerce import Prelude hiding (foldr, sum, product, length)@@ -155,3 +165,37 @@    _ @> m = m   {-# INLINE (@>) #-}++instance Distributive (R a) where+  distribute = R (fmap extract) (fmap . prefix1)+  {-# INLINE distribute #-}++instance Functor.Representable (R a) where+  type Rep (R a) = [a]+  index = cosieve+  tabulate = cotabulate++instance Costrong R where+  unfirst = unfirstCorep+  unsecond = unsecondCorep++instance Profunctor.Corepresentable R where+  type Corep R = []+  cotabulate f = R (f . reverse) (:) []+  {-# INLINE cotabulate #-}++instance Cosieve R [] where+  cosieve (R k0 h0 z0) as0 = go k0 h0 z0 as0 where+    go k _ z [] = k z+    go k h z (a:as) = go k h (h a z) as+  {-# INLINE cosieve #-}++instance MonadReader [a] (R a) where+  ask = askRep+  local = localRep++instance Closed R where+  closed (R k h z) = R (\f x -> k (f x)) (liftA2 h) (pure z)++instance MonadFix (R a) where+  mfix = mfixRep

@@ -1,4 +1,6 @@ {-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ExistentialQuantification #-} module Data.Fold.R1   ( R1(..)@@ -8,12 +10,20 @@ import Control.Arrow import Control.Category import Control.Lens+import Control.Monad.Fix+import Control.Monad.Reader.Class import Control.Monad.Zip+import Data.Distributive import Data.Fold.Class import Data.Fold.Internal import Data.Functor.Apply+import Data.Functor.Rep as Functor+import Data.List.NonEmpty as NonEmpty import Data.Pointed import Data.Profunctor+import Data.Profunctor.Closed+import Data.Profunctor.Rep as Profunctor+import Data.Profunctor.Sieve import Data.Profunctor.Unsafe import Data.Semigroupoid import Prelude hiding (id,(.))@@ -151,3 +161,38 @@   go (Last a) = z a   go (Cons1 a as) = h a (go as) {-# INLINE walk #-}++instance Closed R1 where+  closed (R1 k h z) = R1 (\f x -> k (f x)) (liftA2 h) (fmap z)++instance Cosieve R1 NonEmpty where+  cosieve (R1 k h z) l = k (cata h z l)++cata :: (a -> c -> c) -> (a -> c) -> NonEmpty a -> c+cata f0 z0 (a0 :| as0) = go f0 z0 a0 as0 where+  go _ z a [] = z a+  go f z a (b:bs) = f a (go f z b bs)++instance Costrong R1 where+  unfirst = unfirstCorep+  unsecond = unsecondCorep++instance Profunctor.Corepresentable R1 where+  type Corep R1 = NonEmpty+  cotabulate f = R1 (f . NonEmpty.fromList . Prelude.reverse) (:) pure+  {-# INLINE cotabulate #-}++instance Distributive (R1 a) where+  distribute = distributeRep++instance Functor.Representable (R1 a) where+  type Rep (R1 a) = NonEmpty a+  tabulate = cotabulate+  index = cosieve++instance MonadReader (NonEmpty a) (R1 a) where+  ask = askRep+  local = localRep++instance MonadFix (R1 a) where+  mfix = mfixRep