diff --git a/CHANGES b/CHANGES --- a/CHANGES +++ b/CHANGES @@ -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 diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -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 diff --git a/README b/README --- a/README +++ b/README @@ -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 diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -1,3 +1,3 @@ -#!/usr/bin/env runhaskell -> import Distribution.Simple +#!/usr/bin/env runhaskell +> import Distribution.Simple > main = defaultMain diff --git a/TypeCompose.cabal b/TypeCompose.cabal --- a/TypeCompose.cabal +++ b/TypeCompose.cabal @@ -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: + composition, as well as some modules who haven't yet found a home. . - * Use of TypeCompose in Phooey: + Please see the project wiki page: . 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 diff --git a/src/Control/Compose.hs b/src/Control/Compose.hs --- a/src/Control/Compose.hs +++ b/src/Control/Compose.hs @@ -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\" -- ---------------------------------------------------------------------- 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" (). +-- +-- @ +-- 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 +-- () +-- 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 " + diff --git a/src/Control/DataDriven.hs b/src/Control/DataDriven.hs deleted file mode 100644 --- a/src/Control/DataDriven.hs +++ /dev/null @@ -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 - diff --git a/src/Control/Instances.hs b/src/Control/Instances.hs --- a/src/Control/Instances.hs +++ b/src/Control/Instances.hs @@ -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 diff --git a/src/Data/Bijection.hs b/src/Data/Bijection.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bijection.hs @@ -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/, +-- . +-- +-- +---------------------------------------------------------------------- + +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 diff --git a/src/Data/CxMonoid.hs b/src/Data/CxMonoid.hs new file mode 100644 --- /dev/null +++ b/src/Data/CxMonoid.hs @@ -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 diff --git a/src/Data/Lambda.hs b/src/Data/Lambda.hs new file mode 100644 --- /dev/null +++ b/src/Data/Lambda.hs @@ -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 +instance Unlambda Endo Endo where + fres = inEndo $ (($) undefined) . (. const) + +instance Colambda Endo where + cores = inEndo (.) + diff --git a/src/Data/Pair.hs b/src/Data/Pair.hs new file mode 100644 --- /dev/null +++ b/src/Data/Pair.hs @@ -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" + +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 diff --git a/src/Data/Partial.hs b/src/Data/Partial.hs new file mode 100644 --- /dev/null +++ b/src/Data/Partial.hs @@ -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]: +-- [Solution]: +-- +-- 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. diff --git a/src/Data/RefMonad.hs b/src/Data/RefMonad.hs new file mode 100644 --- /dev/null +++ b/src/Data/RefMonad.hs @@ -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" (). +-- + + +---------------------------------------------------------------------- + +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 diff --git a/src/Data/Title.hs b/src/Data/Title.hs new file mode 100644 --- /dev/null +++ b/src/Data/Title.hs @@ -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)