regular 0.1 → 0.2
raw patch · 20 files changed
+1390/−433 lines, 20 files
Files
- CREDITS +24/−0
- ChangeLog +10/−0
- examples/Test.hs +39/−24
- regular.cabal +19/−9
- src/Generics/Regular.hs +96/−7
- src/Generics/Regular/Base.hs +12/−1
- src/Generics/Regular/Constructor.hs +2/−0
- src/Generics/Regular/Functions.hs +37/−323
- src/Generics/Regular/Functions/ConNames.hs +57/−0
- src/Generics/Regular/Functions/Crush.hs +70/−0
- src/Generics/Regular/Functions/Eq.hs +53/−0
- src/Generics/Regular/Functions/Fold.hs +182/−0
- src/Generics/Regular/Functions/GMap.hs +59/−0
- src/Generics/Regular/Functions/LR.hs +99/−0
- src/Generics/Regular/Functions/Read.hs +197/−0
- src/Generics/Regular/Functions/Seq.hs +87/−0
- src/Generics/Regular/Functions/Show.hs +82/−0
- src/Generics/Regular/Functions/Zip.hs +71/−0
- src/Generics/Regular/Selector.hs +20/−0
- src/Generics/Regular/TH.hs +174/−69
+ CREDITS view
@@ -0,0 +1,24 @@+Credits for regular+===================++This is a list of those who have contributed to the research, concept, code,+and/or other issues of the regular library.++Research and Code+-----------------++* Thomas van Noort+* Alexey Rodriguez+* Stefan Holdermans+* Johan Jeuring+* Bastiaan Heeren++Ideas and Support+-----------------++* Thomas van Noort+* José Pedro Magalhães+* Andres Löh+* Rui Barbosa+* Erik Hesselink+* Sebastiaan Visser
+ ChangeLog view
@@ -0,0 +1,10 @@+version 0.2:+ - Separated generic functions per modules+ - Added generic unfold+ - Added record selectors+ - Improved generic show, added showsPrec+ - Added generic read+ - Added generic deep seq+ - Added constructor names++version 0.1: initial release
examples/Test.hs view
@@ -6,8 +6,12 @@ module Test where import Generics.Regular+import Generics.Regular.Functions+import qualified Generics.Regular.Functions.Show as G+import qualified Generics.Regular.Functions.Read as G --- * Datatype representing logical expressions++-- Datatype representing logical expressions data Logic = Var String | Logic :->: Logic -- implication | Logic :<->: Logic -- equivalence@@ -18,42 +22,53 @@ | F -- false deriving Show --- * Instantiating Regular for Logic using TH--- ** Constructors-$(deriveConstructors ''Logic)---- ** Functor encoding and 'Regular' instance-$(deriveRegular ''Logic "PFLogic")+-- Instantiating Regular for Logic using TH+$(deriveAll ''Logic "PFLogic") type instance PF Logic = PFLogic --- * Example logical expressions+-- Example logical expressions l1, l2, l3 :: Logic l1 = Var "p" l2 = Not l1 l3 = l1 :->: l2 --- * Testing flattening+-- Testing flattening ex0 :: [Logic]-ex0 = flatten (from l3)+ex0 = flattenr (from l3) --- * Testing generic equality+-- Testing generic equality ex1, ex2 :: Bool-ex1 = geq l3 l3-ex2 = geq l3 l2+ex1 = eq l3 l3+ex2 = eq l3 l2 --- * Testing generic show+-- Testing generic show ex3 :: String-ex3 = gshow l3 ""+ex3 = G.show l3 --- * Testing value generation-ex4, ex5 :: Logic-ex4 = left-ex5 = right+-- Testing generic read+ex4 :: Logic+ex4 = G.read ex3 --- * Testing folding-ex6 :: (String -> Bool) -> Logic -> Bool-ex6 env = fold (env & impl & (==) & (&&) & (||) & not & True & False)- where impl p q = not p || q+-- Testing value generation+ex5, ex6 :: Logic+ex5 = left+ex6 = right +-- Testing folding ex7 :: Bool-ex7 = ex6 (\_ -> False) l3+ex7 = fold (alg (\_ -> False)) l3 where+ alg env = (env & impl & (==) & (&&) & (||) & not & True & False)+ impl p q = not p || q++-- Testing unfolding+ex8 :: Int -> Logic+ex8 n = unfold alg n where+ alg :: CoAlgebra Logic Int+ alg n | odd n || n <= 0 = Left ""+ | even n = Right (Left (n-1,n-2))++-- Testing conNames+ex9 = conNames (undefined :: Logic)++-- Testing deep seq+ex10 = gdseq (Not (T :->: (error "deep seq works"))) ()
regular.cabal view
@@ -1,5 +1,5 @@ name: regular-version: 0.1+version: 0.2 synopsis: Generic programming library for regular datatypes. description: @@ -18,31 +18,41 @@ More information about this library can be found at <http://www.cs.uu.nl/wiki/GenericProgramming/Regular>. .- \[1] <http://hackage.haskell.org/cgi-bin/hackage-scripts/package/multirec>+ \[1] <http://hackage.haskell.org/package/multirec> category: Generics copyright: (c) 2009 Universiteit Utrecht license: BSD3 license-file: LICENSE-author: Thomas van Noort,- Alexey Rodriguez,- Stefan Holdermans,- Johan Jeuring,- Bastiaan Heeren+author: Jose Pedro Magalhaes maintainer: generics@haskell.org stability: experimental build-type: Custom cabal-version: >= 1.2.1 tested-with: GHC == 6.10.1 extra-source-files: examples/Test.hs-+ ChangeLog+ CREDITS library hs-source-dirs: src exposed-modules: Generics.Regular Generics.Regular.Base- Generics.Regular.Functions Generics.Regular.Constructor+ Generics.Regular.Selector Generics.Regular.TH+ + Generics.Regular.Functions+ Generics.Regular.Functions.ConNames+ Generics.Regular.Functions.Crush+ Generics.Regular.Functions.Eq+ Generics.Regular.Functions.Fold+ Generics.Regular.Functions.GMap+ Generics.Regular.Functions.LR+ Generics.Regular.Functions.Read+ Generics.Regular.Functions.Seq+ Generics.Regular.Functions.Show+ Generics.Regular.Functions.Zip+ build-depends: base >= 4.0 && < 5, template-haskell >= 2.2 && < 2.4 ghc-options: -Wall
src/Generics/Regular.hs view
@@ -24,20 +24,109 @@ -- > | T -- true -- > | F -- false ----- An instance of @Regular@ is derived with TH by invoking:+-- First we import the relevant modules: ----- > $(deriveConstructors ''Logic)--- > $(deriveRegular ''Logic "PFLogic")--- > type instance PF Logic = PFLogic+-- > import Generics.Regular+-- > import Generics.Regular.Functions+-- > import qualified Generics.Regular.Functions.Show as G+-- > import qualified Generics.Regular.Functions.Read as G+--+-- An instance of @Regular@ can be derived automatically with TH by invoking:+--+-- > $(deriveAll ''Logic "PFLogic")+-- > type instance PF Logic = PFLogic+--+-- We define some logic expressions:+--+-- > l1, l2, l3 :: Logic+-- > l1 = Var "p"+-- > l2 = Not l1+-- > l3 = l1 :->: l2+--+-- And now we can use all of the generic functions. Flattening:+--+-- > ex0 :: [Logic]+-- > ex0 = flattenr (from l3)+-- >+-- > > [Var "p",Not (Var "p")]+--+-- Generic equality:+--+-- > ex1, ex2 :: Bool+-- > ex1 = eq l3 l3+-- >+-- > > True+-- >+-- >+-- > ex2 = eq l3 l2+-- >+-- > > False+--+-- Generic show:+--+-- > ex3 :: String+-- > ex3 = G.show l3+-- >+-- > > "((:->:) (Var \"p\") (Not (Var \"p\")))"+--+-- Generic read:+--+-- > ex4 :: Logic+-- > ex4 = G.read ex3+-- >+-- > > Var "p" :->: Not (Var "p")+--+-- Value generation:+--+-- > ex5, ex6 :: Logic+-- > ex5 = left+-- >+-- > > Var ""+-- >+-- >+-- > ex6 = right+-- >+-- > > F+--+-- Folding:+--+-- > ex7 :: Bool+-- > ex7 = fold (alg (\_ -> False)) l3 where+-- > alg env = (env & impl & (==) & (&&) & (||) & not & True & False)+-- > impl p q = not p || q+-- >+-- > > True+--+-- Unfolding:+--+-- > ex8 :: Logic+-- > ex8 = unfold alg 8 where+-- > alg :: CoAlgebra Logic Int+-- > alg n | odd n || n <= 0 = Left ""+-- > | even n = Right (Left (n-1,n-2))+-- >+-- > > Var "" :->: (Var "" :->: (Var "" :->: (Var "" :->: Var "")))+--+-- Constructor names:+--+-- > ex9 = conNames (undefined :: Logic)+-- >+-- > > ["Var",":->:",":<->:",":&&:",":||:","Not","T","F"]+--+-- Deep seq:+--+-- > ex10 = gdseq (Not (T :->: (error "deep seq works"))) ()+-- >+-- > > *** Exception: deep seq works -- ----------------------------------------------------------------------------- module Generics.Regular ( module Generics.Regular.Base,- module Generics.Regular.Functions,- module Generics.Regular.TH+ module Generics.Regular.TH,+ module Generics.Regular.Functions ) where import Generics.Regular.Base-import Generics.Regular.Functions import Generics.Regular.TH+import Generics.Regular.Functions
src/Generics/Regular/Base.hs view
@@ -24,7 +24,10 @@ (:+:)(..), (:*:)(..), C(..),+ S(..),+ Constructor(..), Fixity(..), Associativity(..),+ Selector(..), -- * Fixed-point type Fix (..),@@ -35,6 +38,7 @@ ) where import Generics.Regular.Constructor+import Generics.Regular.Selector -----------------------------------------------------------------------------@@ -59,6 +63,9 @@ -- | Structure type to store the name of a constructor. data C c f r = C { unC :: f r } +-- | Structure type to store the name of a record selector.+data S l f r = S { unS :: f r }+ infixr 6 :+: infixr 7 :*: @@ -67,7 +74,7 @@ ----------------------------------------------------------------------------- -- | The well-known fixed-point type.-newtype Fix f = In (f (Fix f))+newtype Fix f = In { out :: f (Fix f) } -----------------------------------------------------------------------------@@ -111,3 +118,7 @@ instance Functor f => Functor (C c f) where fmap f (C r) = C (fmap f r)++instance Functor f => Functor (S c f) where+ fmap f (S r) = S (fmap f r)+
src/Generics/Regular/Constructor.hs view
@@ -26,6 +26,8 @@ conName :: t c (f :: * -> *) r -> String conFixity :: t c (f :: * -> *) r -> Fixity conFixity = const Prefix+ conIsRecord :: t c (f :: * -> *) r -> Bool+ conIsRecord = const False -- | Datatype to represent the fixity of a constructor. An infix declaration -- directly corresponds to an application of 'Infix'.
src/Generics/Regular/Functions.hs view
@@ -13,332 +13,46 @@ -- Stability : experimental -- Portability : non-portable ----- Summary: Generic functionality for regular dataypes: mapM, flatten, zip,--- equality, show, value generation and fold.+-- Summary: All of the generic functionality for regular dataypes: mapM, +-- flatten, zip, equality, value generation, fold and unfold.+-- Generic show ("Generics.Regular.Functions.Show") and generic read +-- ("Generics.Regular.Functions.Read") are not exported to prevent clashes+-- with @Prelude@. ----------------------------------------------------------------------------- module Generics.Regular.Functions (-- -- * Functorial map function- Functor (..), - -- * Monadic functorial map function- GMap (..),- - -- * Crush right functions- CrushR (..),- flatten,-- -- * Zip functions- Zip (..),- fzip,- fzip',-- -- * Equality function- geq,-- -- * Show function- GShow (..),- gshow,- - -- * Functions for generating values that are different on top-level- LRBase (..),- LR (..),- left,- right,- - -- * Generic folding- Alg, Algebra,- Fold, alg,- fold,- (&) --) where--import Control.Monad--import Generics.Regular.Base----------------------------------------------------------------------------------- Monadic functorial map function.---------------------------------------------------------------------------------- | The @GMap@ class defines a monadic functorial map.-class GMap f where- fmapM :: Monad m => (a -> m b) -> f a -> m (f b)--instance GMap I where- fmapM f (I r) = liftM I (f r)--instance GMap (K a) where- fmapM _ (K x) = return (K x)--instance GMap U where- fmapM _ U = return U--instance (GMap f, GMap g) => GMap (f :+: g) where- fmapM f (L x) = liftM L (fmapM f x)- fmapM f (R x) = liftM R (fmapM f x)--instance (GMap f, GMap g) => GMap (f :*: g) where- fmapM f (x :*: y) = liftM2 (:*:) (fmapM f x) (fmapM f y)--instance GMap f => GMap (C c f) where- fmapM f (C x) = liftM C (fmapM f x)----------------------------------------------------------------------------------- CrushR functions.---------------------------------------------------------------------------------- | The @CrushR@ class defines a right-associative crush on functorial values.-class CrushR f where- crushr :: (a -> b -> b) -> b -> f a -> b--instance CrushR I where- crushr op e (I x) = x `op` e--instance CrushR (K a) where- crushr _ e _ = e--instance CrushR U where- crushr _ e _ = e--instance (CrushR f, CrushR g) => CrushR (f :+: g) where- crushr op e (L x) = crushr op e x- crushr op e (R y) = crushr op e y--instance (CrushR f, CrushR g) => CrushR (f :*: g) where- crushr op e (x :*: y) = crushr op (crushr op e y) x--instance CrushR f => CrushR (C c f) where- crushr op e (C x) = crushr op e x---- | Flatten a structure by collecting all the elements present.-flatten :: CrushR f => f a -> [a]-flatten = crushr (:) []----------------------------------------------------------------------------------- Zip functions.---------------------------------------------------------------------------------- | The @Zip@ class defines a monadic zip on functorial values.-class Zip f where- fzipM :: Monad m => (a -> b -> m c) -> f a -> f b -> m (f c)--instance Zip I where- fzipM f (I x) (I y) = liftM I (f x y)--instance Eq a => Zip (K a) where- fzipM _ (K x) (K y) - | x == y = return (K x)- | otherwise = fail "fzipM: structure mismatch"--instance Zip U where- fzipM _ U U = return U--instance (Zip f, Zip g) => Zip (f :+: g) where- fzipM f (L x) (L y) = liftM L (fzipM f x y)- fzipM f (R x) (R y) = liftM R (fzipM f x y)- fzipM _ _ _ = fail "fzipM: structure mismatch"--instance (Zip f, Zip g) => Zip (f :*: g) where- fzipM f (x1 :*: y1) (x2 :*: y2) = - liftM2 (:*:) (fzipM f x1 x2)- (fzipM f y1 y2)--instance Zip f => Zip (C c f) where- fzipM f (C x) (C y) = liftM C (fzipM f x y)---- | Functorial zip with a non-monadic function, resulting in a monadic value.-fzip :: (Zip f, Monad m) => (a -> b -> c) -> f a -> f b -> m (f c)-fzip f = fzipM (\x y -> return (f x y))---- | Partial functorial zip with a non-monadic function.-fzip' :: Zip f => (a -> b -> c) -> f a -> f b -> f c-fzip' f x y = maybe (error "fzip': structure mismatch") id (fzip f x y)----------------------------------------------------------------------------------- Equality function.---------------------------------------------------------------------------------- | Equality on values based on their structural representation.-geq :: (b ~ PF a, Regular a, CrushR b, Zip b) => a -> a -> Bool-geq x y = maybe False (crushr (&&) True) (fzip geq (from x) (from y))----------------------------------------------------------------------------------- Show function.---------------------------------------------------------------------------------- | The @GShow@ class defines a show on values.-class GShow f where- gshowf :: (a -> ShowS) -> f a -> ShowS--instance GShow I where- gshowf f (I r) = f r--instance Show a => GShow (K a) where- gshowf _ (K x) = shows x--instance GShow U where- gshowf _ U = id--instance (GShow f, GShow g) => GShow (f :+: g) where- gshowf f (L x) = gshowf f x- gshowf f (R x) = gshowf f x--instance (GShow f, GShow g) => GShow (f :*: g) where- gshowf f (x :*: y) = gshowf f x . showChar ' ' . gshowf f y---instance (Constructor c, GShow f) => GShow (C c f) where- gshowf f cx@(C x) = - showParen True (showString (conName cx) . showChar ' ' . gshowf f x)---gshow :: (Regular a, GShow (PF a)) => a -> ShowS-gshow x = gshowf gshow (from x)---------------------------------------------------------------------------------- Functions for generating values that are different on top-level.---------------------------------------------------------------------------------- | The @LRBase@ class defines two functions, @leftb@ and @rightb@, which --- should produce different values.-class LRBase a where- leftb :: a- rightb :: a--instance LRBase Int where- leftb = 0- rightb = 1--instance LRBase Integer where- leftb = 0- rightb = 1--instance LRBase Char where- leftb = 'L'- rightb = 'R'- -instance LRBase a => LRBase [a] where- leftb = []- rightb = [error "Should never be inspected"]---- | The @LR@ class defines two functions, @leftf@ and @rightf@, which should --- produce different functorial values.-class LR f where- leftf :: a -> f a- rightf :: a -> f a--instance LR I where- leftf x = I x- rightf x = I x--instance LRBase a => LR (K a) where- leftf _ = K leftb- rightf _ = K rightb--instance LR U where- leftf _ = U- rightf _ = U--instance (LR f, LR g) => LR (f :+: g) where- leftf x = L (leftf x)- rightf x = R (rightf x)--instance (LR f, LR g) => LR (f :*: g) where- leftf x = leftf x :*: leftf x- rightf x = rightf x :*: rightf x--instance LR f => LR (C c f) where- leftf x = C (leftf x)- rightf x = C (rightf x)---- | Produces a value which should be different from the value returned by --- @right@.-left :: (Regular a, LR (PF a)) => a-left = to (leftf left)---- | Produces a value which should be different from the value returned by --- @left@.-right :: (Regular a, LR (PF a)) => a-right = to (rightf right)----------------------------------------------------------------------------------- Folds--------------------------------------------------------------------------------type family Alg (f :: (* -> *)) - (r :: *) -- result type- :: *---- | For a constant, we take the constant value to a result.-type instance Alg (K a) r = a -> r---- | For a unit, no arguments are available.-type instance Alg U r = r---- | For an identity, we turn the recursive result into a final result.-type instance Alg I r = r -> r---- | For a sum, the algebra is a pair of two algebras.-type instance Alg (f :+: g) r = (Alg f r, Alg g r)---- | For a product where the left hand side is a constant, we--- take the value as an additional argument.-type instance Alg (K a :*: g) r = a -> Alg g r---- | For a product where the left hand side is an identity, we--- take the recursive result as an additional argument.-type instance Alg (I :*: g) r = r -> Alg g r---- | Constructors are ignored.-type instance Alg (C c f) r = Alg f r---type Algebra a r = Alg (PF a) r---- | The class fold explains how to convert an algebra--- 'Alg' into a function from functor to result.-class Fold (f :: * -> *) where- alg :: Alg f r -> f r -> r--instance Fold (K a) where- alg f (K x) = f x--instance Fold U where- alg f U = f--instance Fold I where- alg f (I x) = f x--instance (Fold f, Fold g) => Fold (f :+: g) where- alg (f, _) (L x) = alg f x- alg (_, g) (R x) = alg g x--instance (Fold g) => Fold (K a :*: g) where- alg f (K x :*: y) = alg (f x) y--instance (Fold g) => Fold (I :*: g) where- alg f (I x :*: y) = alg (f x) y--instance (Fold f) => Fold (C c f) where- alg f (C x) = alg f x---- | Fold with convenient algebras.-fold :: (Regular a, Fold (PF a), Functor (PF a))- => Algebra a r -> a -> r-fold f = alg f . fmap (\x -> fold f x) . from+ -- * Constructor names+ module Generics.Regular.Functions.ConNames,+ + -- * Crush+ module Generics.Regular.Functions.Crush,+ + -- * Equality+ module Generics.Regular.Functions.Eq,+ + -- * Generic folding+ module Generics.Regular.Functions.Fold,+ + -- * Functorial map+ module Generics.Regular.Functions.GMap,+ + -- * Generating values that are different on top-level+ module Generics.Regular.Functions.LR,+ + -- * Deep seq+ module Generics.Regular.Functions.Seq,+ + -- * Zipping+ module Generics.Regular.Functions.Zip --- Construction of algebras-infixr 5 &+ ) where --- | For constructing algebras it is helpful to use this pairing combinator.-(&) :: a -> b -> (a, b)-(&) = (,)+import Generics.Regular.Functions.ConNames+import Generics.Regular.Functions.Crush+import Generics.Regular.Functions.Eq+import Generics.Regular.Functions.Fold+import Generics.Regular.Functions.GMap+import Generics.Regular.Functions.LR+import Generics.Regular.Functions.Seq+import Generics.Regular.Functions.Zip
+ src/Generics/Regular/Functions/ConNames.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}++-----------------------------------------------------------------------------+-- |+-- Module : Generics.Regular.Functions.ConNames+-- Copyright : (c) 2009 Universiteit Utrecht+-- License : BSD3+--+-- Maintainer : generics@haskell.org+-- Stability : experimental+-- Portability : non-portable+--+-- Summary: Return the name of all the constructors of a type.+--+-----------------------------------------------------------------------------++module Generics.Regular.Functions.ConNames (++ -- * Functionality for retrieving the names of all the possible contructors+ -- of a type+ ConNames(..), conNames++ ) where++import Generics.Regular.Base++class ConNames f where + hconNames :: f a -> [String]++instance (ConNames f, ConNames g) => ConNames (f :+: g) where+ hconNames (_ :: (f :+: g) a) = hconNames (undefined :: f a) +++ hconNames (undefined :: g a)+ +instance (ConNames f, Constructor c) => ConNames (C c f) where+ hconNames (x :: (C c f) a) = [conName x]++instance (ConNames f, ConNames g) => ConNames (f :*: g) where+ hconNames _ = []++instance ConNames I where+ hconNames _ = []++instance ConNames U where+ hconNames _ = []++instance ConNames (K a) where+ hconNames _ = []++-- | Return the name of all the constructors of the type of the given term.+conNames :: (Regular a, ConNames (PF a)) => a -> [String]+conNames x = hconNames (undefined `asTypeOf` (from x))++--------------------------------------------------------------------------------
+ src/Generics/Regular/Functions/Crush.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE TypeOperators #-}++-----------------------------------------------------------------------------+-- |+-- Module : Generics.Regular.Functions.Crush+-- Copyright : (c) 2008 Universiteit Utrecht+-- License : BSD3+--+-- Maintainer : generics@haskell.org+-- Stability : experimental+-- Portability : non-portable+--+-- Summary: Generic crush.+-----------------------------------------------------------------------------++module Generics.Regular.Functions.Crush (++ -- * Crush functions+ Crush (..),+ flattenl, flattenr, crushr, crushl++) where++import Generics.Regular.Base+++-----------------------------------------------------------------------------+-- Crush functions.+-----------------------------------------------------------------------------++-- | Associativity of the binary operator used for 'crush'+data Assoc = AssocLeft -- ^ Left-associative+ | AssocRight -- ^ Right-associative+++-- | The @Crush@ class defines a right-associative crush on functorial values.+class Crush f where+ crush :: Assoc -> (a -> b -> b) -> b -> f a -> b++instance Crush I where+ crush _ op e (I x) = x `op` e++instance Crush (K a) where+ crush _ _ e _ = e++instance Crush U where+ crush _ _ e _ = e++instance (Crush f, Crush g) => Crush (f :+: g) where+ crush asc op e (L x) = crush asc op e x+ crush asc op e (R y) = crush asc op e y++instance (Crush f, Crush g) => Crush (f :*: g) where+ crush asc@AssocRight op e (x :*: y) = crush asc op (crush asc op e y) x+ crush asc@AssocLeft op e (x :*: y) = crush asc op (crush asc op e x) y++instance Crush f => Crush (C c f) where+ crush asc op e (C x) = crush asc op e x++instance Crush f => Crush (S s f) where+ crush asc op e (S x) = crush asc op e x++-- | Flatten a structure by collecting all the elements present.+flattenr, flattenl :: Crush f => f a -> [a]+flattenr = crushr (:) []+flattenl = crushl (:) []++crushr, crushl :: Crush f => (a -> b -> b) -> b -> f a -> b+crushr = crush AssocRight+crushl = crush AssocLeft
+ src/Generics/Regular/Functions/Eq.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeOperators #-}++-----------------------------------------------------------------------------+-- |+-- Module : Generics.Regular.Functions.Eq+-- Copyright : (c) 2008 Universiteit Utrecht+-- License : BSD3+--+-- Maintainer : generics@haskell.org+-- Stability : experimental+-- Portability : non-portable+--+-- Summary: Generic equality.+-----------------------------------------------------------------------------++module Generics.Regular.Functions.Eq (+ + -- * Generic equality+ Eq(..), eq+ +) where++import Generics.Regular.Base+import Prelude hiding (Eq)+import qualified Prelude as P (Eq)+++class Eq f where+ eqf :: (a -> a -> Bool) -> f a -> f a -> Bool++instance Eq I where+ eqf f (I x) (I y) = f x y++instance P.Eq a => Eq (K a) where+ eqf _ (K x) (K y) = x == y++instance Eq U where+ eqf _ U U = True++instance (Eq f, Eq g) => Eq (f :+: g) where+ eqf f (L x) (L y) = eqf f x y+ eqf f (R x) (R y) = eqf f x y+ eqf _ _ _ = False++instance (Eq f, Eq g) => Eq (f :*: g) where+ eqf f (x1 :*: y1) (x2 :*: y2) = eqf f x1 x2 && eqf f y1 y2++instance Eq f => Eq (C c f) where+ eqf f (C x) (C y) = eqf f x y++eq :: (Regular a, Eq (PF a)) => a -> a -> Bool+eq x y = eqf eq (from x) (from y)
+ src/Generics/Regular/Functions/Fold.hs view
@@ -0,0 +1,182 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}++-----------------------------------------------------------------------------+-- |+-- Module : Generics.Regular.Functions.Fold+-- Copyright : (c) 2008 Universiteit Utrecht+-- License : BSD3+--+-- Maintainer : generics@haskell.org+-- Stability : experimental+-- Portability : non-portable+--+-- Summary: Generic folding and unfolding.+-----------------------------------------------------------------------------++module Generics.Regular.Functions.Fold (++ -- * Generic folding+ Alg, Algebra,+ Fold, alg,+ fold,+ + -- * Generic unfolding+ CoAlg, CoAlgebra,+ Unfold, coalg,+ unfold,+ + -- * Construction of algebras+ (&) ++) where++import Generics.Regular.Base+++-----------------------------------------------------------------------------+-- Folds+-----------------------------------------------------------------------------++type family Alg (f :: (* -> *)) + (r :: *) -- result type+ :: *++-- | For a constant, we take the constant value to a result.+type instance Alg (K a) r = a -> r++-- | For a unit, no arguments are available.+type instance Alg U r = r++-- | For an identity, we turn the recursive result into a final result.+type instance Alg I r = r -> r++-- | For a sum, the algebra is a pair of two algebras.+type instance Alg (f :+: g) r = (Alg f r, Alg g r)++-- | For a product where the left hand side is a constant, we+-- take the value as an additional argument.+type instance Alg ( K a :*: g) r = a -> Alg g r+type instance Alg (S s (K a) :*: g) r = a -> Alg g r++-- | For a product where the left hand side is an identity, we+-- take the recursive result as an additional argument.+type instance Alg (I :*: g) r = r -> Alg g r++-- | Constructors are ignored.+type instance Alg (C c f) r = Alg f r++-- | Selectors are ignored.+type instance Alg (S s f) r = Alg f r+++type Algebra a r = Alg (PF a) r++-- | The class fold explains how to convert an algebra+-- 'Alg' into a function from functor to result.+class Fold (f :: * -> *) where+ alg :: Alg f r -> f r -> r++instance Fold (K a) where+ alg f (K x) = f x++instance Fold U where+ alg f U = f++instance Fold I where+ alg f (I x) = f x++instance (Fold f, Fold g) => Fold (f :+: g) where+ alg (f, _) (L x) = alg f x+ alg (_, g) (R x) = alg g x++instance (Fold g) => Fold (K a :*: g) where+ alg f (K x :*: y) = alg (f x) y++instance (Fold g) => Fold (I :*: g) where+ alg f (I x :*: y) = alg (f x) y++instance (Fold f) => Fold (C c f) where+ alg f (C x) = alg f x++instance (Fold f) => Fold (S s f) where+ alg f (S x) = alg f x++-- | Fold with convenient algebras.+fold :: (Regular a, Fold (PF a), Functor (PF a))+ => Algebra a r -> a -> r+fold f = alg f . fmap (\x -> fold f x) . from++-----------------------------------------------------------------------------+-- Unfolds+-----------------------------------------------------------------------------++type family CoAlg (f :: (* -> *)) + (s :: *) -- seed type+ :: *++-- | For a constant, we produce a constant value as a result.+type instance CoAlg (K a) s = a++-- | For an identity, we produce a new seed to create the recursive result.+type instance CoAlg I s = s++-- | Units can only produce units, so we use the singleton type to encode the+-- lack of choice.+type instance CoAlg U s = ()++-- | For a sum, the coalgebra produces either the left or the right side. +type instance CoAlg (f :+: g) s = Either (CoAlg f s) (CoAlg g s)++-- | For a produt, the coalgebra is a pair of the two arms.+type instance CoAlg (f :*: g) s = (CoAlg f s, CoAlg g s)++-- | Constructors are ignored.+type instance CoAlg (C c f) s = CoAlg f s++-- | Selectors are ignored.+type instance CoAlg (S r f) s = CoAlg f s++type CoAlgebra a s = s -> CoAlg (PF a) s++-- | The class unfold explains how to convert a coalgebra 'CoAlg' and a seed+-- into a representation.+class Unfold (f :: * -> *) where+ coalg :: (s -> a) -> CoAlg f s -> f a++instance Unfold (K a) where+ coalg _ = K++instance Unfold I where+ coalg r a = I (r a)+ +instance Unfold U where+ coalg _ _ = U++instance (Unfold f, Unfold g) => Unfold (f :+: g) where+ coalg r (Left c) = L (coalg r c)+ coalg r (Right c) = R (coalg r c)++instance (Unfold f, Unfold g) => Unfold (f :*: g) where+ coalg r (c, g) = coalg r c :*: coalg r g++instance Unfold f => Unfold (C c f) where+ coalg r = C . coalg r++instance Unfold f => Unfold (S s f) where+ coalg r = S . coalg r++unfold :: (Unfold (PF a), Regular a) => CoAlgebra a s -> s -> a+unfold a = to . coalg (unfold a) . a++-----------------------------------------------------------------------------++-- Construction of algebras+infixr 5 &++-- | For constructing algebras it is helpful to use this pairing combinator.+(&) :: a -> b -> (a, b)+(&) = (,)+
+ src/Generics/Regular/Functions/GMap.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE TypeOperators #-}++-----------------------------------------------------------------------------+-- |+-- Module : Generics.Regular.Functions.GMap+-- Copyright : (c) 2008 Universiteit Utrecht+-- License : BSD3+--+-- Maintainer : generics@haskell.org+-- Stability : experimental+-- Portability : non-portable+--+-- Summary: Monadic generic map.+-----------------------------------------------------------------------------++module Generics.Regular.Functions.GMap (++ -- * Functorial map function+ Functor (..),+ + -- * Monadic functorial map function+ GMap (..)++) where++import Control.Monad++import Generics.Regular.Base+++-----------------------------------------------------------------------------+-- Monadic functorial map function.+-----------------------------------------------------------------------------++-- | The @GMap@ class defines a monadic functorial map.+class GMap f where+ fmapM :: Monad m => (a -> m b) -> f a -> m (f b)++instance GMap I where+ fmapM f (I r) = liftM I (f r)++instance GMap (K a) where+ fmapM _ (K x) = return (K x)++instance GMap U where+ fmapM _ U = return U++instance (GMap f, GMap g) => GMap (f :+: g) where+ fmapM f (L x) = liftM L (fmapM f x)+ fmapM f (R x) = liftM R (fmapM f x)++instance (GMap f, GMap g) => GMap (f :*: g) where+ fmapM f (x :*: y) = liftM2 (:*:) (fmapM f x) (fmapM f y)++instance GMap f => GMap (C c f) where+ fmapM f (C x) = liftM C (fmapM f x)++instance GMap f => GMap (S s f) where+ fmapM f (S x) = liftM S (fmapM f x)
+ src/Generics/Regular/Functions/LR.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeOperators #-}++-----------------------------------------------------------------------------+-- |+-- Module : Generics.Regular.Functions.LR+-- Copyright : (c) 2008 Universiteit Utrecht+-- License : BSD3+--+-- Maintainer : generics@haskell.org+-- Stability : experimental+-- Portability : non-portable+--+-- Summary: Generic functionality for regular dataypes: mapM, flatten, zip,+-- equality, show, value generation and fold.+-----------------------------------------------------------------------------++module Generics.Regular.Functions.LR (++ -- * Functions for generating values that are different on top-level+ LRBase (..),+ LR (..),+ left,+ right,++) where++import Generics.Regular.Base+++-----------------------------------------------------------------------------+-- Functions for generating values that are different on top-level.+-----------------------------------------------------------------------------++-- | The @LRBase@ class defines two functions, @leftb@ and @rightb@, which +-- should produce different values.+class LRBase a where+ leftb :: a+ rightb :: a++instance LRBase Int where+ leftb = 0+ rightb = 1++instance LRBase Integer where+ leftb = 0+ rightb = 1++instance LRBase Char where+ leftb = 'L'+ rightb = 'R'+ +instance LRBase a => LRBase [a] where+ leftb = []+ rightb = [rightb]++-- | The @LR@ class defines two functions, @leftf@ and @rightf@, which should +-- produce different functorial values.+class LR f where+ leftf :: a -> f a+ rightf :: a -> f a++instance LR I where+ leftf x = I x+ rightf x = I x++instance LRBase a => LR (K a) where+ leftf _ = K leftb+ rightf _ = K rightb++instance LR U where+ leftf _ = U+ rightf _ = U++instance (LR f, LR g) => LR (f :+: g) where+ leftf x = L (leftf x)+ rightf x = R (rightf x)++instance (LR f, LR g) => LR (f :*: g) where+ leftf x = leftf x :*: leftf x+ rightf x = rightf x :*: rightf x++instance LR f => LR (C c f) where+ leftf x = C (leftf x)+ rightf x = C (rightf x)++instance LR f => LR (S s f) where+ leftf x = S (leftf x)+ rightf x = S (rightf x)++-- | Produces a value which should be different from the value returned by +-- @right@.+left :: (Regular a, LR (PF a)) => a+left = to (leftf left)++-- | Produces a value which should be different from the value returned by +-- @left@.+right :: (Regular a, LR (PF a)) => a+right = to (rightf right)
+ src/Generics/Regular/Functions/Read.hs view
@@ -0,0 +1,197 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ScopedTypeVariables #-}++-----------------------------------------------------------------------------+-- |+-- Module : Generics.Regular.Functions.Read+-- Copyright : (c) 2008 Universiteit Utrecht+-- License : BSD3+--+-- Maintainer : generics@haskell.org+-- Stability : experimental+-- Portability : non-portable+--+-- Summary: Generic read. This module is not exported by +-- "Generics.Regular.Functions" to avoid clashes with "Prelude".+-----------------------------------------------------------------------------++module Generics.Regular.Functions.Read (++ -- * Read functions+ Read(..),+ read, readPrec, readsPrec++) where++-----------------------------------------------------------------------------+-- Generic read.+-----------------------------------------------------------------------------++import Generics.Regular.Base++import Data.Char+import Control.Monad+import Text.Read hiding (readsPrec, readPrec, read, Read)+import Prelude hiding (readsPrec, read, Read)+import qualified Prelude as P (readsPrec, Read)+import Text.Read.Lex+import Text.ParserCombinators.ReadPrec++-- * Count the number of terms in a product++class CountAtoms f where + countatoms :: f r -> Int++instance CountAtoms (K a) where+ countatoms _ = 1++instance CountAtoms I where+ countatoms _ = 1++instance (CountAtoms f, CountAtoms g) => CountAtoms (f :*: g) where+ countatoms (_ :: (f :*: g) r) = countatoms (undefined :: f r) + + countatoms (undefined :: g r)++instance CountAtoms f => CountAtoms (S s f) where+ countatoms (_ :: S s f r) = countatoms (undefined :: f r)++-- * Generic read++class Read f where+ hreader :: ReadPrec a -> Bool -> ReadPrec (f a)+++instance Read U where+ hreader _ _ = return U++instance (P.Read a) => Read (K a) where+ hreader _ _ = liftM K (readS_to_Prec P.readsPrec)++instance Read I where+ hreader f _ = liftM I f++instance (Read f, Read g) => Read (f :+: g) where+ hreader f r = liftM L (hreader f r) +++ liftM R (hreader f r)++instance (Read f, Read g) => Read (f :*: g) where+ hreader f r = do l' <- hreader f r+ when r $ do Punc "," <- lexP+ return ()+ r' <- hreader f r+ return (l' :*: r')++++-- Dealing with constructors+-- No arguments+instance (Constructor c) => Read (C c U) where+ hreader f _ = let constr = undefined :: C c U r+ name = conName constr+ in readCons (readNoArgsCons f name)++-- 1 argument+instance (Constructor c, Read I) => Read (C c I) where+ hreader f _ = let constr = undefined :: C c I r+ name = conName constr+ in readCons (readPrefixCons f True False name)++instance (Constructor c, Read (K a)) => Read (C c (K a)) where+ hreader f _ = let constr = undefined :: C c (K a) r+ name = conName constr+ in readCons (readPrefixCons f True False name) ++instance (Constructor c, Read (S s f)) => Read (C c (S s f)) where+ hreader f _ = let constr = undefined :: C c (K a) r+ name = conName constr+ in readCons (readPrefixCons f True True name)++-- 2 arguments or more+instance (Constructor c, CountAtoms (f :*: g), Read f, Read g) + => Read (C c (f:*:g)) where+ hreader f _ = let constr = undefined :: C c (f:*:g) r+ name = conName constr+ fixity = conFixity constr+ isRecord = conIsRecord constr+ (assoc,prc,isInfix) = case fixity of + Prefix -> (LeftAssociative, 9, False)+ Infix a p -> (a, p, True)+ nargs = countatoms (undefined :: (f :*: g) r)+ in readCons $ readPrefixCons f (not isInfix) isRecord name+ ++++ (do guard (nargs == 2)+ readInfixCons f (assoc,prc,isInfix) name+ )+++readCons :: (Constructor c) => ReadPrec (f a) -> ReadPrec (C c f a)+readCons = liftM C++readPrefixCons :: (Read f) + => ReadPrec a -> Bool -> Bool -> String -> ReadPrec (f a)+readPrefixCons f b r name = parens . prec appPrec $+ do parens (prefixConsNm name b) + step $ if r then braces (hreader f) else hreader f False+ where prefixConsNm s True = do Ident n <- lexP+ guard (s == n)+ prefixConsNm s False = do Punc "(" <-lexP+ Symbol n <- lexP+ guard (s == n)+ Punc ")" <- lexP+ return ()++braces :: (Bool -> ReadPrec a) -> ReadPrec a+braces f = do hasBraces <- try $ do {Punc "{" <- lexP; return ()}+ res <- f hasBraces+ when hasBraces $ do {Punc "}" <- lexP; return ()}+ return res+ where+ try p = (p >> return True) `mplus` return False+++readInfixCons :: (Read f, Read g)+ => ReadPrec a -> (Associativity,Int,Bool) -> String -> ReadPrec ((f :*: g) a)+readInfixCons f (asc,prc,b) name = parens . prec prc $+ do x <- {- (if asc == LeftAssociative then id else step) -} step (hreader f False)+ parens (infixConsNm name b)+ y <- (if asc == RightAssociative then id else step) (hreader f False)+ return (x :*: y)+ where infixConsNm s True = do Symbol n <- lexP+ guard (n == s) + infixConsNm s False = do Punc "`" <- lexP+ Ident n <- lexP+ guard (n == s)+ Punc "`" <- lexP+ return ()++readNoArgsCons :: ReadPrec a -> String -> ReadPrec (U a)+readNoArgsCons _ name = parens $ + do Ident n <- lexP+ guard (n == name)+ return U++appPrec :: Prec+appPrec = 10++instance (Selector s, Read f) => Read (S s f) where+ hreader f r = do when r $ do Ident n <- lexP+ guard (n == selName (undefined :: S s f a))+ Punc "=" <- lexP+ return ()+ liftM S (hreader f r)+++-- Exported functions++readPrec :: (Regular a, Read (PF a)) => ReadPrec a+readPrec = liftM to (hreader readPrec False)++readsPrec :: (Regular a, Read (PF a)) => Int -> ReadS a+readsPrec n = readPrec_to_S readPrec n++read :: (Regular a, Read (PF a)) => String -> a+read s = case [x | (x,remain) <- readsPrec 0 s , all isSpace remain] of+ [x] -> x + [ ] -> error "no parse"+ _ -> error "ambiguous parse"
+ src/Generics/Regular/Functions/Seq.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}++-----------------------------------------------------------------------------+-- |+-- Module : Generics.Regular.Functions.Seq+-- Copyright : (c) 2009 Universiteit Utrecht+-- License : BSD3+--+-- Maintainer : generics@haskell.org+-- Stability : experimental+-- Portability : non-portable+--+-- Summary: Deep generic seq. Used to fully evaluate a term.+-----------------------------------------------------------------------------++module Generics.Regular.Functions.Seq (++ DeepSeq (..), Seq(..), gdseq+ + ) where++import Data.List+import Generics.Regular.Base++-- | The class for generic deep seq.+class Seq f where+ gseq :: (a -> b -> b) -> f a -> b -> b++instance Seq I where+ gseq f (I x) = f x++-- | For constants we rely on the |DeepSeq| class.+instance (DeepSeq a) => Seq (K a) where+ gseq _ (K x) = dseq x+ +instance Seq U where+ gseq _ U = id++instance (Seq f, Seq g) => Seq (f :+: g) where+ gseq f (L x) = gseq f x+ gseq f (R y) = gseq f y++instance (Seq f, Seq g) => Seq (f :*: g) where+ gseq f (x :*: y) = gseq f x . gseq f y++instance Seq f => Seq (C c f) where+ gseq f (C x) = gseq f x++instance Seq f => Seq (S s f) where+ gseq f (S x) = gseq f x++-- | Deep, generic version of seq.++gdseq :: (Regular a, Seq (PF a)) => a -> b -> b+gdseq p = gseq gdseq (from p)++-- | A general class for expressing deep seq. It is used in the 'K' case for+-- the generic seq.+--+-- We do not give an instance of the form+-- @instance (Regular a, Seq (PF a)) => DeepSeq a where dseq = gdseq@+-- because this requires undecidable instances. However, any type for which+-- there is a generic instance can be given a trivial instance of 'DeepSeq' by+-- using 'gdseq'.+class DeepSeq a where+ dseq :: a -> b -> b+ dseq = seq++instance DeepSeq Int+instance DeepSeq Integer+instance DeepSeq Char+instance DeepSeq Float+instance DeepSeq Double+instance DeepSeq ()++instance DeepSeq a => DeepSeq [a] where+ dseq xs b = foldl' (flip dseq) b xs++instance DeepSeq a => DeepSeq (Maybe a) where+ dseq Nothing b = b+ dseq (Just a) b = dseq a b++instance (DeepSeq a, DeepSeq b) => DeepSeq (Either a b) where+ dseq (Left x) b = dseq x b+ dseq (Right x) b = dseq x b
+ src/Generics/Regular/Functions/Show.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeOperators #-}++-----------------------------------------------------------------------------+-- |+-- Module : Generics.Regular.Functions.Show+-- Copyright : (c) 2008 Universiteit Utrecht+-- License : BSD3+--+-- Maintainer : generics@haskell.org+-- Stability : experimental+-- Portability : non-portable+--+-- Summary: Generic show. This module is not exported by +-- "Generics.Regular.Functions" to avoid clashes with "Prelude".+-----------------------------------------------------------------------------++module Generics.Regular.Functions.Show (++ -- * Show function+ Show (..),+ show, shows++) where++import Generics.Regular.Base+import Prelude hiding (Show, show, shows, showsPrec)+import qualified Prelude as P (Show, showsPrec)+++-----------------------------------------------------------------------------+-- Show function.+-----------------------------------------------------------------------------++-- | The @Show@ class defines a show on values.+class Show f where+ hshowsPrec :: (Int -> a -> ShowS) -> Bool -> Int -> f a -> ShowS++instance Show I where+ hshowsPrec f _ n (I r) = f n r++instance (P.Show a) => Show (K a) where+ hshowsPrec _ _ n (K x) = P.showsPrec n x++instance Show U where+ hshowsPrec _ _ _ U = id++instance (Show f, Show g) => Show (f :+: g) where+ hshowsPrec f b n (L x) = hshowsPrec f b n x+ hshowsPrec f b n (R x) = hshowsPrec f b n x++instance (Show f, Show g) => Show (f :*: g) where+ hshowsPrec f b n (x :*: y) = hshowsPrec f b n x + . (if b then showString ", " else showString " ")+ . hshowsPrec f b n y++instance (Constructor c, Show f) => Show (C c f) where+ hshowsPrec f _ n cx@(C x) = case fixity of+ Prefix -> showParen True (showString (conName cx) . showChar ' ' . showBraces isRecord (hshowsPrec f isRecord n x))+ Infix _ _ -> showParen True + (showChar '(' . showString (conName cx) + . showChar ')' . showChar ' ' + . showBraces isRecord (hshowsPrec f isRecord n x))+ where isRecord = conIsRecord cx+ fixity = conFixity cx++showBraces :: Bool -> ShowS -> ShowS+showBraces b p = if b then showChar '{' . p . showChar '}' else p++instance (Selector s, Show f) => Show (S s f) where+ hshowsPrec f b n s@(S x) = showString (selName s) . showString " = " + . hshowsPrec f b n x+++showsPrec :: (Regular a, Show (PF a)) => Int -> a -> ShowS+showsPrec n x = hshowsPrec showsPrec False n (from x)++shows :: (Regular a, Show (PF a)) => a -> ShowS+shows = showsPrec 0++show :: (Regular a, Show (PF a)) => a -> String+show x = shows x ""
+ src/Generics/Regular/Functions/Zip.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE TypeOperators #-}++-----------------------------------------------------------------------------+-- |+-- Module : Generics.Regular.Functions.Zip+-- Copyright : (c) 2008 Universiteit Utrecht+-- License : BSD3+--+-- Maintainer : generics@haskell.org+-- Stability : experimental+-- Portability : non-portable+--+-- Summary: Generic zip.+-----------------------------------------------------------------------------++module Generics.Regular.Functions.Zip (++ -- * Zip functions+ Zip (..),+ fzip,+ fzip'++) where++import Control.Monad (liftM, liftM2)++import Generics.Regular.Base+++-----------------------------------------------------------------------------+-- Zip functions.+-----------------------------------------------------------------------------++-- | The @Zip@ class defines a monadic zip on functorial values.+class Zip f where+ fzipM :: Monad m => (a -> b -> m c) -> f a -> f b -> m (f c)++instance Zip I where+ fzipM f (I x) (I y) = liftM I (f x y)++instance Eq a => Zip (K a) where+ fzipM _ (K x) (K y) + | x == y = return (K x)+ | otherwise = fail "fzipM: structure mismatch"++instance Zip U where+ fzipM _ U U = return U++instance (Zip f, Zip g) => Zip (f :+: g) where+ fzipM f (L x) (L y) = liftM L (fzipM f x y)+ fzipM f (R x) (R y) = liftM R (fzipM f x y)+ fzipM _ _ _ = fail "fzipM: structure mismatch"++instance (Zip f, Zip g) => Zip (f :*: g) where+ fzipM f (x1 :*: y1) (x2 :*: y2) = + liftM2 (:*:) (fzipM f x1 x2)+ (fzipM f y1 y2)++instance Zip f => Zip (C c f) where+ fzipM f (C x) (C y) = liftM C (fzipM f x y)++instance Zip f => Zip (S s f) where+ fzipM f (S x) (S y) = liftM S (fzipM f x y)++-- | Functorial zip with a non-monadic function, resulting in a monadic value.+fzip :: (Zip f, Monad m) => (a -> b -> c) -> f a -> f b -> m (f c)+fzip f = fzipM (\x y -> return (f x y))++-- | Partial functorial zip with a non-monadic function.+fzip' :: Zip f => (a -> b -> c) -> f a -> f b -> f c+fzip' f x y = maybe (error "fzip': structure mismatch") id (fzip f x y)
+ src/Generics/Regular/Selector.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE KindSignatures #-}++-----------------------------------------------------------------------------+-- |+-- Module : Generics.Regular.Selector+-- Copyright : (c) 2008 Universiteit Utrecht+-- License : BSD3+--+-- Maintainer : generics@haskell.org+-- Stability : experimental+-- Portability : non-portable+--+-- Summary: Representation for record selectors.+-----------------------------------------------------------------------------++module Generics.Regular.Selector (Selector(..)) where++class Selector s where+ selName :: t s (f :: * -> *) r -> String+
src/Generics/Regular/TH.hs view
@@ -19,23 +19,43 @@ -- Adapted from Generics.Multirec.TH module Generics.Regular.TH- ( deriveConstructors,+ ( deriveAll,+ deriveConstructors,+ deriveSelectors, deriveRegular, derivePF ) where +import Data.List (intercalate) import Generics.Regular.Base import Generics.Regular.Constructor import Language.Haskell.TH hiding (Fixity()) import Language.Haskell.TH.Syntax (Lift(..)) import Control.Monad +-- | Given the type and the name (as string) for the pattern functor to derive,+-- generate the Constructor' instances, the Selector' instances and the+-- 'Regular' instance.++deriveAll :: Name -> String -> Q [Dec]+deriveAll n s =+ do a <- deriveConstructors n+ b <- deriveSelectors n+ c <- deriveRegular n s+ return (a ++ b ++ c)+ -- | Given a datatype name, derive datatypes and -- instances of class 'Constructor'. deriveConstructors :: Name -> Q [Dec] deriveConstructors = constrInstance +-- | Given a datatype name, derive datatypes and +-- instances of class 'Selector'.++deriveSelectors :: Name -> Q [Dec]+deriveSelectors = selectInstance+ -- | Given the type and the name (as string) for the -- pattern functor to derive, generate the 'Regular' -- instance.@@ -52,43 +72,75 @@ derivePF :: String -> Name -> Q [Dec] derivePF pfn n =- fmap (:[]) $- tySynD (mkName pfn) [] (pfType n)+ do+ i <- reify n+ fmap (:[]) $ tySynD (mkName pfn) (typeVariables i) (pfType n) deriveInst :: Name -> Q [Dec] deriveInst t = do+ i <- reify t+ let typ = foldl (\a -> AppT a . VarT) (ConT t) (typeVariables i) fcs <- mkFrom t 1 0 t tcs <- mkTo t 1 0 t liftM (:[]) $- instanceD (cxt []) (conT ''Regular `appT` conT t)+ instanceD (cxt []) (conT ''Regular `appT` return typ) [funD 'from fcs, funD 'to tcs] constrInstance :: Name -> Q [Dec] constrInstance n = do i <- reify n- -- runIO (print i)- let cs = case i of- TyConI (DataD _ _ _ cs _) -> cs- _ -> []- ds <- mapM mkData cs- is <- mapM mkInstance cs- return $ ds ++ is+ case i of+ TyConI (DataD _ n _ cs _) -> mkInstance n cs+ TyConI (NewtypeD _ n _ c _) -> mkInstance n [c]+ _ -> return []+ where+ mkInstance n cs = do+ ds <- mapM (mkConstrData n) cs+ is <- mapM (mkConstrInstance n) cs+ return $ ds ++ is +selectInstance :: Name -> Q [Dec]+selectInstance n =+ do+ i <- reify n+ case i of+ TyConI (DataD _ n _ cs _) -> mkInstance n cs+ TyConI (NewtypeD _ n _ c _) -> mkInstance n [c]+ _ -> return []+ where+ mkInstance n cs = do+ ds <- mapM (mkSelectData n) cs+ is <- mapM (mkSelectInstance n) cs+ return $ concat (ds ++ is)++typeVariables :: Info -> [Name]+typeVariables (TyConI (DataD _ _ tv _ _)) = tv+typeVariables (TyConI (NewtypeD _ _ tv _ _)) = tv+typeVariables _ = []+ stripRecordNames :: Con -> Con stripRecordNames (RecC n f) = NormalC n (map (\(_, s, t) -> (s, t)) f) stripRecordNames c = c -mkData :: Con -> Q Dec-mkData (NormalC n _) =- dataD (cxt []) (mkName (nameBase n)) [] [] [] -mkData r@(RecC _ _) =- mkData (stripRecordNames r)-mkData (InfixC t1 n t2) =- mkData (NormalC n [t1,t2])+genName :: [Name] -> Name+genName = mkName . (++"_") . intercalate "_" . map nameBase +mkConstrData :: Name -> Con -> Q Dec+mkConstrData dt (NormalC n _) =+ dataD (cxt []) (genName [dt, n]) [] [] [] +mkConstrData dt r@(RecC _ _) =+ mkConstrData dt (stripRecordNames r)+mkConstrData dt (InfixC t1 n t2) =+ mkConstrData dt (NormalC n [t1,t2])++mkSelectData :: Name -> Con -> Q [Dec]+mkSelectData dt r@(RecC n fs) = return (map one fs)+ where one (f, _, _) = DataD [] (genName [dt, n, f]) [] [] []+mkSelectData dt _ = return []+ instance Lift Fixity where lift Prefix = conE 'Prefix lift (Infix a n) = conE 'Infix `appE` [| a |] `appE` [| n |]@@ -98,20 +150,18 @@ lift RightAssociative = conE 'RightAssociative lift NotAssociative = conE 'NotAssociative -mkInstance :: Con -> Q Dec-mkInstance (NormalC n _) =- instanceD (cxt []) (appT (conT ''Constructor) (conT $ mkName (nameBase n)))- [funD 'conName [clause [wildP] (normalB (stringE (nameBase n))) []]]-mkInstance r@(RecC _ _) =- mkInstance (stripRecordNames r)-mkInstance (InfixC t1 n t2) =+mkConstrInstance :: Name -> Con -> Q Dec+mkConstrInstance dt (NormalC n _) = mkConstrInstanceWith dt n []+mkConstrInstance dt (RecC n _) = mkConstrInstanceWith dt n+ [ funD 'conIsRecord [clause [wildP] (normalB (conE 'True)) []]]+mkConstrInstance dt (InfixC t1 n t2) = do i <- reify n let fi = case i of DataConI _ _ _ f -> convertFixity f _ -> Prefix- instanceD (cxt []) (appT (conT ''Constructor) (conT $ mkName (nameBase n)))- [funD 'conName [clause [wildP] (normalB (stringE ("(" ++ (nameBase n) ++ ")"))) []],+ instanceD (cxt []) (appT (conT ''Constructor) (conT $ genName [dt, n]))+ [funD 'conName [clause [wildP] (normalB (stringE (nameBase n))) []], funD 'conFixity [clause [wildP] (normalB [| fi |]) []]] where convertFixity (Fixity n d) = Infix (convertDirection d) n@@ -119,14 +169,29 @@ convertDirection InfixR = RightAssociative convertDirection InfixN = NotAssociative +mkConstrInstanceWith :: Name -> Name -> [Q Dec] -> Q Dec+mkConstrInstanceWith dt n extra = + instanceD (cxt []) (appT (conT ''Constructor) (conT $ genName [dt, n]))+ (funD 'conName [clause [wildP] (normalB (stringE (nameBase n))) []] : extra)++mkSelectInstance :: Name -> Con -> Q [Dec]+mkSelectInstance dt r@(RecC n fs) = return (map one fs)+ where+ one (f, _, _) = + InstanceD ([]) (AppT (ConT ''Selector) (ConT $ genName [dt, n, f]))+ [FunD 'selName [Clause [WildP] (NormalB (LitE (StringL (nameBase f)))) []]]+mkSelectInstance _ _ = return []+ pfType :: Name -> Q Type pfType n = do -- runIO $ putStrLn $ "processing " ++ show n i <- reify n let b = case i of- TyConI (DataD _ _ _ cs _) ->- foldr1 sum (map (pfCon n) cs)+ TyConI (DataD _ dt vs cs _) ->+ foldr1 sum (map (pfCon (dt, vs)) cs)+ TyConI (NewtypeD _ dt vs c _) ->+ pfCon (dt, vs) c TyConI (TySynD t _ _) -> conT ''K `appT` conT t _ -> error "unknown construct" @@ -136,33 +201,48 @@ sum :: Q Type -> Q Type -> Q Type sum a b = conT ''(:+:) `appT` a `appT` b -pfCon :: Name -> Con -> Q Type-pfCon ns (NormalC n []) =- appT (appT (conT ''C) (conT $ mkName (nameBase n))) (conT ''U)-pfCon ns (NormalC n fs) =- appT (appT (conT ''C) (conT $ mkName (nameBase n))) (foldr1 prod (map (pfField ns . snd) fs))++pfCon :: (Name, [Name]) -> Con -> Q Type+pfCon (dt, vs) (NormalC n []) =+ appT (appT (conT ''C) (conT $ genName [dt, n])) (conT ''U)+pfCon (dt, vs) (NormalC n fs) =+ appT (appT (conT ''C) (conT $ genName [dt, n])) (foldr1 prod (map (pfField (dt, vs) . snd) fs)) where prod :: Q Type -> Q Type -> Q Type prod a b = conT ''(:*:) `appT` a `appT` b-pfCon ns r@(RecC _ _) =- pfCon ns (stripRecordNames r)-pfCon ns (InfixC t1 n t2) =- pfCon ns (NormalC n [t1,t2])+pfCon (dt, vs) r@(RecC n []) =+ appT (appT (conT ''C) (conT $ genName [dt, n])) (conT ''U)+pfCon (dt, vs) r@(RecC n fs) =+ appT (appT (conT ''C) (conT $ genName [dt, n])) (foldr1 prod (map (pfField' (dt, vs) n) fs))+ where+ prod :: Q Type -> Q Type -> Q Type+ prod a b = conT ''(:*:) `appT` a `appT` b -pfField :: Name -> Type -> Q Type-pfField ns t@(ConT n) | n == ns = conT ''I-pfField ns t = conT ''K `appT` return t+pfCon d (InfixC t1 n t2) =+ pfCon d (NormalC n [t1,t2]) +dataDeclToType :: (Name, [Name]) -> Type+dataDeclToType (dt, vs) = foldl (\a b -> AppT a (VarT b)) (ConT dt) vs++pfField :: (Name, [Name]) -> Type -> Q Type+pfField d t | t == dataDeclToType d = conT ''I+pfField d t = conT ''K `appT` return t++pfField' :: (Name, [Name]) -> Name -> (Name, Strict, Type) -> Q Type+pfField' d ns (_, _, t) | t == dataDeclToType d = conT ''I+pfField' (dt, vs) ns (f, _, t) = conT ''S `appT` conT (genName [dt, ns, f]) `appT` (conT ''K `appT` return t)+ mkFrom :: Name -> Int -> Int -> Name -> Q [Q Clause] mkFrom ns m i n = do -- runIO $ putStrLn $ "processing " ++ show n let wrapE e = lrE m i e i <- reify n- let dn = mkName (nameBase n) let b = case i of- TyConI (DataD _ _ _ cs _) ->- zipWith (fromCon wrapE ns dn (length cs)) [0..] cs+ TyConI (DataD _ dt vs cs _) ->+ zipWith (fromCon wrapE ns (dt, vs) (length cs)) [0..] cs+ TyConI (NewtypeD _ dt vs c _) ->+ [fromCon wrapE ns (dt, vs) 1 0 c] TyConI (TySynD t _ _) -> [clause [varP (field 0)] (normalB (wrapE $ conE 'K `appE` varE (field 0))) []] _ -> error "unknown construct"@@ -174,56 +254,81 @@ -- runIO $ putStrLn $ "processing " ++ show n let wrapP p = lrP m i p i <- reify n- let dn = mkName (nameBase n) let b = case i of- TyConI (DataD _ _ _ cs _) ->- zipWith (toCon wrapP ns dn (length cs)) [0..] cs+ TyConI (DataD _ dt vs cs _) ->+ zipWith (toCon wrapP ns (dt, vs) (length cs)) [0..] cs+ TyConI (NewtypeD _ dt vs c _) ->+ [toCon wrapP ns (dt, vs) 1 0 c] TyConI (TySynD t _ _) -> [clause [wrapP $ conP 'K [varP (field 0)]] (normalB $ varE (field 0)) []] _ -> error "unknown construct" return b -fromCon :: (Q Exp -> Q Exp) -> Name -> Name -> Int -> Int -> Con -> Q Clause-fromCon wrap ns n m i (NormalC cn []) =+fromCon :: (Q Exp -> Q Exp) -> Name -> (Name, [Name]) -> Int -> Int -> Con -> Q Clause+fromCon wrap ns (dt, vs) m i (NormalC cn []) = clause [conP cn []] (normalB $ wrap $ lrE m i $ conE 'C `appE` (conE 'U)) []-fromCon wrap ns n m i (NormalC cn fs) =+fromCon wrap ns (dt, vs) m i (NormalC cn fs) = -- runIO (putStrLn ("constructor " ++ show ix)) >> clause [conP cn (map (varP . field) [0..length fs - 1])]- (normalB $ wrap $ lrE m i $ conE 'C `appE` foldr1 prod (zipWith (fromField ns) [0..] (map snd fs))) []+ (normalB $ wrap $ lrE m i $ conE 'C `appE` foldr1 prod (zipWith (fromField (dt, vs)) [0..] (map snd fs))) [] where prod x y = conE '(:*:) `appE` x `appE` y-fromCon wrap ns n m i r@(RecC _ _) =- fromCon wrap ns n m i (stripRecordNames r)-fromCon wrap ns n m i (InfixC t1 cn t2) =- fromCon wrap ns n m i (NormalC cn [t1,t2])+fromCon wrap ns (dt, vs) m i r@(RecC cn []) =+ clause+ [conP cn []]+ (normalB $ wrap $ lrE m i $ conE 'C `appE` (conE 'U)) []+fromCon wrap ns (dt, vs) m i r@(RecC cn fs) =+ clause+ [conP cn (map (varP . field) [0..length fs - 1])]+ (normalB $ wrap $ lrE m i $ conE 'C `appE` foldr1 prod (zipWith (fromField' (dt, vs)) [0..] fs)) []+ where+ prod x y = conE '(:*:) `appE` x `appE` y+fromCon wrap ns (dt, vs) m i (InfixC t1 cn t2) =+ fromCon wrap ns (dt, vs) m i (NormalC cn [t1,t2]) -toCon :: (Q Pat -> Q Pat) -> Name -> Name -> Int -> Int -> Con -> Q Clause-toCon wrap ns n m i (NormalC cn []) =+fromField :: (Name, [Name]) -> Int -> Type -> Q Exp+fromField (dt, vs) nr t | t == dataDeclToType (dt, vs) = conE 'I `appE` varE (field nr)+fromField (dt, vs) nr t = conE 'K `appE` varE (field nr)++fromField' :: (Name, [Name]) -> Int -> (Name, Strict, Type) -> Q Exp+fromField' (dt, vs) nr (_, _, t) | t == dataDeclToType (dt, vs) = conE 'I `appE` varE (field nr)+fromField' (dt, vs) nr (_, _, t) = conE 'S `appE` (conE 'K `appE` varE (field nr))++toCon :: (Q Pat -> Q Pat) -> Name -> (Name, [Name]) -> Int -> Int -> Con -> Q Clause+toCon wrap ns (dt, vs) m i (NormalC cn []) = clause [wrap $ lrP m i $ conP 'C [conP 'U []]] (normalB $ conE cn) []-toCon wrap ns n m i (NormalC cn fs) =+toCon wrap ns (dt, vs) m i (NormalC cn fs) = -- runIO (putStrLn ("constructor " ++ show ix)) >> clause- [wrap $ lrP m i $ conP 'C [foldr1 prod (zipWith (toField ns) [0..] (map snd fs))]]+ [wrap $ lrP m i $ conP 'C [foldr1 prod (zipWith (toField (dt, vs)) [0..] (map snd fs))]] (normalB $ foldl appE (conE cn) (map (varE . field) [0..length fs - 1])) [] where prod x y = conP '(:*:) [x,y]-toCon wrap ns n m i r@(RecC _ _) =- toCon wrap ns n m i (stripRecordNames r)-toCon wrap ns n m i (InfixC t1 cn t2) =- toCon wrap ns n m i (NormalC cn [t1,t2])+toCon wrap ns (dt, vs) m i r@(RecC cn []) =+ clause+ [wrap $ lrP m i $ conP 'C [conP 'U []]]+ (normalB $ conE cn) []+toCon wrap ns (dt, vs) m i r@(RecC cn fs) =+ clause+ [wrap $ lrP m i $ conP 'C [foldr1 prod (zipWith (toField' (dt, vs)) [0..] fs)]]+ (normalB $ foldl appE (conE cn) (map (varE . field) [0..length fs - 1])) []+ where+ prod x y = conP '(:*:) [x,y]+toCon wrap ns (dt, vs) m i (InfixC t1 cn t2) =+ toCon wrap ns (dt, vs) m i (NormalC cn [t1,t2]) -fromField :: Name -> Int -> Type -> Q Exp-fromField ns nr t@(ConT n) | n == ns = conE 'I `appE` varE (field nr)-fromField ns nr t = conE 'K `appE` varE (field nr)+toField :: (Name, [Name]) -> Int -> Type -> Q Pat+toField (dt, vs) nr t | t == dataDeclToType (dt, vs) = conP 'I [varP (field nr)]+toField (dt, vs) nr t = conP 'K [varP (field nr)] -toField :: Name -> Int -> Type -> Q Pat-toField ns nr t@(ConT n) | n == ns = conP 'I [varP (field nr)]-toField ns nr t = conP 'K [varP (field nr)]+toField' :: (Name, [Name]) -> Int -> (Name, Strict, Type) -> Q Pat+toField' (dt, vs) nr (_, _, t) | t == dataDeclToType (dt, vs) = conP 'I [varP (field nr)]+toField' (dt, vs) nr (_, _, t) = conP 'S [conP 'K [varP (field nr)]] field :: Int -> Name field n = mkName $ "f" ++ show n