functor-combo 0.1.1 → 0.2.1
raw patch · 5 files changed
+414/−46 lines, 5 filesdep ~TypeCompose
Dependency ranges changed: TypeCompose
Files
- functor-combo.cabal +4/−2
- src/FunctorCombo/Functor.hs +34/−42
- src/FunctorCombo/Pair.hs +164/−0
- src/FunctorCombo/ParScan.hs +210/−0
- src/FunctorCombo/StrictMemo.hs +2/−2
functor-combo.cabal view
@@ -1,5 +1,5 @@ Name: functor-combo-Version: 0.1.1+Version: 0.2.1 Cabal-Version: >= 1.2 Synopsis: Functor combinators with tries & zippers Category: Data@@ -27,10 +27,12 @@ Library hs-Source-Dirs: src Extensions:- Build-Depends: base<5, TypeCompose >= 0.8, containers, data-inttrie, lub+ Build-Depends: base<5, TypeCompose >= 0.9.4, containers, data-inttrie, lub Exposed-Modules: FunctorCombo.Strict FunctorCombo.Functor+ FunctorCombo.ParScan+ FunctorCombo.Pair FunctorCombo.LubF FunctorCombo.Derivative FunctorCombo.Holey
src/FunctorCombo/Functor.hs view
@@ -1,4 +1,7 @@-{-# LANGUAGE TypeOperators, EmptyDataDecls, StandaloneDeriving, DeriveFunctor #-}+{-# LANGUAGE TypeOperators, EmptyDataDecls, StandaloneDeriving #-}+{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}+{-# LANGUAGE TypeFamilies #-}+ {-# OPTIONS_GHC -Wall #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------@@ -15,22 +18,23 @@ module FunctorCombo.Functor (- Const(..),Void,voidF,Unit,unit,Id(..),unId,inId,inId2,(:+:)(..),eitherF- , (:*:)(..),fstF,sndF,(:.)(..),unO,inO,inO2,(~>)+ Const(..),Void,voidF,Unit,unit,Id(..),unId,inId,inId2+ , (:+:)(..),eitherF+ , (:*:)(..),asProd,asPair,fstF,sndF+ , (:.)(..),unO,inO,inO2,(~>),(<~) , Lift(..), (:*:!)(..), (:+:!)(..), eitherF' , pairF, unPairF, inProd, inProd2- , Pair(..)+ , EncodeF(..) ) where -import Data.Monoid(Monoid(..))+import Data.Monoid (Monoid(..)) import Data.Foldable (Foldable(..)) import Data.Traversable (Traversable(..)) import Control.Applicative (Applicative(..),Const(..),liftA2,(<$>)) import Control.Monad (join) -import Control.Compose (Id(..),unId,inId,inId2,(:.)(..),unO,inO,inO2,(~>))-+import Control.Compose (Id(..),unId,inId,inId2,(:.)(..),unO,inO,inO2,(~>),(<~)) -- infixl 9 :. infixl 7 :*:@@ -62,6 +66,12 @@ -- | Product on unary type constructors data (f :*: g) a = f a :*: g a deriving (Show,Functor) +asPair :: (f :*: g) a -> (f a, g a)+asPair (fa :*: ga) = (fa,ga)++asProd :: (f a, g a) -> (f :*: g) a+asProd (fa,ga) = (fa :*: ga)+ -- | Like 'fst' fstF :: (f :*: g) a -> f a fstF (fa :*: _) = fa@@ -102,14 +112,17 @@ -- TODO: replace explicit definition with deriving, when the compiler fix -- has been around for a while. -instance Foldable (Const b) where- -- fold (Const _) = mempty- fold = const mempty+deriving instance Foldable (Const b)+deriving instance Traversable (Const b) -instance Traversable (Const b) where- -- sequenceA (Const b) = pure (Const b)- traverse _ (Const b) = pure (Const b)+-- instance Foldable (Const b) where+-- -- fold (Const _) = mempty+-- foldMap _ (Const _) = mempty +-- instance Traversable (Const b) where+-- -- sequenceA (Const b) = pure (Const b)+-- traverse _ (Const b) = pure (Const b)+ -- instance Functor Id where -- fmap h (Id a) = Id (h a) @@ -219,12 +232,12 @@ -- Could also define curryF, uncurryF inProd :: ((f a , g a) -> (h b , i b)) -> ((f :*: g) a -> (h :*: i) b)-inProd = unPairF ~> pairF+inProd = pairF <~ unPairF inProd2 :: ((f a , g a) -> (h b , i b) -> (j c , k c)) -> ((f :*: g) a -> (h :*: i) b -> (j :*: k) c)-inProd2 = unPairF ~> inProd+inProd2 = inProd <~ unPairF {--------------------------------------------------------------------@@ -267,33 +280,12 @@ eitherF' _ q (InR' ga) = q ga {--------------------------------------------------------------------- Pair functor. Just a convenience. Pair =~ Id :*: Id+ Encoding via standard functor combinators --------------------------------------------------------------------} --- | Uniform pairs-data Pair a = a :# a---- Interpreting Pair a as Bool -> a or as Vec2 a, the instances follow--- inevitably from the principle of type class morphisms.--instance Functor Pair where- fmap f (a :# b) = (f a :# f b)--instance Applicative Pair where- pure a = (a :# a)- (f :# g) <*> (a :# b) = (f a :# g b)--instance Monad Pair where- return = pure- (a :# b) >>= f = (c :# d)- where- (c :# _) = f a- (_ :# d) = f b--instance Foldable Pair where- foldMap f (a :# b) = f a `mappend` f b- -- fold (a :# b) = a `mappend` b+class EncodeF f where+ type Enc f :: * -> *+ encode :: f a -> Enc f a+ decode :: Enc f a -> f a -instance Traversable Pair where- traverse h (fa :# fb) = liftA2 (:#) (h fa) (h fb)- -- sequenceA (fa :# fb) = liftA2 (:#) fa fb+-- TODO: Very similar to the Regular class. Can they be reconciled?
+ src/FunctorCombo/Pair.hs view
@@ -0,0 +1,164 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE TypeOperators, TypeFamilies #-}+{-# OPTIONS_GHC -Wall #-}++-- {-# OPTIONS_GHC -fno-warn-unused-imports #-} -- TEMP+-- {-# OPTIONS_GHC -fno-warn-unused-binds #-} -- TEMP++----------------------------------------------------------------------+-- |+-- Module : FunctorCombo.Pair+-- Copyright : (c) 2012 Tabula, Inc.+-- +-- Maintainer : conal@tabula.com+-- Stability : experimental+-- +-- Pair functor+----------------------------------------------------------------------++module FunctorCombo.Pair+ ( Pair(..)+ , fstP, sndP, swapP, fromP, toP, inP+ , firstP, secondP, zipA, unzipA, inZipA+ , curryP, uncurryP+ , preScanP, sufScanP+ ) where++-- TODO: consider using standard names like fst, snd & curry.++import Data.Monoid (Monoid(..))+import Data.Functor ((<$>))+import Data.Foldable (Foldable(..))+import Data.Traversable (Traversable(..))+import Control.Applicative (Applicative(..),liftA2)++import FunctorCombo.Functor+import FunctorCombo.ParScan++{--------------------------------------------------------------------+ Pair functor. Just a convenience. Pair =~ Id :*: Id+--------------------------------------------------------------------}++infixl 1 :#+-- | Uniform pairs+data Pair a = a :# a deriving (Functor,Eq,Show)++-- Interpreting Pair a as Bool -> a or as Vec2 a, the instances follow+-- inevitably from the principle of type class morphisms.++-- instance Functor Pair where+-- fmap f (a :# b) = (f a :# f b)++-- The derived foldMap inserts a mempty (in GHC 7.0.4).+instance Foldable Pair where+ foldMap f (a :# b) = f a `mappend` f b++instance Applicative Pair where+ pure a = a :# a+ (f :# g) <*> (a :# b) = (f a :# g b)++instance Monad Pair where+ return = pure+ m >>= f = joinP (f <$> m)++joinP :: Pair (Pair a) -> Pair a+joinP ((a :# _) :# (_ :# d)) = a :# d++-- so+--+-- (a :# b) >>= f = (c :# d)+-- where+-- (c :# _) = f a+-- (_ :# d) = f b++instance Traversable Pair where+ traverse h (fa :# fb) = liftA2 (:#) (h fa) (h fb)+ -- sequenceA (fa :# fb) = liftA2 (:#) fa fb++instance EncodeF Pair where+ type Enc Pair = Id :*: Id+ encode (a :# b) = Id a :*: Id b+ decode (Id a :*: Id b) = a :# b++fstP, sndP :: Pair a -> a+fstP (a :# _) = a+sndP (_ :# b) = b++swapP :: Unop (Pair a)+swapP (a :# b) = b :# a++toP :: (a,a) -> Pair a+toP (a,b) = a :# b++fromP :: Pair a -> (a,a)+fromP (a :# b) = (a,b)++inP :: Unop (a,a) -> Unop (Pair a)+inP f = toP . f . fromP++firstP, secondP :: Unop a -> Unop (Pair a)+firstP f = ((f :# id) <*>)+secondP g = ((id :# g) <*>)++-- Or use 'ap', e.g., ap (f :# id)++-- firstP f (a :# b) = (f a :# b)+-- secondP g (a :# b) = ( a :# g b)++zipA :: Applicative f => Pair (f a) -> f (Pair a)+zipA (u :# v) = liftA2 (:#) u v++unzipA :: Functor f => f (Pair a) -> Pair (f a)+unzipA t = fmap fstP t :# fmap sndP t++inZipA :: Applicative f => Unop (f (Pair a)) -> Unop (Pair (f a))+inZipA f = unzipA . f . zipA++-- TODO: Eliminate inZipA in favor of inDist++curryP :: (Pair a -> b) -> (a -> a -> b)+curryP g = curry (g . toP)++uncurryP :: (a -> a -> b) -> (Pair a -> b)+uncurryP f = uncurry f . fromP++preScanP :: (Functor f, Monoid o) => Pair (f o, o) -> (Pair (f o), o)+preScanP (us :# vs) = ((u :# v), vTot)+ where+ (u,uTot) = us+ (v,vTot) = preScanTweak (uTot `mappend`) vs++sufScanP :: (Functor f, Monoid o) => Pair (o, f o) -> (o, Pair (f o))+sufScanP (us :# vs) = (uTot, (u :# v))+ where+ (vTot,v) = vs+ (uTot,u) = sufScanTweak (`mappend` vTot) us+++{--------------------------------------------------------------------+ A simple example: pairs+--------------------------------------------------------------------}++-- To get a first sense of generalized scans, let's use see how to scan over a+-- pair functor.++-- instance Scan Pair where+-- prefixScan (a :# b) = (mempty :# a, a `mappend` b)+-- suffixScan (a :# b) = (a `mappend` b, b :# mempty)++-- We don't really have to figure out how to define scans for every functor+-- separately. We can instead look at how functors are are composed out of their+-- essential building blocks.++instance Scan Pair where+ prefixScan = prefixScanEnc+ suffixScan = suffixScanEnc++{--------------------------------------------------------------------+ Misc+--------------------------------------------------------------------}++-- Put somewhere standard.++-- | Unary transformation+type Unop a = a -> a
+ src/FunctorCombo/ParScan.hs view
@@ -0,0 +1,210 @@+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# OPTIONS_GHC -Wall #-}++{-# OPTIONS_GHC -fno-warn-unused-imports #-} -- TEMP+-- {-# OPTIONS_GHC -fno-warn-unused-binds #-} -- TEMP++----------------------------------------------------------------------+-- |+-- Module : FunctorCombo.ParScan+-- Copyright : (c) 2012 Tabula, Inc.+-- +-- Maintainer : conal@tabula.com+-- Stability : experimental+-- +-- Composable parallel scanning from+-- <http://conal.net/blog/posts/composable-parallel-scanning/>+----------------------------------------------------------------------++module FunctorCombo.ParScan+ ( Scan(..), PreScanO, SufScanO+ , prefixScanEnc, suffixScanEnc+ , preScanTweak, sufScanTweak+ , prefixSums, suffixSums+ ) where++-- TODO: explicit exports++import Prelude hiding (zip,unzip)++import Data.Monoid (Monoid(..),Sum(..))+import Control.Applicative (Applicative(..),liftA2,(<$>))+import Control.Arrow ((&&&),(***),first,second)+import Data.Foldable+import Data.Traversable++import FunctorCombo.Functor++type PreScanO f a = (f a, a)+type SufScanO f a = (a, f a)++-- | Parallel scans. `prefixScan` accumulates moving left-to-right, while+-- `suffixScan` accumulates moving right-to-left.+class Scan f where+ prefixScan :: Monoid m => f m -> PreScanO f m+ suffixScan :: Monoid m => f m -> SufScanO f m++{--------------------------------------------------------------------+ Functor combinators+--------------------------------------------------------------------}++-- The constant functor is easiest. There are no values to accumulate, so the+-- final result (fold) is `mempty`.++instance Scan (Const x) where+ prefixScan (Const x) = (Const x, mempty)+ suffixScan (Const x) = (mempty, Const x)+++instance Scan Id where+ prefixScan (Id m) = (Id mempty, m)+ suffixScan (Id m) = (m, Id mempty)++instance (Scan f, Scan g) => Scan (f :+: g) where+ prefixScan (InL fa) = first InL (prefixScan fa)+ prefixScan (InR ga) = first InR (prefixScan ga)+ + suffixScan (InL fa) = second InL (suffixScan fa)+ suffixScan (InR ga) = second InR (suffixScan ga)++-- These definitions correspond to simple "commutative diagram" properties,+-- e.g.,++-- prefixScan . InL == second InL . prefixScan++-- Product scannning is a little trickier. Scan each of the two parts+-- separately, and then combine the final (`fold`) part of one result with each+-- of the non-final elements of the other.++preScanTweak :: Functor f => (a -> b) -> PreScanO f a -> PreScanO f b+preScanTweak h = fmap h *** h++sufScanTweak :: Functor f => (a -> b) -> SufScanO f a -> SufScanO f b+sufScanTweak h = h *** fmap h++-- preScanTweak h (fa,a) = (h <$> fa, h a)+-- sufScanTweak h (a,fa) = (h a, h <$> fa)++-- TODO: Maybe make PreScanO and SufScanO into data types, and replace+-- preScanTweak and sufScanTweak with fmap.+--+-- data PreScanO' f a = f a :> a deriving Functor+-- data SufScanO' f a = a :< f a deriving Functor++instance (Scan f, Scan g, Functor f, Functor g) => Scan (f :*: g) where++-- prefixScan (fa :*: ga) = (fa' :*: ga', ag)+-- where (fa',af) = prefixScan fa+-- (ga',ag) = preScanTweak (af `mappend`) (prefixScan ga)++ prefixScan = first asProd+ . assocL+ . second tweak+ . assocR+ . (prefixScan *** prefixScan)+ . asPair+ where+ tweak (af,w) = preScanTweak (af `mappend`) w++-- suffixScan (fa :*: ga) = (af, fa' :*: ga')+-- where (ag,ga') = suffixScan ga+-- (af,fa') = sufScanTweak (`mappend` ag) (suffixScan fa)++ suffixScan = second asProd+ . assocR+ . first tweak+ . assocL+ . (suffixScan *** suffixScan)+ . asPair+ where+ tweak (w,ag) = sufScanTweak (`mappend` ag) w+++-- Note that Functor f above is for suffixScan, and Functor g for prefixScan.+-- If we split into two classes, we'd get a bit more generality.++-- Finally, composition is the trickiest. The target signatures:+-- +-- prefixScan :: Monoid m => (g :. f) m -> ((g :. f) m, m)+-- suffixScan :: Monoid m => (g :. f) m -> (m, (g :. f) m)++-- To find the prefix and suffix scan definitions, fiddle with types beginning+-- at the domain type for `prefixScan` or `suffixScan` and arriving at the range+-- type.++-- Some helpers:++zip :: Applicative g => (g a, g b) -> g (a,b)+zip = uncurry (liftA2 (,))++unzip :: Functor g => g (a,b) -> (g a, g b)+unzip = fmap fst &&& fmap snd++assocL :: (a,(b,c)) -> ((a,b),c)+assocL (a,(b,c)) = ((a,b),c)++assocR :: ((a,b),c) -> (a,(b,c))+assocR ((a,b),c) = (a,(b,c))++adjustL :: (Functor f, Monoid m) => (f m, m) -> f m+adjustL (ms, m) = (m `mappend`) <$> ms++adjustR :: (Functor f, Monoid m) => (m, f m) -> f m+adjustR (m, ms) = (`mappend` m) <$> ms++-- TODO: Reconsider names 'adjustL' and 'adjustR'++-- First `prefixScan`:++-- < gofm :: (g :. f) m+-- < unO '' :: g (f m)+-- < fmap prefixScan '' :: g (f m, m)+-- < unzip '' :: (g (f m), g m)+-- < second prefixScan '' :: (g (f m), (g m, m))+-- < assocL '' :: ((g (f m), g m), m)+-- < first zip '' :: (g (f m, m), m)+-- < first (fmap adjustL) '' :: (g (f m), m)+-- < first O '' :: ((g :. f) m, m)++-- Then `suffixScan`:++-- < gofm :: (g :. f) m+-- < unO '' :: g (f m)+-- < fmap suffixScan '' :: g (m, f m)+-- < unzip '' :: (g m, g (f m))+-- < first suffixScan '' :: ((m, g m), g (f m))+-- < assocR '' :: (m, (g m, g (f m)))+-- < second zip '' :: (m, (g (m, f m)))+-- < second (fmap adjustR) '' :: (m, (g (f m)))+-- < second O '' :: (m, ((g :. f) m))++-- Putting together the pieces and simplifying just a bit leads to the method+-- definitions:++instance (Scan g, Scan f, Functor f, Applicative g) => Scan (g :. f) where+ prefixScan = first (O . fmap adjustL . zip)+ . assocL+ . second prefixScan+ . unzip+ . fmap prefixScan+ . unO+ + suffixScan = second (O . fmap adjustR . zip)+ . assocR+ . first suffixScan+ . unzip+ . fmap suffixScan+ . unO++prefixScanEnc :: (EncodeF f, Scan (Enc f), Monoid m) => f m -> PreScanO f m+prefixScanEnc = first decode . prefixScan . encode++suffixScanEnc :: (EncodeF f, Scan (Enc f), Monoid m) => f m -> SufScanO f m+suffixScanEnc = second decode . suffixScan . encode++prefixSums :: (Functor f, Scan f, Num a) => f a -> PreScanO f a+prefixSums = preScanTweak getSum . prefixScan . fmap Sum++suffixSums :: (Functor f, Scan f, Num a) => f a -> SufScanO f a+suffixSums = sufScanTweak getSum . suffixScan . fmap Sum
src/FunctorCombo/StrictMemo.hs view
@@ -34,6 +34,7 @@ -- import FunctorCombo.Strict import FunctorCombo.Functor+import FunctorCombo.Pair import FunctorCombo.Regular @@ -120,7 +121,7 @@ instance HasTrie () where type Trie () = Id trie f = Id (f ())- untrie (Id v) = const v+ untrie (Id v) = \ () -> v -- enumerate (Id a) = [((),a)] instance (HasTrie a, HasTrie b) => HasTrie (Either a b) where@@ -136,7 +137,6 @@ [] `weave` as = as as `weave` [] = as (a:as) `weave` bs = a : (bs `weave` as)- instance (HF(a), HasTrie b) => HasTrie (a , b) where type Trie (a , b) = Trie a :. Trie b