TypeCompose 0.1 → 0.3
raw patch · 15 files changed
+1376/−236 lines, 15 filesdep −mtlsetup-changed
Dependencies removed: mtl
Files
- CHANGES +52/−10
- Makefile +0/−4
- README +11/−9
- Setup.lhs +2/−2
- TypeCompose.cabal +12/−10
- src/Control/Compose.hs +595/−69
- src/Control/DataDriven.hs +0/−96
- src/Control/Instances.hs +28/−36
- src/Data/Bijection.hs +78/−0
- src/Data/CxMonoid.hs +42/−0
- src/Data/Lambda.hs +140/−0
- src/Data/Pair.hs +187/−0
- src/Data/Partial.hs +113/−0
- src/Data/RefMonad.hs +48/−0
- src/Data/Title.hs +68/−0
CHANGES view
@@ -1,10 +1,52 @@-Version 0.1:-* Renamed "Compose/Comp/unComp" to "O/O/unO".-* Renamed "onComp" to "inO"-* Renamed "mapSrc" to "mapCur", and renamed type parameter "src" to "cur",- to avoid confusion with "Source" in Phooey's use of DataDriven.-* Swapped argument order to dd in DataDriven.-* Renamed "Updater" to "Action"-* Changed the Monoid (IO a) instance in Control.Instances to use "liftA2- mappend" instead of "(*>)".-* Added unFlip, inFlip, inFlip2+% TypeCompose changes++== Version 0.3 ==++* Simplified Applicative instance for g :. f+* Renamed type constructors "O" and "App" to "(:.)" and "(:$)". Also+ include old names for compatibility.+* Replaced the 6.6-compatible OPTIONS pragmas with LANGUAGE+* Pair & Copair for Const+* Changed functional dependency for RefMonad++## Version 0.2 ##+++ More comments++ Added [Data.Partial](src/Data/Partial.hs): partial values.++ [Data.Bijection](src/Data/Bijection.hs): bijective arrows. Used in+ [Control.Compose] for composing representation transformations.++ Using `LANGUAGE` instead of `OPTIONS` pragmas++ [Data.Pair](src/Data/Pair.hs) & [Data.Fun](src/Data/Fun.hs). Classes of+ pair-like and function-like types.++ [Data.RefMonad](src/Data/RefMonad.hs)++ Renamed StaticArrow/Static to OO/OO++ Now in{O,Flip,Prod,Arrw,Const}{,2,3} (i.e., `inO2` etc)++ `Sink` type alias and `Monoid` instance.++ `Monoid_f` and `O` instance.++ `Arrw` type class with `Functor` & `Cofunctor` instances.++ [Data.Title](src/Data/Title.hs): a titling class for type constructors.+ Doesn't really belong here.++ Eliminated dependency on "mtl" package by removing a standard+ applicative instance for `ReaderT`.++ [Data.CxMonoid](src/Data/CxMonoid.hs): context-dependent monoid++ Type constructors `:*:`, `::*::`, & `:~>:`++ `FunA` and `FunAble`, for convenient `Arrow` definitions. See also `FunD` &+ `FunDble` in [DeepArrow].++## Version 0.1 ##+++ Renamed "Compose/Comp/unComp" to "O/O/unO".++ Renamed "onComp" to "inO"++ Renamed "mapSrc" to "mapCur", and renamed type parameter "src" to "cur",+ to avoid confusion with "Source" in Phooey's use of DataDriven.++ Swapped argument order to dd in DataDriven.++ Renamed "Updater" to "Action"++ Changed the Monoid (IO a) instance in Control.Instances to use "liftA2+ mappend" instead of "(*>)".++ Added unFlip, inFlip, inFlip2+++[TypeCompose]: http://haskell.org/haskellwiki/TypeCompose+[DeepArrow]: http://haskell.org/haskellwiki/DeepArrow++[Control.Compose]: src/Control.Compose.hs
Makefile view
@@ -1,7 +1,3 @@ # For special configuration, especially for docs. Otherwise see README. -haddock-interfaces=\- http://haskell.org/ghc/docs/latest/html/libraries/base,c:/ghc/ghc-6.6/doc/html/libraries/base/base.haddock \- http://haskell.org/ghc/docs/latest/html/libraries/mtl,c:/ghc/ghc-6.6/doc/html/libraries/mtl/mtl.haddock \- include ../my-cabal-make.inc
README view
@@ -1,15 +1,17 @@-TypeCompose provides some classes & instances for forms of type-composition. It also includes a very simple implementation of data-driven-computation. See the description and link to documentation:+% TypeCompose - http://haskell.org/haskellwiki/TypeCompose+TypeCompose provides some classes & instances for forms of type+composition, as well as some modules that haven't found another home. The+[wiki page] contains a description and links to documentation. -Please share any comments & suggestions on the discussion (talk) page-there.+Please share any comments & suggestions on the [talk page] there. You can configure, build, and install all in the usual way with Cabal commands. - runhaskell Setup.lhs configure- runhaskell Setup.lhs build- runhaskell Setup.lhs install+ runhaskell Setup.lhs configure+ runhaskell Setup.lhs build+ runhaskell Setup.lhs install++[wiki page]: http://haskell.org/haskellwiki/TypeCompose+[talk page]: http://haskell.org/haskellwiki/Talk:TypeCompose
Setup.lhs view
@@ -1,3 +1,3 @@-#!/usr/bin/env runhaskell -> import Distribution.Simple +#!/usr/bin/env runhaskell+> import Distribution.Simple > main = defaultMain
TypeCompose.cabal view
@@ -1,17 +1,12 @@ Name: TypeCompose-Version: 0.1+Version: 0.3 Synopsis: Type composition classes & instances Category: Composition, Control Description: TypeCompose provides some classes & instances for forms of type- composition. Bonus: a very simple implementation of data-driven- computation.- .- See also- .- * The project wiki page: <http://haskell.org/haskellwiki/TypeCompose>+ composition, as well as some modules who haven't yet found a home. .- * Use of TypeCompose in Phooey: <http://haskell.org/haskellwiki/Phooey>+ Please see the project wiki page: <http://haskell.org/haskellwiki/TypeCompose> . The module documentation pages have links to colorized source code and to wiki pages where you can read and contribute /user comments/. Enjoy!@@ -20,15 +15,22 @@ Author: Conal Elliott Maintainer: conal@conal.net Homepage: http://haskell.org/haskellwiki/TypeCompose+Package-Url: http://darcs.haskell.org/packages/TypeCompose Copyright: (c) 2007 by Conal Elliott License: BSD3 Stability: provisional Hs-Source-Dirs: src Extensions: -Build-Depends: base, mtl+Build-Depends: base Exposed-Modules: + Data.Bijection+ Data.CxMonoid+ Data.RefMonad+ Data.Pair+ Data.Lambda+ Data.Title+ Data.Partial Control.Instances Control.Compose- Control.DataDriven Extra-Source-Files: ghc-options: -O -Wall
src/Control/Compose.hs view
@@ -1,85 +1,257 @@-{-# OPTIONS -fglasgow-exts #-}+{-# LANGUAGE Rank2Types, FlexibleInstances, MultiParamTypeClasses+ , FlexibleContexts, UndecidableInstances, TypeSynonymInstances+ , TypeOperators, GeneralizedNewtypeDeriving, StandaloneDeriving+ #-}+-- For ghc 6.6 compatibility+-- {-# OPTIONS -fglasgow-exts -fallow-undecidable-instances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-}+ ---------------------------------------------------------------------- -- | -- Module : Control.Compose -- Copyright : (c) Conal Elliott 2007--- License : LGPL+-- License : BSD3 -- -- Maintainer : conal@conal.net -- Stability : experimental--- Portability : portable+-- Portability : see LANGUAGE pragma -- -- Various type constructor compositions and instances for them.--- References:--- [1] \"Applicative Programming with Effects\"+-- Some come from +-- \"Applicative Programming with Effects\" -- <http://www.soi.city.ac.uk/~ross/papers/Applicative.html> ---------------------------------------------------------------------- module Control.Compose- ( Cofunctor(..)- , O(..), inO- , StaticArrow(..)- , Flip(..), inFlip, inFlip2- , ArrowAp(..)- , App(..)+ ( Unop, Binop+ -- * Contravariant functors+ , Cofunctor(..), bicomap+ -- * Unary\/unary composition+ , (:.)(..), O, biO, convO, coconvO, inO, inO2, inO3+ , fmapFF, fmapCC, cofmapFC, cofmapCF+ -- * Type composition+ -- ** Unary\/binary+ , OO(..)+-- -- * Binary\/unary+-- , ArrowAp(..),+ -- ** (->)\/unary+ , FunA(..), inFunA, inFunA2, FunAble(..)+ -- * Monoid constructors+ , Monoid_f(..)+ -- * Flip a binary constructor's type arguments+ , Flip(..), biFlip, inFlip, inFlip2, inFlip3, OI, ToOI(..)+ -- * Type application+ , (:$)(..), App, biApp, inApp, inApp2+ -- * Identity+ , Id(..), biId, inId+ -- * Constructor pairing+ -- ** Unary+ , (:*:)(..), biProd, convProd, (***#), ($*), inProd, inProd2, inProd3+ -- * Binary+ , (::*::)(..), inProdd, inProdd2+ -- * Arrow between /two/ constructor applications+ , Arrw(..), (:->:)+ , biFun, convFun, inArrw, inArrw2, inArrw3+ -- * Augment other modules+ , biConst, inConst, inConst2, inConst3+ , biEndo, inEndo ) where import Control.Applicative import Control.Arrow hiding (pure) import Data.Monoid --- | Often useful for /acceptors/ (consumers, sinks) of values.+-- import Test.QuickCheck -- for Endo++import Data.Bijection++infixl 9 :. -- , `O`+infixl 7 :*:+infixr 1 :->:+infixr 0 :$++infixl 0 $*+infixr 3 ***#++{----------------------------------------------------------+ Misc+----------------------------------------------------------}++-- |Unary functions+type Unop a = a -> a+-- |Binary functions+type Binop a = a -> a -> a+++{----------------------------------------------------------+ Contravariant functors+----------------------------------------------------------}++-- | Contravariant functors. often useful for /acceptors/ (consumers,+-- sinks) of values. class Cofunctor acc where cofmap :: (a -> b) -> (acc b -> acc a) --- | Composition of type constructors: unary & unary. Called \"@g . f@\" in--- [1], section 5, but GHC won't parse that, nor will it parse any infix--- type operators in an export list. Haddock won't parse any type infixes--- at all. Meant to be used infix when Haddock is up to it or not involved.-newtype O g f a = O { unO :: g (f a) }+-- | Bijections on contravariant functors+bicomap :: Cofunctor f => (a :<->: b) -> (f a :<->: f b)+bicomap (Bi ab ba) = Bi (cofmap ba) (cofmap ab) --- | Apply a function within the 'O' constructor.-inO :: (g (f a) -> g' (f' a')) -> ((O g f) a -> (O g' f') a')-inO h = O . h . unO+{----------------------------------------------------------+ Type composition+----------------------------------------------------------} -instance (Functor g, Functor f) => Functor (O g f) where- fmap h (O gf) = O (fmap (fmap h) gf)+{- | -instance (Applicative g, Applicative f) => Applicative (O g f) where- pure x = O (pure (pure x))- O getf <*> O getx = O (liftA2 (<*>) getf getx)+Composition of unary type constructors --- instance (Functor g, Cofunctor f) => Cofunctor (O g f) where--- cofmap h (O gf) = O (fmap (cofmap h) gf)+There are (at least) two useful 'Monoid' instances, so you'll have to+pick one and type-specialize it (filling in all or parts of @g@ and\/or @f@). --- Or this alternative. Having both yields "Duplicate instance--- declarations".-instance (Cofunctor g, Functor f) => Cofunctor (O g f) where- cofmap h (O gf) = O (cofmap (fmap h) gf)+@+ -- standard Monoid instance for Applicative applied to Monoid+ instance (Applicative (g :. f), Monoid a) => Monoid ((g :. f) a) where+ { mempty = pure mempty; mappend = liftA2 mappend }+ -- Especially handy when g is a Monoid_f.+ instance Monoid (g (f a)) => Monoid ((g :. f) a) where+ { mempty = O mempty; mappend = inO2 mappend }+@ --- We can also make functors by composing /cofunctors/. GHC would--- consider such a declaration to be in conflict with the the--- composition-of-functors instance, because it doesn't take contexts into--- account. Too bad.+Corresponding to the first and second definitions above, --- standard Monoid instance for Applicative applied to Monoid-instance (Applicative (O g f), Monoid a) => Monoid (O g f a) where- { mempty = pure mempty; mappend = (*>) }+@+ instance (Applicative g, Monoid_f f) => Monoid_f (g :. f) where+ { mempty_f = O (pure mempty_f); mappend_f = inO2 (liftA2 mappend_f) }+ instance Monoid_f g => Monoid_f (g :. f) where+ { mempty_f = O mempty_f; mappend_f = inO2 mappend_f }+@ --- | Composition of type constructors: unary with binary.-newtype StaticArrow f (~>) a b = Static { unStatic :: f (a ~> b) }+Similarly, there are two useful 'Functor' instances and two useful+'Cofunctor' instances. -instance (Applicative f, Arrow (~>)) => Arrow (StaticArrow f (~>)) where- arr = Static . pure . arr- Static g >>> Static h = Static (liftA2 (>>>) g h)- first (Static g) = Static (liftA first g)+@+ instance ( Functor g, Functor f) => Functor (g :. f) where fmap = fmapFF+ instance (Cofunctor g, Cofunctor f) => Functor (g :. f) where fmap = fmapCC+@ --- For instance, /\ a b. f (a -> m b) =~ StaticArrow f Kleisli m+@+ instance (Functor g, Cofunctor f) => Cofunctor (g :. f) where cofmap = cofmapFC+ instance (Cofunctor g, Functor f) => Cofunctor (g :. f) where cofmap = cofmapCF+@ +However, it's such a bother to define the Functor instances per+composition type, I've left the fmapFF case in. If you want the fmapCC+one, you're out of luck for now. I'd love to hear a good solution. Maybe+someday Haskell will do Prolog-style search for instances, subgoaling the+constraints, rather than just matching instance heads. --- | Composition of type constructors: binary with unary.+-}+newtype (g :. f) a = O { unO :: g (f a) } +-- | Compatibility synonym+type O = (:.)++-- Here it is, as promised.+instance ( Functor g, Functor f) => Functor (g :. f) where fmap = fmapFF++-- | @newtype@ bijection+biO :: g (f a) :<->: (g :. f) a+biO = Bi O unO++-- | Compose a bijection, Functor style+convO :: Functor g => (b :<->: g c) -> (c :<->: f a) -> (b :<->: (g :. f) a)+convO biG biF = biG >>> bimap biF >>> Bi O unO++-- | Compose a bijection, Cofunctor style+coconvO :: Cofunctor g => (b :<->: g c) -> (c :<->: f a) -> (b :<->: (g :. f) a)+coconvO biG biF = biG >>> bicomap biF >>> Bi O unO+++-- | Apply a unary function within the 'O' constructor.+inO :: (g (f a) -> g' (f' a')) -> ((g :. f) a -> (g' :. f') a')+inO = (O .).(. unO)++-- | Apply a binary function within the 'O' constructor.+inO2 :: (g (f a) -> g' (f' a') -> g'' (f'' a''))+ -> ((g :. f) a -> (g' :. f') a' -> (g'' :. f'') a'')+inO2 h (O gfa) = inO (h gfa)++-- | Apply a ternary function within the 'O' constructor.+inO3 :: (g (f a) -> g' (f' a') -> g'' (f'' a'') -> g''' (f''' a'''))+ -> ((g :. f) a -> (g' :. f') a' -> (g'' :. f'') a'' -> (g''' :. f''') a''')+inO3 h (O gfa) = inO2 (h gfa)++-- | Used for the @Functor :. Functor@ instance of 'Functor'+fmapFF :: ( Functor g, Functor f) => (a -> b) -> (g :. f) a -> (g :. f) b+fmapFF h = inO $ fmap (fmap h)++-- | Used for the @Cofunctor :. Cofunctor@ instance of 'Functor'+fmapCC :: (Cofunctor g, Cofunctor f) => (a -> b) -> (g :. f) a -> (g :. f) b+fmapCC h = inO $ cofmap (cofmap h)++-- | Used for the @Functor :. Cofunctor@ instance of 'Functor'+cofmapFC :: (Functor g, Cofunctor f) => (b -> a) -> (g :. f) a -> (g :. f) b+cofmapFC h (O gf) = O (fmap (cofmap h) gf)++-- | Used for the @Cofunctor :. Functor@ instance of 'Functor'+cofmapCF :: (Cofunctor g, Functor f) => (b -> a) -> (g :. f) a -> (g :. f) b+cofmapCF h (O gf) = O (cofmap (fmap h) gf)++instance ( Functor (g :. f)+ , Applicative g, Applicative f) => Applicative (g :. f) where+ pure = O . pure . pure+ (<*>) = inO2 (liftA2 (<*>))+++-- Possible Monoid instances++-- instance (Monoid change, Applicative m, Monoid o)+-- => Monoid (SourceG change m o) where+-- mempty = pure mempty+-- mappend = liftA2 mappend++-- instance Monoid (g (f a)) => Monoid ((g :. f) a) where+-- mempty = O mempty+-- mappend = inO2 mappend+++{----------------------------------------------------------+ Unary\/binary composition+----------------------------------------------------------}++-- | Composition of type constructors: unary with binary. Called+-- "StaticArrow" in [1].+newtype OO f (~>) a b = OO { unOO :: f (a ~> b) }++instance (Applicative f, Arrow (~>)) => Arrow (OO f (~>)) where+ arr = OO . pure . arr+ OO g >>> OO h = OO (liftA2 (>>>) g h)+ first (OO g) = OO (liftA first g)++-- For instance, /\ a b. f (a -> m b) =~ OO f Kleisli m++{-++{----------------------------------------------------------+ Binary\/unary composition. * Not currently exported *+----------------------------------------------------------}++-- | Composition of type constructors: binary with unary. See also+-- 'FunA', which specializes from arrows to functions.+-- +-- Warning: Wolfgang Jeltsch pointed out a problem with these definitions:+-- 'splitA' and 'mergeA' are not inverses. The definition of 'first',+-- e.g., violates the \"extension\" law and causes repeated execution.+-- Look for a reformulation or a clarification of required properties of+-- the applicative functor @f@.+-- +-- See also "Arrows and Computation", which notes that the following type+-- is "almost an arrow" (<http://www.soi.city.ac.uk/~ross/papers/fop.html>).+-- +-- @+-- newtype ListMap i o = LM ([i] -> [o])+-- @+ newtype ArrowAp (~>) f a b = ArrowAp {unArrowAp :: f a ~> f b} instance (Arrow (~>), Applicative f) => Arrow (ArrowAp (~>) f) where@@ -93,49 +265,403 @@ loop (ArrowAp k) = ArrowAp (loop (arr mergeA >>> k >>> arr splitA)) --- Wolfgang Jeltsch pointed out a problem with these definitions: 'splitA'--- and 'mergeA' are not inverses. The definition of 'first', e.g.,--- violates the \"extension\" law and causes repeated execution. Look for--- a reformulation or a clarification of required properties of the--- applicative functor @f@.--- --- See also "Arrows and Computation", which notes that the following type--- is "almost an arrow" (http://www.soi.city.ac.uk/~ross/papers/fop.html).--- --- > newtype ListMap i o = LM ([i] -> [o])- mergeA :: Applicative f => (f a, f b) -> f (a,b) mergeA ~(fa,fb) = liftA2 (,) fa fb splitA :: Applicative f => f (a,b) -> (f a, f b) splitA fab = (liftA fst fab, liftA snd fab) +-} ++{----------------------------------------------------------+ (->)\/unary composition+----------------------------------------------------------}++-- Hm. See warning above for 'ArrowAp'++-- | Common pattern for 'Arrow's.+newtype FunA h a b = FunA { unFunA :: h a -> h b }++-- | Apply unary function in side a 'FunA' representation.+inFunA :: ((h a -> h b) -> (h' a' -> h' b'))+ -> (FunA h a b -> FunA h' a' b')+inFunA = (FunA .).(. unFunA)++-- | Apply binary function in side a 'FunA' representation.+inFunA2 :: ((h a -> h b) -> (h' a' -> h' b') -> (h'' a'' -> h'' b''))+ -> (FunA h a b -> FunA h' a' b' -> FunA h'' a'' b'')+inFunA2 q (FunA f) = inFunA (q f)++-- | Support needed for a 'FunA' to be an 'Arrow'.+class FunAble h where+ arrFun :: (a -> b) -> (h a -> h b) -- ^ for 'arr'+ firstFun :: (h a -> h a') -> (h (a,b) -> h (a',b)) -- for 'first'+ secondFun :: (h b -> h b') -> (h (a,b) -> h (a,b')) -- for 'second'+ (***%) :: (h a -> h b) -> (h a' -> h b') -> (h (a,a') -> h (b,b')) -- for '(***)'+ (&&&%) :: (h a -> h b) -> (h a -> h b') -> (h a -> h (b,b')) -- for '(&&&)'++ -- In direct imitation of Arrow defaults:+ f ***% g = firstFun f >>> secondFun g+ f &&&% g = arrFun (\b -> (b,b)) >>> f ***% g++instance FunAble h => Arrow (FunA h) where+ arr p = FunA (arrFun p)+ (>>>) = inFunA2 (>>>)+ first = inFunA firstFun+ second = inFunA secondFun+ (***) = inFunA2 (***%)+ (&&&) = inFunA2 (&&&%)++++{----------------------------------------------------------+ Monoid constructors+----------------------------------------------------------}++-- | Simulates universal constraint @forall a. Monoid (f a)@.+-- +-- See Simulating Quantified Class Constraints+-- (<http://flint.cs.yale.edu/trifonov/papers/sqcc.pdf>)+-- Instantiate this schema wherever necessary:+--+-- @+-- instance Monoid_f f where { mempty_f = mempty ; mappend_f = mappend }+-- @+class Monoid_f m where+ mempty_f :: forall a. m a+ mappend_f :: forall a. m a -> m a -> m a++-- e.g.,+instance Monoid_f [] where { mempty_f = mempty ; mappend_f = mappend }++++{----------------------------------------------------------+ Flip a binary constructor's type arguments+----------------------------------------------------------}+ -- | Flip type arguments newtype Flip (~>) b a = Flip { unFlip :: a ~> b } +-- | @newtype@ bijection+biFlip :: (a ~> b) :<->: Flip (~>) b a+biFlip = Bi Flip unFlip++-- Apply unary function inside of a 'Flip' representation. inFlip :: ((a~>b) -> (a' ~~> b')) -> (Flip (~>) b a -> Flip (~~>) b' a')-inFlip f (Flip ar) = Flip (f ar)+inFlip = (Flip .).(. unFlip) +-- Apply binary function inside of a 'Flip' representation. inFlip2 :: ((a~>b) -> (a' ~~> b') -> (a'' ~~~> b'')) -> (Flip (~>) b a -> Flip (~~>) b' a' -> Flip (~~~>) b'' a'')-inFlip2 f (Flip ar) (Flip ar') = Flip (f ar ar')+inFlip2 f (Flip ar) = inFlip (f ar) +-- Apply ternary function inside of a 'Flip' representation.+inFlip3 :: ((a~>b) -> (a' ~~> b') -> (a'' ~~~> b'') -> (a''' ~~~~> b'''))+ -> (Flip (~>) b a -> Flip (~~>) b' a' -> Flip (~~~>) b'' a'' -> Flip (~~~~>) b''' a''')+inFlip3 f (Flip ar) = inFlip2 (f ar)+ instance Arrow (~>) => Cofunctor (Flip (~>) b) where cofmap h (Flip f) = Flip (arr h >>> f) +-- Useful for (~>) = (->). Maybe others.+instance (Applicative ((~>) a), Monoid o) => Monoid (Flip (~>) o a) where+ mempty = Flip (pure mempty)+ mappend = inFlip2 (liftA2 mappend)++-- TODO: generalize (->) to (~>) with Applicative_f (~>)+instance Monoid o => Monoid_f (Flip (->) o) where+ { mempty_f = mempty ; mappend_f = mappend }++-- | (-> IO ()) as a 'Flip'. A Cofunctor.+type OI = Flip (->) (IO ())++-- | Convert to an 'OI'.+class ToOI sink where toOI :: sink b -> OI b++instance ToOI OI where toOI = id++{----------------------------------------------------------+ Type application+----------------------------------------------------------}+ -- | Type application-newtype App f a = App { unApp :: f a }+-- We can also drop the @App@ constructor, but then we overlap with many+-- other instances, like @[a]@. Here's a template for @App@-free+-- instances.+-- +-- @+-- instance (Applicative f, Monoid a) => Monoid (f a) where+-- mempty = pure mempty+-- mappend = liftA2 mappend+-- @+newtype f :$ a = App { unApp :: f a } +-- | Compatibility synonym for (:$).+type App = (:$)++-- How about?+-- data f :$ a = App { unApp :: f a }++-- | @newtype@ bijection+biApp :: f a :<->: App f a+biApp = Bi App unApp++-- Apply unary function inside of an 'App representation.+inApp :: (f a -> f' a') -> (App f a -> App f' a')+inApp = (App .).(. unApp)++-- Apply binary function inside of a 'App' representation.+inApp2 :: (f a -> f' a' -> f'' a'') -> (App f a -> App f' a' -> App f'' a'')+inApp2 h (App fa) = inApp (h fa)+ -- Example: App IO () instance (Applicative f, Monoid m) => Monoid (App f m) where- mempty = App (pure mempty)- App a `mappend` App b = App (a *> b)+ mempty = App (pure mempty )+ mappend = inApp2 (liftA2 mappend) -{---- We can also drop the App constructor, but then we overlap with many--- other instances, like [a].-instance (Applicative f, Monoid a) => Monoid (f a) where- mempty = pure mempty- mappend = (*>)--}+-- App a `mappend` App b = App (liftA2 mappend a b)+++{----------------------------------------------------------+ Identity -- TODO: eliminate in favor of Data.Traversable.Id+----------------------------------------------------------}++-- | Identity type constructor. Until there's a better place to find it.+-- I'd use "Control.Monad.Identity", but I don't want to introduce a+-- dependency on mtl just for Id.+newtype Id a = Id { unId :: a }++inId :: (a -> b) -> (Id a -> Id b)+inId = (Id .).(. unId)++-- | @newtype@ bijection+biId :: a :<->: Id a+biId = Bi Id unId+++{----------------------------------------------------------+ Unary constructor pairing+----------------------------------------------------------}++-- | Pairing of unary type constructors+newtype (f :*: g) a = Prod { unProd :: (f a, g a) }+ -- deriving (Show, Eq, Ord)++-- | @newtype@ bijection+biProd :: (f a, g a) :<->: (f :*: g) a+biProd = Bi Prod unProd++-- | Compose a bijection+convProd :: (b :<->: f a) -> (c :<->: g a) -> (b,c) :<->: (f :*: g) a+convProd biF biG = biF *** biG >>> Bi Prod unProd++-- In GHC 6.7, deriving no longer works on types like :*:. Take out the+-- following three instances when deriving works again, in GHC 6.8.++instance (Show (f a, g a)) => Show ((f :*: g) a) where+ show (Prod p) = "Prod " ++ show p++instance (Eq (f a, g a)) => Eq ((f :*: g) a) where+ Prod p == Prod q = p == q++instance (Ord (f a, g a)) => Ord ((f :*: g) a) where+ Prod p <= Prod q = p <= q+ Prod p `compare` Prod q = p `compare` q++-- | Apply unary function inside of @f :*: g@ representation.+inProd :: ((f a, g a) -> (f' a', g' a'))+ -> ((f :*: g) a -> (f' :*: g') a')+inProd = (Prod .).(. unProd)++-- | Apply binary function inside of @f :*: g@ representation.+inProd2 :: ((f a, g a) -> (f' a', g' a') -> (f'' a'', g'' a''))+ -> ((f :*: g) a -> (f' :*: g') a' -> (f'' :*: g'') a'')+inProd2 h (Prod p) = inProd (h p)++-- | Apply ternary function inside of @f :*: g@ representation.+inProd3 :: ((f a, g a) -> (f' a', g' a') -> (f'' a'', g'' a'')+ -> (f''' a''', g''' a'''))+ -> ((f :*: g) a -> (f' :*: g') a' -> (f'' :*: g'') a''+ -> (f''' :*: g''') a''')+inProd3 h (Prod p) = inProd2 (h p)++-- | A handy combining form. See '(***#)' for an sample use.+($*) :: (a -> b, a' -> b') -> (a,a') -> (b,b')+($*) = uncurry (***)++-- | Combine two binary functions into a binary function on pairs+(***#) :: (a -> b -> c) -> (a' -> b' -> c')+ -> (a, a') -> (b, b') -> (c, c')+h ***# h' = \ as bs -> (h,h') $* as $* bs+ -- (uncurry (***)) . (h *** h')+ -- \ as bs -> uncurry (***) ((h *** h') as) bs+ -- \ as bs -> (h *** h') as $* bs+ -- \ (a,a') (b,b') -> (h a b, h' a' b')++-- instance (Monoid a, Monoid b) => Monoid (a,b) where+-- mempty = (mempty, mempty)+-- mappend = mappend ***# mappend++instance (Monoid_f f, Monoid_f g) => Monoid_f (f :*: g) where+ mempty_f = Prod (mempty_f,mempty_f)+ mappend_f = inProd2 (mappend_f ***# mappend_f)++instance (Functor f, Functor g) => Functor (f :*: g) where+ fmap h = inProd (fmap h *** fmap h)+++{----------------------------------------------------------+ Binary constructor pairing+----------------------------------------------------------}++-- | Pairing of binary type constructors+newtype (f ::*:: g) a b = Prodd { unProdd :: (f a b, g a b) }+ -- deriving (Show, Eq, Ord)++-- Remove the next three when GHC can derive them (6.8).++instance (Show (f a b, g a b)) => Show ((f ::*:: g) a b) where+ show (Prodd p) = "Prod " ++ show p++instance (Eq (f a b, g a b)) => Eq ((f ::*:: g) a b) where+ Prodd p == Prodd q = p == q++instance (Ord (f a b, g a b)) => Ord ((f ::*:: g) a b) where+ Prodd p < Prodd q = p < q++-- | Apply binary function inside of @f :*: g@ representation.+inProdd :: ((f a b, g a b) -> (f' a' b', g' a' b'))+ -> ((f ::*:: g) a b -> (f' ::*:: g') a' b')+inProdd = (Prodd .).(. unProdd)++-- | Apply binary function inside of @f :*: g@ representation.+inProdd2 :: ((f a b, g a b) -> (f' a' b', g' a' b') -> (f'' a'' b'', g'' a'' b''))+ -> ((f ::*:: g) a b -> (f' ::*:: g') a' b' -> (f'' ::*:: g'') a'' b'')+inProdd2 h (Prodd p) = inProdd (h p)++instance (Arrow f, Arrow f') => Arrow (f ::*:: f') where+ arr = Prodd . (arr &&& arr )+ (>>>) = inProdd2 ((>>>) ***# (>>>) )+ first = inProdd (first *** first )+ second = inProdd (second *** second)+ (***) = inProdd2 ((***) ***# (***) )+ (&&&) = inProdd2 ((&&&) ***# (&&&) )+++{----------------------------------------------------------+ Arrow between /two/ constructor applications+----------------------------------------------------------}++-- | Arrow-like type between type constructors (doesn't enforce @Arrow+-- (~>)@ here).+newtype Arrw (~>) f g a = Arrw { unArrw :: f a ~> g a } -- deriving Monoid++deriving instance Monoid (f a ~> g a) => Monoid (Arrw (~>) f g a)++-- Replace with generalized bijection?++-- toArrw :: Arrow (~>) => (f a ~> b) -> (c ~> g a) -> ((b ~> c) -> Arrw (~>) f g a)+-- toArrw fromF toG h = Arrw (fromF >>> h >>> toG)++-- fromArrw :: Arrow (~>) => (b ~> f a) -> (g a ~> c) -> (Arrw (~>) f g a -> (b ~> c))+-- fromArrw toF fromG (Arrw h') = toF >>> h' >>> fromG++-- | Apply unary function inside of @Arrw@ representation.+inArrw :: ((f a ~> g a) -> (f' a' ~> g' a'))+ -> ((Arrw (~>) f g) a -> (Arrw (~>) f' g') a')+inArrw = (Arrw .).(. unArrw)++-- | Apply binary function inside of @Arrw (~>) f g@ representation.+inArrw2 :: ((f a ~> g a) -> (f' a' ~> g' a') -> (f'' a'' ~> g'' a''))+ -> (Arrw (~>) f g a -> Arrw (~>) f' g' a' -> Arrw (~>) f'' g'' a'')+inArrw2 h (Arrw p) = inArrw (h p)++-- | Apply ternary function inside of @Arrw (~>) f g@ representation.+inArrw3 :: ((f a ~> g a) -> (f' a' ~> g' a') -> (f'' a'' ~> g'' a'') -> (f''' a''' ~> g''' a'''))+ -> ((Arrw (~>) f g) a -> (Arrw (~>) f' g') a' -> (Arrw (~>) f'' g'') a'' -> (Arrw (~>) f''' g''') a''')+inArrw3 h (Arrw p) = inArrw2 (h p)++-- Functor & Cofunctor instances. Beware use of 'arr', which is not+-- available for some of my favorite arrows.++instance (Arrow (~>), Cofunctor f, Functor g) => Functor (Arrw (~>) f g) where+ fmap h = inArrw $ \ fga -> arr (cofmap h) >>> fga >>> arr (fmap h)++instance (Arrow (~>), Functor f, Cofunctor g) => Cofunctor (Arrw (~>) f g) where+ cofmap h = inArrw $ \ fga -> arr (fmap h) >>> fga >>> arr (cofmap h)++-- Restated,+-- +-- cofmap h = inArrw $ (arr (fmap h) >>>) . (>>> arr (cofmap h))++-- 'Arrw' specialized to functions. +type (:->:) = Arrw (->)++-- | @newtype@ bijection+biFun :: (f a -> g a) :<->: (f :->: g) a+biFun = Bi Arrw unArrw++-- | Compose a bijection+convFun :: (b :<->: f a) -> (c :<->: g a) -> ((b -> c) :<->: (f :->: g) a)+convFun bfa cga = (bfa ---> cga) >>> biFun++-- biA :: ((f a -> g a) :<->: (f :->: g) a)+-- biA = Bi Arrw unArrw+++{----------------------------------------------------------+ Augment other modules+----------------------------------------------------------}++---- For Control.Applicative Const++-- newtype Const a b = Const { getConst :: a }++-- | @newtype@ bijection+biConst :: a :<->: Const a b+biConst = Bi Const getConst++inConst :: (a -> b) -> Const a u -> Const b v+inConst = (Const .).(. getConst)++inConst2 :: (a -> b -> c) -> Const a u -> Const b v -> Const c w+inConst2 f (Const a) = inConst (f a)++inConst3 :: (a -> b -> c -> d)+ -> Const a u -> Const b v -> Const c w -> Const d x+inConst3 f (Const a) = inConst2 (f a)+++---- For Control.Applicative.Endo++-- deriving instance Monoid o => Monoid (Const o a)+instance Monoid o => Monoid (Const o a) where+ mempty = Const mempty+ mappend = inConst2 mappend++-- newtype Endo a = Endo { appEndo :: a -> a }++-- | @newtype@ bijection+biEndo :: (a -> a) :<->: Endo a+biEndo = Bi Endo appEndo++instance Monoid_f Endo where { mempty_f = mempty; mappend_f = mappend }++-- | Convenience for partial-manipulating functions+inEndo :: (Unop a -> Unop a') -> (Endo a -> Endo a')+inEndo f = Endo . f . appEndo++-- -- | Dual for 'inEndo'+-- outEndo :: (Endo a -> Endo a') -> ((a->a) -> (a'->a'))+-- outEndo g = appEndo . g . Endo++-- -- Missing from Control.Applicative+-- instance Arbitrary a => Arbitrary (Endo a) where+-- arbitrary = fmap Endo arbitrary+-- coarbitrary = coarbitrary . appEndo++-- -- Simple show instance. Better: show an arbitrary sampling of the function.+-- instance Show (Endo a) where show _ = "Endo <function>"+
− src/Control/DataDriven.hs
@@ -1,96 +0,0 @@-{-# OPTIONS -fglasgow-exts #-}--------------------------------------------------------------------------- |--- Module : Control.DataDriven--- Copyright : (c) Conal Elliott 2007--- License : LGPL--- --- Maintainer : conal@conal.net--- Stability : experimental--- Portability : portable--- --- Data-driven computations-------------------------------------------------------------------------module Control.DataDriven- (- -- * Plumbing for \"events\" and subscription - Sink, Action, News- -- * Data-driven computations- , DataDrivenG, dd, mapCur- , DataDriven, runDD, joinDD- ) where--import Control.Applicative-import Control.Monad (join)-import Control.Arrow (second)--import Data.Monoid--import Control.Compose---{----------------------------------------------------------- Plumbing for event publishing-----------------------------------------------------------}---- | Sinks (consumers) of values-type Sink cur a = a -> Action cur---- | Actions-type Action cur = cur ()---- | News publisher -- somewhere to register updaters to be executed--- when events occur.-type News cur = Sink cur (Action cur)---{----------------------------------------------------------- Data-driven computations-----------------------------------------------------------}---- | The general type of data-driven computations. Represented as a--- /news/ publisher (@news@) and a way to get new values (@cur@). Clients--- interested in the value subscribe to @news@ and extract a new value--- from @cur@ when notified that the value may have changed. When @news@--- is a monoid and @cur@ is an applicative functor, @DataDrivenG news cur@--- is an applicative functor also. The applicative property is very--- convenient for composition. See the more specific type 'DataDriven'.------ Nicer, but Haddock chokes on the infix op:--- type DataDrivenG news cur = ((,) news) `O` cur--type DataDrivenG news cur = O ((,) news) cur---- More tersely :--- type DataDrivenG news = O ((,) news)---- | Construct a data-driven computation from a subscription service--- (@Monoid@) and a value source subscriber (@Applicative@).-dd :: cur a -> news -> DataDrivenG news cur a-dd = flip (curry O)---- | Modify the source part of a 'DataDriven' computation.-mapCur :: (cur a -> cur b) -> (DataDrivenG news cur a -> DataDrivenG news cur b)-mapCur f = inO (second f)----- | Data driven with news publisher-type DataDriven cur = DataDrivenG (News cur) cur----- | Run a unit-valued 'DataDriven' computation. Causes the source to be--- executed /and/ registered with the subscriber.-runDD :: (Monoid (Action cur), Applicative cur)- => DataDriven cur () -> Action cur-runDD (O (news,cur)) = news cur `mappend` cur---- | Apply 'join' to a source-joinDD :: Monad cur => DataDriven cur (cur a) -> DataDriven cur a-joinDD = mapCur join---- runDDJoin :: (Monad cur, Applicative cur, Monoid (Action cur))--- => DataDriven cur (Action cur) -> Action cur--- runDDJoin = runDD . joinDD-
src/Control/Instances.hs view
@@ -1,36 +1,28 @@-{-# OPTIONS #-} - ----------------------------------------------------------------------- --- | --- Module : Control.Instances --- Copyright : (c) Conal Elliott 2007 --- License : LGPL --- --- Maintainer : conal@conal.net --- Stability : experimental --- Portability : portable --- --- Some (orphan) instances that belong elsewhere (where they wouldn't be orphans). --- Add the following line to get these instances --- --- > import Control.Instances () --- ----------------------------------------------------------------------- - -module Control.Instances () where - -import Data.Monoid -import Control.Applicative -import Control.Monad.Reader -import Control.Monad - - --- Standard instance: Applicative functor applied to monoid -instance Monoid a => Monoid (IO a) where - mempty = pure mempty - mappend = liftA2 mappend - - --- standard Applicative instance for Monad -instance Monad m => Applicative (ReaderT r m) where { pure = return; (<*>) = ap } - +{-# OPTIONS_GHC -fno-warn-orphans #-}+----------------------------------------------------------------------+-- |+-- Module : Control.Instances+-- Copyright : (c) Conal Elliott 2007+-- License : BSD3+-- +-- Maintainer : conal@conal.net+-- Stability : experimental+-- Portability : portable+-- +-- Some (orphan) instances that belong elsewhere (where they wouldn't be orphans).+-- Add the following line to get these instances+-- +-- > import Control.Instances ()+-- +----------------------------------------------------------------------++module Control.Instances () where++import Data.Monoid+import Control.Applicative+++-- Standard instance: Applicative functor applied to monoid+instance Monoid o => Monoid (IO o) where + mempty = pure mempty+ mappend = liftA2 mappend
+ src/Data/Bijection.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE TypeOperators #-}+-- For ghc 6.6 compatibility+-- {-# OPTIONS -fglasgow-exts #-}+++----------------------------------------------------------------------+-- |+-- Module : Data.Bijection+-- Copyright : (c) Conal Elliott 2007+-- License : BSD3+-- +-- Maintainer : conal@conal.net+-- Stability : experimental+-- Portability : TypeOperators+-- +-- Bijections. See also [1], which provides a more general setting.+-- +-- [1]: /There and Back Again: Arrows for Invertible Programming/,+-- <http://citeseer.ist.psu.edu/alimarine05there.html>.+-- +-- +----------------------------------------------------------------------++module Data.Bijection+ (+ Bijection(..),(:<->:)+ , idb, inverse, bimap, (--->)+ , inBi+ ) where++import Control.Arrow+++infix 8 :<->:+infixr 2 --->++-- | A type of bijective arrows+data Bijection (~>) a b = Bi { biTo :: a ~> b, biFrom :: b ~> a }++-- | Bijective functions+type a :<->: b = Bijection (->) a b++-- | Bijective identity arrow. Warning: uses 'arr' on @(~>)@. If you+-- have no 'arr', but you have a @DeepArrow@, you can instead use @Bi idA+-- idA@.+idb :: Arrow (~>) => Bijection (~>) a a+idb = Bi idA idA where idA = arr id++-- | Inverse bijection+inverse :: Bijection (~>) a b -> Bijection (~>) b a+inverse (Bi ab ba) = Bi ba ab++instance Arrow (~>) => Arrow (Bijection (~>)) where+ arr = error "No arr for (:<->:)."+ Bi ab ba >>> Bi bc cb = Bi (ab >>> bc) (cb >>> ba)+ first (Bi ab ba) = Bi (first ab) (first ba)+ second (Bi ab ba) = Bi (second ab) (second ba)+ Bi ab ba *** Bi cd dc = Bi (ab *** cd) (ba *** dc)+ (&&&) = error "No (***) for (:<->:)"+ -- Can't really define (&&&) unless we have a way to merge two @a@ values.+ -- Bi ab ba &&& Bi ac ca = Bi (ab &&& ac) (ba &&& ???)++-- Most but not all DeepArrow operations can be defined. No @fstA@, @sndA@.++-- The '(***)' operator creates bijections on pairs. Here are some similar tools.++-- | Bijections on functors+bimap :: Functor f => (a :<->: b) -> (f a :<->: f b)+bimap (Bi ab ba) = Bi (fmap ab) (fmap ba)++-- | Bijections on arrows.+(--->) :: Arrow (~>) => Bijection (~>) a b -> Bijection (~>) c d+ -> (a ~> c) :<->: (b ~> d)+Bi ab ba ---> Bi cd dc = Bi (\ ac -> ba>>>ac>>>cd) (\ bd -> ab>>>bd>>>dc)++-- | Apply a function in an alternative (monomorphic) representation.+inBi :: Arrow (~>) => Bijection (~>) a b -> (a ~> a) -> (b ~> b)+inBi (Bi to from) aa = from >>> aa >>> to
+ src/Data/CxMonoid.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE TypeSynonymInstances, TypeOperators, GeneralizedNewtypeDeriving #-}+-- -- For ghc 6.6 compatibility+-- {-# OPTIONS -fglasgow-exts #-}++----------------------------------------------------------------------+-- |+-- Module : Data.CxMonoid+-- Copyright : (c) Conal Elliott 2007+-- License : BSD3+-- +-- Maintainer : conal@conal.net+-- Stability : experimental+-- Portability : synonym instance+-- +-- Context-dependent monoids+----------------------------------------------------------------------++module Data.CxMonoid (MonoidDict, CxMonoid(..), biCxMonoid) where++import Data.Monoid (Monoid(..))++import Data.Bijection+import Data.Title++-- | Dictionary for 'CxMonoid'.+type MonoidDict a = (a, a -> a -> a)++-- | Type of context-dependent monoid. Includes an explicit dictionary.+newtype CxMonoid a = CxMonoid { unCxMonoid :: MonoidDict a -> a }++-- | @newtype@ bijection+biCxMonoid :: (MonoidDict a -> a) :<->: CxMonoid a+biCxMonoid = Bi CxMonoid unCxMonoid++instance Monoid (CxMonoid a) where+ mempty = CxMonoid (\ (e,_) -> e)+ CxMonoid f `mappend` CxMonoid g =+ CxMonoid (\ md@(_,op) -> f md `op` g md)++-- Exploit the function instance of 'Title'+instance Title a => Title (CxMonoid a) where+ title str = inBi biCxMonoid $ title str
+ src/Data/Lambda.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE Rank2Types, TypeOperators, MultiParamTypeClasses+ , FunctionalDependencies, FlexibleInstances, TypeSynonymInstances #-}+-- -- For ghc 6.6 compatibility+-- {-# OPTIONS -fglasgow-exts #-}++----------------------------------------------------------------------+-- |+-- Module : Data.Lambda+-- Copyright : (c) Conal Elliott 2007+-- License : BSD3+-- +-- Maintainer : conal@conal.net+-- Stability : experimental+-- Portability : multi-parameter type classes+-- +-- Some function-like classes, having lambda-like construction.+-- See 'LambdaTy' for why "lambda".+-- See "Data.Pair" for similar classes.+----------------------------------------------------------------------++module Data.Lambda+ (+ -- * Make function-like things+ LambdaTy+ , Lambda(..)+ -- * Dissect function-like things+ , Unlambda(..)+ -- * Dual dissections+ , Colambda(..)+ ) where++import Data.Monoid (Endo)+import Control.Applicative+import Control.Arrow++import Control.Compose+import Data.Bijection++{----------------------------------------------------------+ Make function-like things+----------------------------------------------------------}++-- | Type of 'lambda' method. Think of @src@ as the bound variable (or+-- pattern) part of a lambda and @snk@ as the expression part. They+-- combine to form a function-typed expression. +-- Instance template:+-- +-- @+-- instance (Applicative f, Lambda src snk)+-- => Lambda (f :. src) (f :. snk) where+-- lambda = apLambda+-- @+type LambdaTy src snk = forall a b. src a -> snk b -> snk (a -> b)++-- | Type constructor class for function-like things having lambda-like construction.+class Lambda src snk where+ lambda :: LambdaTy src snk -- ^ Form a function-like value++-- | Handy for 'Applicative' functor instances of 'Lambda'+apLambda :: (Applicative f, Lambda src snk) => LambdaTy (f :. src) (f :. snk)+apLambda = inO2 (liftA2 lambda)++-- Helper+apLambda' :: Applicative f => f a -> (f b -> o) -> (f (a->b) -> o)+apLambda' a bo ab = bo (ab <*> a)++---- Other instances++instance Lambda Id (Flip (->) o) where+ lambda (Id a) (Flip bo) = Flip (\ ab -> bo (ab a))++instance Lambda IO OI where+ lambda geta (Flip snkb) = Flip (\ f -> fmap f geta >>= snkb)++-- f a & f (b -> o)+instance Applicative f => Lambda f (f :. Flip (->) o) where+ -- Map f a -> (f :. Id) a, and appeal to the O/O and Id/Flip instances+ lambda src snk = apLambda (O (fmap Id src)) snk++-- f a & (f b -> o)+instance Applicative f => Lambda f (Flip (->) o :. f) where+ lambda a b = biTo bi (apLambda' a (biFrom bi b))+ where+ bi = coconvO biFlip idb++-- Different wrapping of above+instance Applicative f => Lambda f (f :->: Const o) where+ lambda a b = biTo bi (apLambda' a (biFrom bi b))+ where+ bi = idb `convFun` biConst++instance (Lambda src snk, Lambda dom' ran')+ => Lambda (src :*: dom') (snk :*: ran') where+ lambda = inProd2 (lambda ***# lambda)++-- | 'lambda' with 'Arrw'. /Warning/: definition uses 'arr', so only+-- use if your arrow has a working 'arr'.+arLambda :: (Arrow (~>), Unlambda f f', Lambda g g')+ => LambdaTy (Arrw (~>) f g) (Arrw (~>) f' g')+arLambda = inArrw2 $ \ fga fgb ->+ arr unlambda >>> fga***fgb >>> arr (uncurry lambda)++instance (Arrow (~>), Unlambda f f', Lambda g g')+ => Lambda (Arrw (~>) f g) (Arrw (~>) f' g')+ where lambda = arLambda+++{----------------------------------------------------------+ Dissect function-like things+----------------------------------------------------------}++-- | Like @Unpair@, but for functions. Minimal instance definition: either (a)+-- 'unlambda' /or/ (b) both of 'fsrc' /and/ 'fres'.+class Unlambda src snk | snk -> src where+ -- | Deconstruct pair-like value+ unlambda :: snk (a -> b) -> (src a, snk b)+ -- | First part of pair-like value+ fsrc :: snk (a -> b) -> src a+ -- | Second part of pair-like value+ fres :: snk (a -> b) -> snk b+ unlambda = fsrc &&& fres+ fsrc = fst.unlambda+ fres = snd.unlambda+++{----------------------------------------------------------+ Dual dissections+----------------------------------------------------------}++-- | Like @Copair@, but for functions+class Colambda f where+ cores :: f b -> f (a -> b)++-- Handy for partial values <http://haskell.org/haskellwiki/Partial>+instance Unlambda Endo Endo where+ fres = inEndo $ (($) undefined) . (. const)++instance Colambda Endo where+ cores = inEndo (.)+
+ src/Data/Pair.hs view
@@ -0,0 +1,187 @@+{-# LANGUAGE Rank2Types, TypeOperators, FlexibleInstances, FlexibleContexts+ , UndecidableInstances, TypeSynonymInstances #-}++-- -- For ghc 6.6 compatibility+-- {-# OPTIONS -fglasgow-exts -fallow-undecidable-instances #-}++----------------------------------------------------------------------+-- |+-- Module : Data.Pair+-- Copyright : (c) Conal Elliott 2007+-- License : BSD3+-- +-- Maintainer : conal@conal.net+-- Stability : experimental+-- Portability : GHC+-- +-- Pair-related type constructor classes. See "Data.Fun" for similar classes.+----------------------------------------------------------------------++module Data.Pair+ (+ -- * Pairings+ PairTy, Pair(..)+ , apPair, ppPair, arPair+ -- * Unpairings+ , UnpairTy, Unpair(..)+ -- * Dual unpairings+ , Copair(..), copair+ ) where+++import Data.Monoid+import Control.Arrow+import Control.Applicative++import Control.Compose+++{----------------------------------------------------------+ Pairings+----------------------------------------------------------}++-- | Type of 'pair' method+type PairTy f = forall a b. f a -> f b -> f (a,b)++-- | Type constructor class for pair-like things. Generalizes 'zip'.+-- Here are some standard instance templates you can fill in. They're not+-- defined in the general forms below, because they would lead to a lot of+-- overlap.+-- +-- @+-- instance Applicative f => Pair f where+-- pair = liftA2 (,)+-- instance (Applicative h, Pair f) => Pair (h :. f) where+-- pair = apPair+-- instance (Functor g, Pair g, Pair f) => Pair (g :. f)+-- where pair = ppPair+-- instance (Arrow (~>), Unpair f, Pair g) => Pair (Arrw (~>) f g) where+-- pair = arPair+-- instance (Monoid_f h, Copair h) => Pair h where+-- pair = copair+-- @++class Pair f where+ pair :: PairTy f -- ^ Form a pair-like value (generalizes 'zip')++-- Standard instances (Applicative f)+instance Monoid u => Pair ((,) u) where pair = liftA2 (,)+instance Pair ((->) u) where pair = liftA2 (,)+instance Pair IO where pair = liftA2 (,)++instance Monoid o => Pair (Const o) where+ pair = inConst2 mappend++instance Pair Id where Id a `pair` Id b = Id (a,b)++-- Standard instance, e.g., (~>) = (->)+-- This one requires UndecidableInstances. Alternatively, specialize to+-- (->) and other arrows as desired.+instance (Arrow (~>), Monoid_f (Flip (~>) o)) =>+ Pair (Flip (~>) o) where pair = copair++-- | Handy for 'Pair' instances+apPair :: (Applicative h, Pair f) => PairTy (h :. f)+apPair = inO2 (liftA2 pair)++-- | Handy for 'Pair' instances+ppPair :: (Functor g, Pair g, Pair f) => PairTy (g :. f)+ppPair = inO2 $ \ gfa gfb -> fmap (uncurry pair) (gfa `pair` gfb)++-- | Pairing of 'Arrw' values. /Warning/: definition uses 'arr', so only+-- use if your arrow has a working 'arr'.+arPair :: (Arrow (~>), Unpair f, Pair g) => PairTy (Arrw (~>) f g)+arPair = inArrw2 $ \ fga fgb ->+ arr unpair >>> fga***fgb >>> arr (uncurry pair)++-- Standard instance+instance (Arrow (~>), Unpair f, Pair g) => Pair (Arrw (~>) f g)+ where pair = arPair++instance (Pair f, Pair g) => Pair (f :*: g) where+ pair = inProd2 (pair ***# pair)+++{----------------------------------------------------------+ Unpairings+----------------------------------------------------------}++-- | Type of 'unpair' method. Generalizes 'unzip'.+type UnpairTy f = forall a b. f (a,b) -> (f a, f b)++-- | Dissectable as pairs. Minimal instance definition: either (a)+-- 'unpair' /or/ (b) both of 'pfst' /and/ 'psnd'.+-- A standard template to substitute any 'Functor' @f.@ But watch out for+-- effects!+-- +-- @+-- instance Functor f => Unpair f where {pfst = fmap fst; psnd = fmap snd}+-- @+class Unpair f where+ unpair :: UnpairTy f -- ^ Deconstruct pair-like value+ pfst :: f (a,b) -> f a -- ^ First part of pair-like value+ psnd :: f (a,b) -> f b -- ^ Second part of pair-like value++ unpair = pfst &&& psnd+ pfst = fst.unpair+ psnd = snd.unpair++instance Unpair (Const a) where+ unpair (Const a) = (Const a, Const a)++instance Unpair Id where+ unpair (Id (a,b)) = (Id a, Id b)++-- Standard instance+instance Unpair [] where { pfst = fmap fst; psnd = fmap snd }+++{----------------------------------------------------------+ Dual unpairings+----------------------------------------------------------}++-- | Dual to 'Unpair'.+-- Especially handy for contravariant functors ('Cofunctor') . Use this+-- template (filling in @f@) :+-- +-- @+-- instance Cofunctor f => Copair f where+-- { cofst = cofmap fst ; cosnd = cofmap snd }+-- @+class Copair f where+ cofst :: f a -> f (a,b) -- ^ Pair-like value from first part+ cosnd :: f b -> f (a,b) -- ^ Pair-like value from second part++instance Copair (Const e) where+ cofst = inConst id+ cosnd = inConst id++-- Standard instance for contravariant functors+instance Arrow (~>) => Copair (Flip (~>) o) where+ { cofst = cofmap fst ; cosnd = cofmap snd }++instance (Functor h, Copair f) => Copair (h :. f) where+ cofst = inO (fmap cofst)+ cosnd = inO (fmap cosnd)++instance (Copair f, Copair g) => Copair (f :*: g) where+ cofst = inProd (cofst *** cofst)+ cosnd = inProd (cosnd *** cosnd)++-- | Pairing of 'Copair' values. Combines contribution of each.+copair :: (Copair f, Monoid_f f) => PairTy f+fa `copair` fb = cofst fa `mappend_f` cosnd fb++-- Control.Applicative.Endo+-- Handy for "partial values" <http://haskell.org/haskellwiki/Partial>++instance Unpair Endo where -- Parital == Endo+ pfst = inEndo $ (fst .) . (. (\ a -> (a, undefined)))+ psnd = inEndo $ (snd .) . (. (\ b -> (undefined, b)))++instance Copair Endo where -- Parital == Endo+ cofst = inEndo first+ cosnd = inEndo second++-- Standard instance for (Monoid_f h, Copair h)+instance Pair Endo where pair = copair
+ src/Data/Partial.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE TypeSynonymInstances #-}++----------------------------------------------------------------------+-- |+-- Module : Data.Partial+-- Copyright : (c) Conal Elliott 2007+-- License : BSD3+-- +-- Maintainer : conal@conal.net+-- Stability : experimental+-- Portability : portable+-- +-- A monoid 'Partial' of partial values. See the [Teaser] and [Solution] blog+-- posts.+-- +-- [Teaser]: <http://conal-elliott.blogspot.com/2007/07/type-for-partial-values.html>+-- [Solution]: <http://conal-elliott.blogspot.com/2007/07/implementing-type-for-partial-values.html>+-- +-- Also defines a 'FunAble' instance, so that @FunA Partial@ is an arrow.+----------------------------------------------------------------------++module Data.Partial+ (+ -- * Partial values+ Partial, PartialX, valp, pval+ , pUnElt, pUnArg, pUnRes, pUnSrc+ -- * Support for arrow partial value arrow+ -- via 'FunAble' instance+ ) where++import Data.Monoid+import Control.Arrow++import Control.Compose (FunAble(..),inEndo)++import Data.Pair++-- | Partial value. Represented an endomorphism, which is a 'Monoid'+-- under 'id' and '(.)'. Then 'mempty' is the completely undefined value,+-- and in @u `@'mappend'@` v@, @v@ selectively replaces parts of @u@. The+-- 'Endo' instances for 'Pair', 'Unpair', 'Copair', 'Unfun', and 'Cofun'+-- are all very useful on partial values.+type Partial = Endo++type PartialX a b = Partial a -> Partial b++-- | Treat a full value as a partial one. Fully overrides any+-- \"previous\" (earlier argument to @mappend@) partial value.+valp :: c -> Partial c+valp c = Endo (const c)++-- | Force a partial value into a full one, filling in bottom for any+-- missing parts.+pval :: Partial c -> c+pval (Endo f) = f (error "Partial: absent info")+++-- | Inverse to \"element\" access, on all elements. A way to inject some+-- info about every element. For @f@, consider '[]', @(->) a@,+-- @Event@, etc.++pUnElt :: Functor f => PartialX a (f a)+pUnElt = inEndo fmap++-- | Provide in info about a function argument+pUnArg :: PartialX u (u -> v)+pUnArg = inEndo (flip (.)) -- \ uv -> \ u -> uv (uu u)++-- | Provide info about a function result+pUnRes :: PartialX v (u -> v)+pUnRes = inEndo (.)++-- | Inject a partial argument-source into a partial function-sink.+pUnSrc :: PartialX a ((a -> b) -> o)+pUnSrc = pUnArg . pUnArg+++{----------------------------------------------------------+ 'FunA' support for arrows on partial values+----------------------------------------------------------}++instance FunAble Partial where+ arrFun = pArr+ firstFun = pFirst+ secondFun = pSecond++-- I don't think we can define @arr f@ unless we can invert @f@. Same+-- problem exists in "There and back again: arrows for invertible+-- programming". Suggests refactoring Arrow.++pArr :: (a->b) -> PartialX a b+pArr f = inEndo $ (f .) . (. inv f)+ where+ inv :: (a->b) -> (b->a)+ inv = error "inv -- can't do it."++-- Since @pArr == fmap@, nor can we make a @Functor@ instance of+-- @PartialFun a@.++pFirst :: PartialX a a' -> PartialX (a,b) (a',b)+pFirst f = uncurry pair . first f . unpair++pSecond :: PartialX b b' -> PartialX (a,b) (a,b')+pSecond g = uncurry pair . second g . unpair++-- The following is not quite equivalent, since mappend doesn't commute.+-- +-- pSecond g ab = pUnSnd (g b) `mappend` pUnFst a+-- where (a,b) = dsPPair ab+++-- TODO: DeepArrow instance for PartialFun (perhaps in the DeepArrow+-- library) . Some methods are easy, and some hard or impossible.
+ src/Data/RefMonad.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}+-- -- For ghc 6.6 compatibility+-- {-# OPTIONS -fglasgow-exts #-}++----------------------------------------------------------------------+-- |+-- Module : Data.RefMonad+-- Copyright : (c) Conal Elliott 2007+-- License : BSD3+-- +-- Maintainer : conal@conal.net+-- Stability : experimental+-- Portability : MPTC+-- +-- Monads with references, taken from John Hughes's "Global Variables in+-- Haskell" (<http://citeseer.ist.psu.edu/473734.html>).+-- +++----------------------------------------------------------------------++module Data.RefMonad (RefMonad(..), modifyRef) where++import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import Data.STRef (STRef, newSTRef, readSTRef, writeSTRef)+import Control.Monad.ST (ST)++-------------------------------------------------------------------------------++-- | Class of monads with references.+class Monad m => RefMonad m r | m -> r, r -> m where+ newRef :: a -> m (r a)+ readRef :: r a -> m a+ writeRef :: r a -> a -> m ()++instance RefMonad IO IORef where+ newRef = newIORef+ readRef = readIORef+ writeRef = writeIORef++instance RefMonad (ST s) (STRef s) where+ newRef = newSTRef+ readRef = readSTRef+ writeRef = writeSTRef++-- | Change the contents of a ref+modifyRef :: RefMonad m r => r a -> (a -> a) -> m ()+modifyRef ref f = readRef ref >>= writeRef ref . f
+ src/Data/Title.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE FlexibleInstances, OverlappingInstances, TypeOperators, TypeSynonymInstances #-}+-- -- For ghc 6.6 compatibility+-- {-# OPTIONS -fglasgow-exts -fallow-overlapping-instances #-}++----------------------------------------------------------------------+-- |+-- Module : Data.Title+-- Copyright : (c) Conal Elliott 2007+-- License : BSD3+-- +-- Maintainer : conal@conal.net+-- Stability : experimental+-- Portability : portable+-- +-- Generic titling (labeling).+----------------------------------------------------------------------++module Data.Title (Title(..),Title_f(..)) where++import Control.Compose (Flip(..),inFlip,(:.),inO)++-- | Provide a title on a value. If you can title polymorphically, please+-- instantiate 'Title_f' instead of Title. Then you'll automatically+-- get a 'Title' for each type instance, thanks to this rule.+-- +-- @+-- instance Title_f f => Title (f a) where title = title_f+-- @+-- +-- To handle ambiguity for types like @([] Char)@ -- aka 'String', this+-- module is compiled with @OverlappingInstances@ and+-- @UndecidableInstances@. The more specific instance (yours) wins.+-- +-- In defining your instance, you might want to use the String instance,+-- e.g., @title ttl \"\"@.+class Title u where title :: String -> u -> u++-- Polymorphic version of 'Title'. See 'Title' doc.+class Title_f f where+ -- | 'title' for all applications of @f@+ title_f :: String -> f a -> f a++instance Title_f g => Title_f (g :. f) where title_f str = inO (title_f str)++instance Title_f f => Title (f a) where title = title_f++instance Title String where+ title ttl str = (ttl ++ suffix ++ str)+ where+ suffix | null ttl || final `elem` " \n" = ""+ | final `elem` ".?:" = " "+ | otherwise = ": "+ where+ final = last ttl++instance Title_f IO where+ title_f ttl = (putStr (title ttl "") >> )++instance Title b => Title (a -> b) where+ title str f = title str . f++-- Combining the two previous instances+instance Title o => Title_f (Flip (->) o) where+ title_f str = inFlip (title str)++-- Equivalently,+-- +-- title_f str (Flip snk) = Flip (title str snk)