diff --git a/.ghci b/.ghci new file mode 100644 --- /dev/null +++ b/.ghci @@ -0,0 +1,1 @@ +:set -isrc -idist/build/autogen -optP-include -optPdist/build/autogen/cabal_macros.h diff --git a/.gitignore b/.gitignore new file mode 100644 --- /dev/null +++ b/.gitignore @@ -0,0 +1,16 @@ +dist +docs +wiki +TAGS +tags +wip +stats +.DS_Store +.*.swp +.*.swo +*.o +*.hi +*~ +*# +.cabal-sandbox +cabal.sandbox.config diff --git a/.travis.yml b/.travis.yml new file mode 100644 --- /dev/null +++ b/.travis.yml @@ -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}" diff --git a/.vim.custom b/.vim.custom new file mode 100644 --- /dev/null +++ b/.vim.custom @@ -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 :exec ":!hasktags -x -c --ignore src" + +" 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" diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown new file mode 100644 --- /dev/null +++ b/CHANGELOG.markdown @@ -0,0 +1,3 @@ +0.1 +--- +* Repository Initialized diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.markdown b/README.markdown new file mode 100644 --- /dev/null +++ b/README.markdown @@ -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 diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -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} diff --git a/folds.cabal b/folds.cabal new file mode 100644 --- /dev/null +++ b/folds.cabal @@ -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 +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 + . + This package can be seen as what happens if you chase Max Rabkin's to its logical conclusion. + . + More information on this approach can be found in the and posts by Conal Elliott, as well as in Gabriel Gonzales' + +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 diff --git a/src/Data/Fold.hs b/src/Data/Fold.hs new file mode 100644 --- /dev/null +++ b/src/Data/Fold.hs @@ -0,0 +1,155 @@ +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2009-2013 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- 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 diff --git a/src/Data/Fold/Class.hs b/src/Data/Fold/Class.hs new file mode 100644 --- /dev/null +++ b/src/Data/Fold/Class.hs @@ -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) diff --git a/src/Data/Fold/L'.hs b/src/Data/Fold/L'.hs new file mode 100644 --- /dev/null +++ b/src/Data/Fold/L'.hs @@ -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 #-} diff --git a/src/Data/Fold/L.hs b/src/Data/Fold/L.hs new file mode 100644 --- /dev/null +++ b/src/Data/Fold/L.hs @@ -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 #-} diff --git a/src/Data/Fold/M.hs b/src/Data/Fold/M.hs new file mode 100644 --- /dev/null +++ b/src/Data/Fold/M.hs @@ -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 + diff --git a/src/Data/Fold/R.hs b/src/Data/Fold/R.hs new file mode 100644 --- /dev/null +++ b/src/Data/Fold/R.hs @@ -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 (@>) #-} diff --git a/tests/doctests.hsc b/tests/doctests.hsc new file mode 100644 --- /dev/null +++ b/tests/doctests.hsc @@ -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 +-- 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 diff --git a/tests/hlint.hs b/tests/hlint.hs new file mode 100644 --- /dev/null +++ b/tests/hlint.hs @@ -0,0 +1,23 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Main (hlint) +-- Copyright : (C) 2013 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Edward Kmett +-- 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