packages feed

folds (empty) → 0.1

raw patch · 17 files changed

+1216/−0 lines, 17 filesdep +basedep +bytestringdep +comonadbuild-type:Customsetup-changed

Dependencies added: base, bytestring, comonad, contravariant, deepseq, directory, doctest, filepath, hlint, lens, mtl, profunctors, reflection, semigroupoids, semigroups, tagged, vector

Files

+ .ghci view
@@ -0,0 +1,1 @@+:set -isrc -idist/build/autogen -optP-include -optPdist/build/autogen/cabal_macros.h
+ .gitignore view
@@ -0,0 +1,16 @@+dist+docs+wiki+TAGS+tags+wip+stats+.DS_Store+.*.swp+.*.swo+*.o+*.hi+*~+*#+.cabal-sandbox+cabal.sandbox.config
+ .travis.yml view
@@ -0,0 +1,24 @@+language: haskell+before_install:+  # Uncomment whenever hackage is down.+  # - mkdir -p ~/.cabal && cp travis/config ~/.cabal/config && cabal update+  - cabal update++  # Try installing some of the build-deps with apt-get for speed.+  - travis/cabal-apt-install --enable-tests++install:+  - cabal configure --enable-tests+  - cabal build+  - cabal install++script:+  - cabal test --show-details=always++notifications:+  irc:+    channels:+      - "irc.freenode.org#haskell-lens"+    skip_join: true+    template:+      - "\x0313folds\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}"
+ .vim.custom view
@@ -0,0 +1,31 @@+" Add the following to your .vimrc to automatically load this on startup++" if filereadable(".vim.custom")+"     so .vim.custom+" endif++function StripTrailingWhitespace()+  let myline=line(".")+  let mycolumn = col(".")+  silent %s/  *$//+  call cursor(myline, mycolumn)+endfunction++" enable syntax highlighting+syntax on++" search for the tags file anywhere between here and /+set tags=TAGS;/++" highlight tabs and trailing spaces+set listchars=tab:‗‗,trail:‗+set list++" f2 runs hasktags+map <F2> :exec ":!hasktags -x -c --ignore src"<CR><CR>++" strip trailing whitespace before saving+" au BufWritePre *.hs,*.markdown silent! cal StripTrailingWhitespace()++" rebuild hasktags after saving+au BufWritePost *.hs silent! :exec ":!hasktags -x -c --ignore src"
+ CHANGELOG.markdown view
@@ -0,0 +1,3 @@+0.1+---+* Repository Initialized
+ LICENSE view
@@ -0,0 +1,26 @@+Copyright 2009-2013 Edward Kmett++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ README.markdown view
@@ -0,0 +1,15 @@+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.++Contact Information+-------------------++Contributions and bug reports are welcome!++Please feel free to contact me through github or on the #haskell IRC channel on irc.freenode.net.++-Edward Kmett
+ Setup.lhs view
@@ -0,0 +1,55 @@+#!/usr/bin/runhaskell+\begin{code}+{-# OPTIONS_GHC -Wall #-}+module Main (main) where++import Data.List ( nub )+import Data.Version ( showVersion )+import Distribution.Package ( PackageName(PackageName), Package, PackageId, InstalledPackageId, packageVersion, packageName )+import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) )+import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks )+import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose, copyFiles )+import Distribution.Simple.BuildPaths ( autogenModulesDir )+import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), Flag(..), fromFlag, HaddockFlags(haddockDistPref))+import Distribution.Simple.LocalBuildInfo ( withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps) )+import Distribution.Text ( display )+import Distribution.Verbosity ( Verbosity, normal )+import System.FilePath ( (</>) )++main :: IO ()+main = defaultMainWithHooks simpleUserHooks+  { buildHook = \pkg lbi hooks flags -> do+     generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi+     buildHook simpleUserHooks pkg lbi hooks flags+  , postHaddock = \args flags pkg lbi -> do+     copyFiles normal (haddockOutputDir flags pkg) []+     postHaddock simpleUserHooks args flags pkg lbi+  }++haddockOutputDir :: Package p => HaddockFlags -> p -> FilePath+haddockOutputDir flags pkg = destDir where+  baseDir = case haddockDistPref flags of+    NoFlag -> "."+    Flag x -> x+  destDir = baseDir </> "doc" </> "html" </> display (packageName pkg)++generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO ()+generateBuildModule verbosity pkg lbi = do+  let dir = autogenModulesDir lbi+  createDirectoryIfMissingVerbose verbosity True dir+  withLibLBI pkg lbi $ \_ libcfg -> do+    withTestLBI pkg lbi $ \suite suitecfg -> do+      rewriteFile (dir </> "Build_" ++ testName suite ++ ".hs") $ unlines+        [ "module Build_" ++ testName suite ++ " where"+        , "deps :: [String]"+        , "deps = " ++ (show $ formatdeps (testDeps libcfg suitecfg))+        ]+  where+    formatdeps = map (formatone . snd)+    formatone p = case packageName p of+      PackageName n -> n ++ "-" ++ showVersion (packageVersion p)++testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)]+testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys++\end{code}
+ folds.cabal view
@@ -0,0 +1,111 @@+name:          folds+category:      Data, Vector+version:       0.1+license:       BSD3+cabal-version: >= 1.8+license-file:  LICENSE+author:        Edward A. Kmett+maintainer:    Edward A. Kmett <ekmett@gmail.com>+stability:     experimental+homepage:      http://github.com/ekmett/folds+bug-reports:   http://github.com/ekmett/folds/issues+copyright:     Copyright (C) 2009-2013 Edward A. Kmett+build-type:    Custom+synopsis:      Beautiful Folding++extra-source-files:+  .ghci+  .travis.yml+  .gitignore+  .vim.custom+  CHANGELOG.markdown+  README.markdown++description: This package is a playground full of comonadic folds.+  .+  This style of fold is documented in <https://www.fpcomplete.com/user/edwardk/cellular-automata/part-2 "Cellular Automata, Part II: PNGs and Moore">+  .+  This package can be seen as what happens if you chase Max Rabkin's <http://squing.blogspot.com/2008/11/beautiful-folding.html "Beautiful Folding"> to its logical conclusion.+  .+  More information on this approach can be found in the <http://conal.net/blog/posts/another-lovely-example-of-type-class-morphisms "Another lovely example of type class morphisms"> and <http://conal.net/blog/posts/more-beautiful-fold-zipping "More beautiful fold zipping"> posts by Conal Elliott, as well as in Gabriel Gonzales' <http://www.haskellforall.com/2013/08/composable-streaming-folds.html "Composable Streaming Folds">++source-repository head+  type: git+  location: git://github.com/ekmett/folds.git++-- You can disable the doctests test suite with -f-test-doctests+flag test-doctests+  default: True+  manual: True++-- You can disable the hlint test suite with -f-test-hlint+flag test-hlint+  default: True+  manual: True++-- You can disable the optimizations -f-optimize for faster builds+flag optimize+  default: True+  manual: True++library+  build-depends:+    base              >= 4     && < 5,+    comonad           >= 3.1   && < 4,+    contravariant     >= 0.4.2 && < 1,+    lens              >= 3.9   && < 4,+    profunctors       >= 3.3   && < 4,+    reflection        >= 1.3   && < 2,+    semigroupoids     >= 3.1   && < 4,+    tagged            >= 0.7   && < 1,+    vector            >= 0.10  && < 0.11++  hs-source-dirs: src++  exposed-modules:+    Data.Fold+    Data.Fold.Class+    Data.Fold.L+    Data.Fold.L'+    Data.Fold.M+    Data.Fold.R++  ghc-options: -Wall++  if flag(optimize)+    ghc-options: -O2++test-suite hlint+  type: exitcode-stdio-1.0+  main-is: hlint.hs+  ghc-options: -w -threaded -rtsopts -with-rtsopts=-N+  hs-source-dirs: tests++  if !flag(test-hlint)+    buildable: False+  else+    build-depends:+      base,+      hlint >= 1.7++test-suite doctests+  type:           exitcode-stdio-1.0+  main-is:        doctests.hs+  ghc-options:    -Wall -threaded+  hs-source-dirs: tests++  if !flag(test-doctests)+    buildable: False+  else+    build-depends:+      base,+      bytestring,+      directory      >= 1.0,+      deepseq,+      doctest        >= 0.9.1,+      filepath,+      mtl,+      semigroups     >= 0.9++  if impl(ghc<7.6.1)+    ghc-options: -Werror
+ src/Data/Fold.hs view
@@ -0,0 +1,155 @@+-----------------------------------------------------------------------------+-- |+-- Copyright   :  (C) 2009-2013 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable+--+----------------------------------------------------------------------------+module Data.Fold+  (+  -- * Foldings+  -- ** Left Foldings+    L(..), L'(..)+  -- ** Monoidal Foldings+  , M(..)+  -- ** Right Foldings+  , R(..)+  -- * Folding Combinators+  , Folding(..)+  , beneath+  -- * Folding Homomorphisms+  -- $hom+  , AsRM(..)+  , AsL'(..)+  ) where++import Data.Fold.Class+import Data.Fold.L+import Data.Fold.L'+import Data.Fold.M+import Data.Fold.R+import Control.Category ((>>>))++-- * Folding Homomorphisms++-- $hom+--+-- We define @f@ to be a folding homomorphism betwen @p@ and @q@ when:+--+-- @+-- f :: forall a b. p a b -> q a b+-- @+--+-- @+-- 'run' xs (f φ)         ≡ 'run' xs φ+-- 'runOf' l xs (f φ)     ≡ 'runOf' l xs φ+-- 'prefix' xs (f φ)      ≡ f ('prefix' xs φ)+-- 'prefixOf' l xs (f φ)  ≡ f ('prefixOf' l xs φ)+-- 'postfix' (f φ) xs     ≡ f ('postfix' φ xs)+-- 'postfixOf' l (f φ) xs ≡ f ('postfixOf' l φ xs)+-- 'left'' (f φ)          ≡ f ('left'' φ)+-- 'right'' (f φ)         ≡ f ('right'' φ)+-- 'dimap' l r (f φ)      ≡ f ('dimap' l r φ)+-- 'extract' (f φ)        ≡ 'extract' φ+-- 'extend' h (f φ)       ≡ f ('extend' (h . f) φ)+-- 'pure' a               ≡ f ('pure' a)+-- f φ '<*>' f ψ          ≡ f (φ '<*>' ψ)+-- 'return' a             ≡ f ('return' a)+-- f φ '>>=' f . k        ≡ f (φ '>>=' k)+-- @++class AsRM p where+  -- | 'asM' is a folding homomorphism to a monoidal folding+  --+  -- @+  -- 'run' xs ('asM' φ)         ≡ 'run' xs φ+  -- 'prefix' xs ('asM' φ)      ≡ 'asM' ('prefix' xs φ)+  -- 'prefixOf' l xs ('asM' φ)  ≡ 'asM' ('prefixOf' l xs φ)+  -- 'postfix' ('asM' φ) xs     ≡ 'asM' ('postfix' φ xs)+  -- 'postfixOf' l ('asM' φ) xs ≡ 'asM' ('postfixOf' l φ xs)+  -- 'left'' ('asM' φ)          ≡ 'asM' ('left'' φ)+  -- 'right'' ('asM' φ)         ≡ 'asM' ('right'' φ)+  -- 'dimap' l r ('asM' φ)      ≡ 'asM' ('dimap' l r φ)+  -- 'extract' ('asM' φ)        ≡ 'extract' φ+  -- 'extend' h ('asM' φ)       ≡ 'asM' ('extend' (h . 'asM') φ)+  -- 'pure' a                  ≡ 'asM' ('pure' a)+  -- 'asM' φ '<*>' 'asM' ψ        ≡ 'asM' (φ '<*>' ψ)+  -- 'return' a                ≡ 'asM' ('return' a)+  -- 'asM' φ '>>=' 'asM' . k      ≡ 'asM' (φ '>>=' k)+  -- @+  asM :: p a b -> M a b+  asM = asM . asR++  -- | 'asR' is a folding homomorphism to a right folding+  --+  -- @+  -- 'run' xs ('asR' φ)         ≡ 'run' xs φ+  -- 'prefix' xs ('asR' φ)      ≡ 'asR' ('prefix' xs φ)+  -- 'prefixOf' l xs ('asR' φ)  ≡ 'asR' ('prefixOf' l xs φ)+  -- 'postfix' ('asR' φ) xs     ≡ 'asR' ('postfix' φ xs)+  -- 'postfixOf' l ('asR' φ) xs ≡ 'asR' ('postfixOf' l φ xs)+  -- 'left'' ('asR' φ)          ≡ 'asR' ('left'' φ)+  -- 'right'' ('asR' φ)         ≡ 'asR' ('right'' φ)+  -- 'dimap' l r ('asR' φ)      ≡ 'asR' ('dimap' l r φ)+  -- 'extract' ('asR' φ)        ≡ 'extract' φ+  -- 'extend' h ('asR' φ)       ≡ 'asR' ('extend' (h . 'asR') φ)+  -- 'pure' a                  ≡ 'asR' ('pure' a)+  -- 'asR' φ '<*>' 'asR' ψ        ≡ 'asR' (φ '<*>' ψ)+  -- 'return' a                ≡ 'asR' ('return' a)+  -- 'asR' φ '>>=' 'asR' . k      ≡ 'asR' (φ '>>=' k)+  -- @+  asR :: p a b -> R a b+  asR = asR . asM++-- | We can convert from a lazy right fold to a monoidal fold+instance AsRM R where+  asM (R k h z) = M (\f -> k (f z)) h (.) id+  asR = id++-- | We can convert from a monoidal fold to a lazy right fold+instance AsRM M where+  asR (M k h m z) = R k (m . h) z+  asM = id++-- | We can convert from a lazy left folding to a right or monoidal fold+instance AsRM L where+  asM (L k h z) = M (\f -> k (f z)) (flip h) (>>>) id+  asR (L k h z) = R (\f -> k (f z)) (\b g x -> g (h x b)) id++-- | We can convert from a strict left folding to a right or monoidal fold+instance AsRM L' where+  asR (L' k h z) = R (\f -> k (f z)) (\b g x -> g $! h x b) id++class AsL' p where+  -- | 'asL'' is a folding homomorphism to a strict left folding+  --+  -- @+  -- 'run' xs ('asL'' φ)         ≡ 'run' xs φ+  -- 'prefix' xs ('asL'' φ)      ≡ 'asL'' ('prefix' xs φ)+  -- 'prefixOf' l xs ('asL'' φ)  ≡ 'asL'' ('prefixOf' l xs φ)+  -- 'postfix' ('asL'' φ) xs     ≡ 'asL'' ('postfix' φ xs)+  -- 'postfixOf' l ('asL'' φ) xs ≡ 'asL'' ('postfixOf' l φ xs)+  -- 'left'' ('asL'' φ)          ≡ 'asL'' ('left'' φ)+  -- 'right'' ('asL'' φ)         ≡ 'asL'' ('right'' φ)+  -- 'dimap' l r ('asL'' φ)      ≡ 'asL'' ('dimap' l r φ)+  -- 'extract' ('asL'' φ)        ≡ 'extract' φ+  -- 'extend' h ('asL'' φ)       ≡ 'asL'' ('extend' (h . 'asL'') φ)+  -- 'pure' a                   ≡ 'asL'' ('pure' a)+  -- 'asL'' φ '<*>' 'asL'' ψ       ≡ 'asL'' (φ '<*>' ψ)+  -- 'return' a                 ≡ 'asL'' ('return' a)+  -- 'asL'' φ '>>=' 'asL'' . k     ≡ 'asL'' (φ '>>=' k)+  -- @+  asL' :: p a b -> L' a b++-- | We can convert a lazy fold to itself+instance AsL' L' where+  asL' = id++-- | We can convert from a lazy left folding to a strict left folding.+instance AsL' L where+  asL' (L k h z) = L' (\(Box r) -> k r) (\(Box r) a -> Box (h r a)) (Box z)++data Box a = Box a
+ src/Data/Fold/Class.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE Trustworthy #-}+module Data.Fold.Class+  ( Folding(..)+  , beneath+  ) where++import Control.Lens+import Control.Lens.Internal.Setter+import Data.Foldable+import Data.Profunctor.Unsafe++--+-- $setup+-- >>> import Data.Fold++newtype One a = One a++instance Foldable One where+  foldMap f (One a) = f a++class Choice p => Folding p where+  prefix :: Foldable t => t a -> p a b -> p a b+  prefix = prefixOf folded+  {-# INLINE prefix #-}++  prefix1 :: a -> p a b -> p a b+  prefix1 = prefix . One+  {-# INLINE prefix1 #-}++  prefixOf :: Fold s a -> s -> p a b -> p a b++  postfix :: Foldable t => p a b -> t a -> p a b+  postfix = postfixOf folded+  {-# INLINE postfix #-}++  postfix1 :: p a b -> a -> p a b+  postfix1 p = postfix p . One+  {-# INLINE postfix1 #-}++  postfixOf :: Fold s a -> p a b -> s -> p a b++  run :: Foldable t => t a -> p a b -> b+  run = runOf folded+  {-# INLINE run #-}++  run1 :: a -> p a b -> b+  run1 = run . One+  {-# INLINE run1 #-}++  runOf :: Fold s a -> s -> p a b -> b++-- enscanOf :: Traversal s t a b -> s -> p a b -> t++-- | Lift a 'Folding' into a 'Prism'.+--+-- This acts like a generalized notion of \"costrength\",+-- when applied to a 'Folding', causing it to return the+-- left-most value that fails to match the Prism, or the+-- result of accumulating rewrapped in the 'Prism' if+-- everything matches.+--+-- >>> run [Left 1, Left 2, Left 3] $ beneath _Left $ R id (+) 0+-- Left 6+--+-- >>> run [Left 1, Right 2, Right 3] $ beneath _Left $ R id (+) 0+-- Right 2+--+-- @+-- beneath :: Prism s t a b -> p a b -> p s t+-- beneath :: Iso s t a b   -> p a b -> p s t+-- @+beneath :: Profunctor p => Overloaded p Mutator s t a b -> p a b -> p s t+beneath l f = runMutator #. l (Mutator #. f)
+ src/Data/Fold/L'.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ExistentialQuantification #-}+module Data.Fold.L'+  ( L'(..)+  ) where++import Control.Applicative+import Control.Comonad+import Control.Lens+import Data.Foldable+import Data.Fold.Class+import Data.Functor.Extend+import Data.Functor.Bind+import Data.Monoid+import Data.Profunctor.Unsafe+import Unsafe.Coerce+import Prelude hiding (foldl)++-- | strict left folds+data L' a b = forall r. L' (r -> b) (r -> a -> r) r++-- | efficient 'prefix', leaky 'postfix'+instance Folding L' where+  run t (L' k h z)     = k $! foldl' h z t+  run1 t (L' k h z)    = k $! h z t+  runOf l s (L' k h z) = k $! foldlOf' l h z s+  prefix s             = run s . duplicate+  prefix1 a            = run1 a . duplicate+  prefixOf l s         = runOf l s . duplicate+  postfix t s          = extend (run s) t+  postfix1 t a         = extend (run1 a) t+  postfixOf l t s      = extend (runOf l s) t++instance Profunctor L' where+  dimap f g (L' k h z) = L' (g.k) (\r -> h r . f) z+  {-# INLINE dimap #-}+  rmap g (L' k h z) = L' (g.k) h z+  {-# INLINE rmap #-}+  lmap f (L' k h z) = L' k (\r -> h r . f) z+  {-# INLINE lmap #-}+  (#.) _ = unsafeCoerce+  {-# INLINE (#.) #-}+  x .# _ = unsafeCoerce x+  {-# INLINE (.#) #-}++instance Choice L' where+  left' (L' k h z) = L' (_Left %~ k) step (Left z) where+    step (Left x) (Left y) = Left (h x y)+    step (Right c) _ = Right c+    step _ (Right c) = Right c+  {-# INLINE left' #-}++  right' (L' k h z) = L' (_Right %~ k) step (Right z) where+    step (Right x) (Right y) = Right (h x y)+    step (Left c) _ = Left c+    step _ (Left c) = Left c+  {-# INLINE right' #-}++instance Functor (L' a) where+  fmap f (L' k h z) = L' (f.k) h z+  {-# INLINE fmap #-}++  (<$) b = \_ -> pure b+  {-# INLINE (<$) #-}++instance Comonad (L' a) where+  extract (L' k _ z) = k z+  {-# INLINE extract #-}++  duplicate (L' k h z) = L' (L' k h) h z+  {-# INLINE duplicate #-}++  extend f (L' k h z)  = L' (f . L' k h) h z+  {-# INLINE extend #-}++data Pair a b = Pair !a !b++instance Applicative (L' a) where+  pure b = L' (\() -> b) (\() _ -> ()) ()+  {-# INLINE pure #-}++  L' xf bxx xz <*> L' ya byy yz = L'+    (\(Pair x y) -> xf x $ ya y)+    (\(Pair x y) b -> Pair (bxx x b) (byy y b))+    (Pair xz yz)+  {-# INLINE (<*>) #-}++  (<*) m = \_ -> m+  {-# INLINE (<*) #-}++  _ *> m = m+  {-# INLINE (*>) #-}++instance Bind (L' a) where+  (>>-) = (>>=)+  {-# INLINE (>>-) #-}++instance Monad (L' a) where+  return = pure+  {-# INLINE return #-}+  m >>= f = L' (\xs a -> run xs (f a)) Snoc Nil <*> m+  {-# INLINE (>>=) #-}++instance Extend (L' a) where+  extended = extend+  {-# INLINE extended #-}++  duplicated = duplicate+  {-# INLINE duplicated #-}++instance Apply (L' a) where+  (<.>) = (<*>)+  {-# INLINE (<.>) #-}++  (<.) m = \_ -> m+  {-# INLINE (<.) #-}++  _ .> m = m+  {-# INLINE (.>) #-}++instance ComonadApply (L' a) where+  (<@>) = (<*>)+  {-# INLINE (<@>) #-}++  (<@) m = \_ -> m+  {-# INLINE (<@) #-}++  _ @> m = m+  {-# INLINE (@>) #-}++data SnocList a = Snoc (SnocList a) a | Nil++instance Foldable SnocList where+  foldl f z m0 = go m0 where+    go (Snoc xs x) = f (go xs) x+    go Nil = z+  {-# INLINE foldl #-}+  foldMap f (Snoc xs x) = foldMap f xs `mappend` f x+  foldMap _ Nil = mempty+  {-# INLINE foldMap #-}
+ src/Data/Fold/L.hs view
@@ -0,0 +1,152 @@+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ExistentialQuantification #-}+module Data.Fold.L+  ( L(..)+  ) where++import Control.Applicative+import Control.Comonad+import Control.Lens+import Data.Foldable+import Data.Fold.Class+import Data.Functor.Extend+import Data.Functor.Bind+import Data.Monoid+import Data.Profunctor.Unsafe+import Unsafe.Coerce+import Prelude hiding (foldl)++-- left folds+data L a b = forall r. L (r -> b) (r -> a -> r) r++-- | efficient 'prefix', leaky 'postfix'+instance Folding L where+  run t (L k h z)     = k (foldl h z t)+  run1 t (L k h z)    = k (h z t)+  runOf l s (L k h z) = k (foldlOf l h z s)+  prefix s            = run s . duplicate+  prefix1 a           = run1 a . duplicate+  prefixOf l s        = runOf l s . duplicate+  postfix t s         = extend (run s) t+  postfix1 t a        = extend (run1 a) t+  postfixOf l t s     = extend (runOf l s) t++{-+enscanl s (L k h z) = snd (mapAccumL h' z s) where+  h' r a = (r', k r') where r' = h r a++enscanlOf l s (L k h z) = snd (mapAccumLOf l h' z s) where+  h' r a = (r', k r') where r' = h r a+-}++instance Profunctor L where+  dimap f g (L k h z) = L (g.k) (\r -> h r . f) z+  {-# INLINE dimap #-}+  rmap g (L k h z) = L (g.k) h z+  {-# INLINE rmap #-}+  lmap f (L k h z) = L k (\r -> h r . f) z+  {-# INLINE lmap #-}+  (#.) _ = unsafeCoerce+  {-# INLINE (#.) #-}+  x .# _ = unsafeCoerce x+  {-# INLINE (.#) #-}++instance Choice L where+  left' (L k h z) = L (_Left %~ k) step (Left z) where+    step (Left x) (Left y) = Left (h x y)+    step (Right c) _ = Right c+    step _ (Right c) = Right c+  {-# INLINE left' #-}++  right' (L k h z) = L (_Right %~ k) step (Right z) where+    step (Right x) (Right y) = Right (h x y)+    step (Left c) _ = Left c+    step _ (Left c) = Left c+  {-# INLINE right' #-}++instance Functor (L a) where+  fmap f (L k h z) = L (f.k) h z+  {-# INLINE fmap #-}++  (<$) b = \_ -> pure b+  {-# INLINE (<$) #-}++instance Comonad (L a) where+  extract (L k _ z) = k z+  {-# INLINE extract #-}++  duplicate (L k h z) = L (L k h) h z+  {-# INLINE duplicate #-}++  extend f (L k h z)  = L (f . L k h) h z+  {-# INLINE extend #-}++data Pair a b = Pair !a !b++instance Applicative (L a) where+  pure b = L (\() -> b) (\() _ -> ()) ()+  {-# INLINE pure #-}++  L xf bxx xz <*> L ya byy yz = L+    (\(Pair x y) -> xf x $ ya y)+    (\(Pair x y) b -> Pair (bxx x b) (byy y b))+    (Pair xz yz)+  {-# INLINE (<*>) #-}++  (<*) m = \_ -> m+  {-# INLINE (<*) #-}++  _ *> m = m+  {-# INLINE (*>) #-}++instance Bind (L a) where+  (>>-) = (>>=)+  {-# INLINE (>>-) #-}++instance Monad (L a) where+  return = pure+  {-# INLINE return #-}+  m >>= f = L (\xs a -> run xs (f a)) Snoc Nil <*> m+  {-# INLINE (>>=) #-}++instance Extend (L a) where+  extended = extend+  {-# INLINE extended #-}++  duplicated = duplicate+  {-# INLINE duplicated #-}++instance Apply (L a) where+  (<.>) = (<*>)+  {-# INLINE (<.>) #-}++  (<.) m = \_ -> m+  {-# INLINE (<.) #-}++  _ .> m = m+  {-# INLINE (.>) #-}++instance ComonadApply (L a) where+  (<@>) = (<*>)+  {-# INLINE (<@>) #-}++  (<@) m = \_ -> m+  {-# INLINE (<@) #-}++  _ @> m = m+  {-# INLINE (@>) #-}++data SnocList a = Snoc (SnocList a) a | Nil++instance Foldable SnocList where+  foldl f z m0 = go m0 where+    go (Snoc xs x) = f (go xs) x+    go Nil = z+  {-# INLINE foldl #-}+  foldMap f (Snoc xs x) = foldMap f xs `mappend` f x+  foldMap _ Nil = mempty+  {-# INLINE foldMap #-}
+ src/Data/Fold/M.hs view
@@ -0,0 +1,179 @@+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ExistentialQuantification #-}+-- |+-- Unlike 'Data.Fold.L' and 'Data.Fold.R' this 'Comonad'+-- is based on a @(->) r@ 'Comonad' for a 'Monoid' @r@ rather than+-- than on the @'Store' r@ 'Comonad'.+module Data.Fold.M+  ( M(..)+  ) where++import Control.Applicative+import Control.Comonad+import Control.Lens+import Data.Fold.Class+import Data.Foldable hiding (sum, product)+import Data.Functor.Extend+import Data.Functor.Bind+import Data.Monoid+import Data.Profunctor.Unsafe+import Data.Proxy+import Data.Reflection+import Unsafe.Coerce+import Prelude hiding (sum, product, length)++-- | A 'foldMap' caught in amber.+data M a b = forall m. M (m -> b) (a -> m) (m -> m -> m) m++-- | efficient 'prefix', efficient 'postfix'+instance Folding M where+  run s (M k h m (z :: m)) = reify (m, z) $+    \ (_ :: Proxy s) -> k $ runN (foldMap (N #. h) s :: N m s)+  run1 a (M k h _ _) = k (h a)+  runOf l s (M k h m (z :: m)) = reify (m, z) $+    \ (_ :: Proxy s) -> k $ runN (foldMapOf l (N #. h) s :: N m s)+  prefix s (M k h m (z :: m)) = reify (m, z) $+    \ (_ :: Proxy s) -> case runN (foldMap (N #. h) s :: N m s) of+      x -> M (\y -> k (m x y)) h m z+  prefix1 a (M k h m z) = case h a of+     x -> M (\y -> k (m x y)) h m z+  prefixOf l s (M k h m (z :: m)) = reify (m, z) $+    \ (_ :: Proxy s) -> case runN (foldMapOf l (N #. h) s :: N m s) of+      x -> M (\y -> k (m x y)) h m z+  postfix (M k h m (z :: m)) s = reify (m, z) $+    \ (_ :: Proxy s) -> case runN (foldMap (N #. h) s :: N m s) of+      y -> M (\x -> k (m x y)) h m z+  postfix1 (M k h m z) a = case h a of+     y -> M (\x -> k (m x y)) h m z+  postfixOf l (M k h m (z :: m)) s = reify (m, z) $+    \ (_ :: Proxy s) -> case runN (foldMapOf l (N #. h) s :: N m s) of+      y -> M (\x -> k (m x y)) h m z++instance Profunctor M where+  dimap f g (M k h m e) = M (g.k) (h.f) m e+  {-# INLINE dimap #-}+  rmap g (M k h m e) = M (g.k) h m e+  {-# INLINE rmap #-}+  lmap f (M k h m e) = M k (h.f) m e+  {-# INLINE lmap #-}+  (#.) _ = unsafeCoerce+  {-# INLINE (#.) #-}+  x .# _ = unsafeCoerce x+  {-# INLINE (.#) #-}++instance Choice M where+  left' (M k h m z) = M (_Left %~ k) (_Left %~ h) step (Left z) where+    step (Left x) (Left y) = Left (m x y)+    step (Right c) _ = Right c+    step _ (Right c) = Right c+  {-# INLINE left' #-}++  right' (M k h m z) = M (_Right %~ k) (_Right %~ h) step (Right z) where+    step (Right x) (Right y) = Right (m x y)+    step (Left c) _ = Left c+    step _ (Left c) = Left c+  {-# INLINE right' #-}++instance Functor (M a) where+  fmap f (M k h m z) = M (f.k) h m z+  {-# INLINE fmap #-}++  (<$) b = \_ -> pure b+  {-# INLINE (<$) #-}++instance Comonad (M a) where+  extract (M k _ _ z) = k z+  {-# INLINE extract #-}++  duplicate (M k h m z) = M (\n -> M (k . m n) h m z) h m z+  {-# INLINE duplicate #-}++data Pair a b = Pair !a !b++instance Applicative (M a) where+  pure b = M (\() -> b) (\_ -> ()) (\() () -> ()) ()+  {-# INLINE pure #-}++  M xf bx xx xz <*> M ya by yy yz = M+    (\(Pair x y) -> xf x $ ya y)+    (\b -> Pair (bx b) (by b))+    (\(Pair x1 y1) (Pair x2 y2) -> Pair (xx x1 x2) (yy y1 y2))+    (Pair xz yz)+  {-# INLINE (<*>) #-}++  (<*) m = \_ -> m+  {-# INLINE (<*) #-}++  _ *> m = m+  {-# INLINE (*>) #-}++instance Bind (M a) where+  (>>-) = (>>=)+  {-# INLINE (>>-) #-}++instance Monad (M a) where+  return = pure+  {-# INLINE return #-}+  m >>= f = M (\xs a -> run xs (f a)) One Two Zero <*> m+  {-# INLINE (>>=) #-}++instance Extend (M a) where+  extended = extend+  {-# INLINE extended #-}++  duplicated = duplicate+  {-# INLINE duplicated #-}++instance Apply (M a) where+  (<.>) = (<*>)+  {-# INLINE (<.>) #-}++  (<.) m = \_ -> m+  {-# INLINE (<.) #-}++  _ .> m = m+  {-# INLINE (.>) #-}++instance ComonadApply (M a) where+  (<@>) = (<*>)+  {-# INLINE (<@>) #-}++  (<@) m = \_ -> m+  {-# INLINE (<@) #-}++  _ @> m = m+  {-# INLINE (@>) #-}++-- * Internals++-- | A reified 'Monoid'.+newtype N a s = N { runN :: a }++instance Reifies s (a -> a -> a, a) => Monoid (N a s) where+  mempty = N $ snd $ reflect (Proxy :: Proxy s)+  {-# INLINE mempty #-}+  mappend (N a) (N b) = N $ fst (reflect (Proxy :: Proxy s)) a b+  {-# INLINE mappend #-}++-- | The shape of a 'foldMap'+data Tree a = Zero | One a | Two (Tree a) (Tree a)++instance Functor Tree where+  fmap _ Zero = Zero+  fmap f (One a) = One (f a)+  fmap f (Two a b) = Two (fmap f a) (fmap f b)++instance Foldable Tree where+  foldMap _ Zero = mempty+  foldMap f (One a) = f a+  foldMap f (Two a b) = foldMap f a `mappend` foldMap f b++instance Traversable Tree where+  traverse _ Zero = pure Zero+  traverse f (One a) = One <$> f a+  traverse f (Two a b) = Two <$> traverse f a <*> traverse f b+
+ src/Data/Fold/R.hs view
@@ -0,0 +1,134 @@+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ExistentialQuantification #-}+module Data.Fold.R+  ( R(..)+  ) where++import Control.Applicative+import Control.Comonad+import Control.Lens+import Data.Foldable hiding (sum, product)+import Data.Fold.Class+import Data.Functor.Extend+import Data.Functor.Bind+import Data.Profunctor.Unsafe+-- import Data.Traversable+import Unsafe.Coerce+import Prelude hiding (foldr, sum, product, length)++-- right folds+data R a b = forall r. R (r -> b) (a -> r -> r) r++-- | leaky 'prefix', efficient 'postfix'+instance Folding R where+  run t (R k h z)     = k (foldr h z t)+  run1 t (R k h z)    = k (h t z)+  runOf l s (R k h z) = k (foldrOf l h z s)+  prefix s            = extend (run s)+  prefix1 a           = extend (run1 a)+  prefixOf l s        = extend (runOf l s)+  postfix t s         = run s (duplicate t)+  postfix1 t a        = run1 a (duplicate t)+  postfixOf l t s     = runOf l s (duplicate t)++instance Profunctor R where+  dimap f g (R k h z) = R (g.k) (h.f) z+  {-# INLINE dimap #-}+  rmap g (R k h z) = R (g.k) h z+  {-# INLINE rmap #-}+  lmap f (R k h z) = R k (h.f) z+  {-# INLINE lmap #-}+  (#.) _ = unsafeCoerce+  {-# INLINE (#.) #-}+  x .# _ = unsafeCoerce x+  {-# INLINE (.#) #-}++instance Choice R where+  left' (R k h z) = R (_Left %~ k) step (Left z) where+    step (Left x) (Left y) = Left (h x y)+    step (Right c) _ = Right c+    step _ (Right c) = Right c+  {-# INLINE left' #-}++  right' (R k h z) = R (_Right %~ k) step (Right z) where+    step (Right x) (Right y) = Right (h x y)+    step (Left c) _ = Left c+    step _ (Left c) = Left c+  {-# INLINE right' #-}++instance Functor (R a) where+  fmap f (R k h z) = R (f.k) h z+  {-# INLINE fmap #-}++  (<$) b = \_ -> pure b+  {-# INLINE (<$) #-}++instance Comonad (R a) where+  extract (R k _ z) = k z+  {-# INLINE extract #-}++  duplicate (R k h z) = R (R k h) h z+  {-# INLINE duplicate #-}++  extend f (R k h z)  = R (f . R k h) h z+  {-# INLINE extend #-}++data Pair a b = Pair !a !b++instance Bind (R a) where+  (>>-) = (>>=)+  {-# INLINE (>>-) #-}++instance Monad (R a) where+  return b = R (\() -> b) (\_ () -> ()) ()+  {-# INLINE return #-}++  m >>= f = R (\xs a -> run xs (f a)) (:) [] <*> m+  {-# INLINE (>>=) #-}++instance Applicative (R a) where+  pure b = R (\() -> b) (\_ () -> ()) ()+  {-# INLINE pure #-}++  R xf bxx xz <*> R ya byy yz = R+    (\(Pair x y) -> xf x $ ya y)+    (\b (Pair x y) -> Pair (bxx b x) (byy b y))+    (Pair xz yz)+  {-# INLINE (<*>) #-}++  (<*) m = \_ -> m+  {-# INLINE (<*) #-}++  _ *> m = m+  {-# INLINE (*>) #-}++instance Extend (R a) where+  extended = extend+  {-# INLINE extended #-}++  duplicated = duplicate+  {-# INLINE duplicated #-}++instance Apply (R a) where+  (<.>) = (<*>)+  {-# INLINE (<.>) #-}++  (<.) m = \_ -> m+  {-# INLINE (<.) #-}++  _ .> m = m+  {-# INLINE (.>) #-}++instance ComonadApply (R a) where+  (<@>) = (<*>)+  {-# INLINE (<@>) #-}++  (<@) m = \_ -> m+  {-# INLINE (<@) #-}++  _ @> m = m+  {-# INLINE (@>) #-}
+ tests/doctests.hsc view
@@ -0,0 +1,73 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ForeignFunctionInterface #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Main (doctests)+-- Copyright   :  (C) 2012-13 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  provisional+-- Portability :  portable+--+-- This module provides doctests for a project based on the actual versions+-- of the packages it was built with. It requires a corresponding Setup.lhs+-- to be added to the project+-----------------------------------------------------------------------------+module Main where++import Build_doctests (deps)+import Control.Applicative+import Control.Monad+import Data.List+import System.Directory+import System.FilePath+import Test.DocTest++##if defined(mingw32_HOST_OS)+##if defined(i386_HOST_ARCH)+##define USE_CP+import Control.Applicative+import Control.Exception+import Foreign.C.Types+foreign import stdcall "windows.h SetConsoleCP" c_SetConsoleCP :: CUInt -> IO Bool+foreign import stdcall "windows.h GetConsoleCP" c_GetConsoleCP :: IO CUInt+##elif defined(x86_64_HOST_ARCH)+##define USE_CP+import Control.Applicative+import Control.Exception+import Foreign.C.Types+foreign import ccall "windows.h SetConsoleCP" c_SetConsoleCP :: CUInt -> IO Bool+foreign import ccall "windows.h GetConsoleCP" c_GetConsoleCP :: IO CUInt+##endif+##endif++-- | Run in a modified codepage where we can print UTF-8 values on Windows.+withUnicode :: IO a -> IO a+##ifdef USE_CP+withUnicode m = do+  cp <- c_GetConsoleCP+  (c_SetConsoleCP 65001 >> m) `finally` c_SetConsoleCP cp+##else+withUnicode m = m+##endif++main :: IO ()+main = withUnicode $ getSources >>= \sources -> doctest $+    "-isrc"+  : "-idist/build/autogen"+  : "-optP-include"+  : "-optPdist/build/autogen/cabal_macros.h"+  : "-hide-all-packages"+  : map ("-package="++) deps ++ sources++getSources :: IO [FilePath]+getSources = filter (isSuffixOf ".hs") <$> go "src"+  where+    go dir = do+      (dirs, files) <- getFilesAndDirectories dir+      (files ++) . concat <$> mapM go dirs++getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath])+getFilesAndDirectories dir = do+  c <- map (dir </>) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir+  (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c
+ tests/hlint.hs view
@@ -0,0 +1,23 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Main (hlint)+-- Copyright   :  (C) 2013 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  provisional+-- Portability :  portable+--+-- This module runs HLint on the lens source tree.+-----------------------------------------------------------------------------+module Main where++import Control.Monad+import Language.Haskell.HLint+import System.Environment+import System.Exit++main :: IO ()+main = do+    args <- getArgs+    hints <- hlint $ ["src", "--cpp-define=HLINT"] ++ args+    unless (null hints) exitFailure