regular 0.3.4 → 0.3.4.2
raw patch · 21 files changed
+1839/−1840 lines, 21 filesdep ~template-haskellsetup-changed
Dependency ranges changed: template-haskell
Files
- CREDITS +24/−24
- ChangeLog +42/−42
- LICENSE +28/−28
- Setup.hs +6/−6
- examples/Test.hs +78/−78
- regular.cabal +65/−66
- src/Generics/Regular.hs +132/−132
- src/Generics/Regular/Base.hs +124/−124
- src/Generics/Regular/Constructor.hs +38/−38
- src/Generics/Regular/Functions.hs +51/−51
- src/Generics/Regular/Functions/ConNames.hs +59/−59
- src/Generics/Regular/Functions/Crush.hs +70/−70
- src/Generics/Regular/Functions/Eq.hs +56/−56
- src/Generics/Regular/Functions/Fold.hs +182/−182
- src/Generics/Regular/Functions/GMap.hs +59/−59
- src/Generics/Regular/Functions/LR.hs +99/−99
- src/Generics/Regular/Functions/Read.hs +195/−195
- src/Generics/Regular/Functions/Show.hs +82/−82
- src/Generics/Regular/Functions/Zip.hs +71/−71
- src/Generics/Regular/Selector.hs +20/−20
- src/Generics/Regular/TH.hs +358/−358
CREDITS view
@@ -1,24 +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+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
@@ -1,43 +1,43 @@-version 0.3.4:- - Change template-haskell dependency to allow building with ghc-7.4.1.--version 0.3.3:- - Change template-haskell dependency to allow building with ghc-7.2.1.--version 0.3.2:- - Add missing S case to eq.--version 0.3.1:- - Fix a bug in the Template Haskell code (thanks to lists@snowlion.nl)--version 0.3.0:- - Remove gdseq (moved to the regular-extras package due to the introduction- of the deepseq dependency).--version 0.2.4:- - Export Assoc(..) from Generics.Regular.Functions.Crush (thanks to Martijn- van Steenbergen).--version 0.2.3:- - Replaced the flag on the cabal package by an explicit test on the ghc- version. This makes it easier to build on ghc-6.12.--version 0.2.2:- - Update to build with ghc-6.12: require template-haskell-2.4.*, adapt- Generics.Regular.TH accordingly and use CPP to maintain compatibility with- ghc-6.10--version 0.2.1:- - Do not export generic equality by default to avoid clashes with Prelude- - Turn I and K into newtypes--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.3.4: + - Change template-haskell dependency to allow building with ghc-7.4.1. + +version 0.3.3: + - Change template-haskell dependency to allow building with ghc-7.2.1. + +version 0.3.2: + - Add missing S case to eq. + +version 0.3.1: + - Fix a bug in the Template Haskell code (thanks to lists@snowlion.nl) + +version 0.3.0: + - Remove gdseq (moved to the regular-extras package due to the introduction + of the deepseq dependency). + +version 0.2.4: + - Export Assoc(..) from Generics.Regular.Functions.Crush (thanks to Martijn + van Steenbergen). + +version 0.2.3: + - Replaced the flag on the cabal package by an explicit test on the ghc + version. This makes it easier to build on ghc-6.12. + +version 0.2.2: + - Update to build with ghc-6.12: require template-haskell-2.4.*, adapt + Generics.Regular.TH accordingly and use CPP to maintain compatibility with + ghc-6.10 + +version 0.2.1: + - Do not export generic equality by default to avoid clashes with Prelude + - Turn I and K into newtypes + +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
LICENSE view
@@ -1,28 +1,28 @@-Copyright (c) 2009 Universiteit Utrecht-All rights reserved.--Redistribution and use in source and binary forms, with or without modification,-are permitted provided that the following conditions are met:--1. Redistributions of source code must retain the above copyright notice, this- list of conditions and the following disclaimer.--2. Redistributions in binary form must reproduce the above copyright notice,- this list of conditions and the following disclaimer in the documentation- and/or other materials provided with the distribution.--3. Neither the name of Universiteit Utrecht nor the names of its contributors- may be used to endorse or promote products derived from this software without- specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND-ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED-WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE-DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR-ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES-(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;-LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON-ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS-SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.-+Copyright (c) 2009 Universiteit Utrecht +All rights reserved. + +Redistribution and use in source and binary forms, with or without modification, +are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +3. Neither the name of Universiteit Utrecht nor the names of its contributors + may be used to endorse or promote products derived from this software without + specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON +ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +
Setup.hs view
@@ -1,6 +1,6 @@-module Main (main) where--import Distribution.Simple--main :: IO ()-main = defaultMain+module Main (main) where + +import Distribution.Simple + +main :: IO () +main = defaultMain
examples/Test.hs view
@@ -1,78 +1,78 @@-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE EmptyDataDecls #-}--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-import Generics.Regular.Functions.Eq--data X = X {one :: Int, three :: Float}--$(deriveAll ''X "Y")-type instance PF X = Y--{---- Datatype representing logical expressions-data Logic = Var String- | Logic :->: Logic -- implication- | Logic :<->: Logic -- equivalence- | Logic :&&: Logic -- and (conjunction)- | Logic :||: Logic -- or (disjunction)- | Not Logic -- not- | T -- true- | F -- false- deriving Show---- Instantiating Regular for Logic using TH-$(deriveAll ''Logic "PFLogic")-type instance PF Logic = PFLogic---- Example logical expressions-l1, l2, l3 :: Logic-l1 = Var "p"-l2 = Not l1-l3 = l1 :->: l2---- Testing flattening-ex0 :: [Logic]-ex0 = flattenr (from l3)---- Testing generic equality-ex1, ex2 :: Bool-ex1 = eq l3 l3-ex2 = eq l3 l2---- Testing generic show-ex3 :: String-ex3 = G.show l3---- Testing generic read-ex4 :: Logic-ex4 = G.read ex3---- Testing value generation-ex5, ex6 :: Logic-ex5 = left-ex6 = right---- Testing folding-ex7 :: Bool-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)--}+{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE EmptyDataDecls #-} + +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 +import Generics.Regular.Functions.Eq + +data X = X {one :: Int, three :: Float} + +$(deriveAll ''X "Y") +type instance PF X = Y + +{- +-- Datatype representing logical expressions +data Logic = Var String + | Logic :->: Logic -- implication + | Logic :<->: Logic -- equivalence + | Logic :&&: Logic -- and (conjunction) + | Logic :||: Logic -- or (disjunction) + | Not Logic -- not + | T -- true + | F -- false + deriving Show + +-- Instantiating Regular for Logic using TH +$(deriveAll ''Logic "PFLogic") +type instance PF Logic = PFLogic + +-- Example logical expressions +l1, l2, l3 :: Logic +l1 = Var "p" +l2 = Not l1 +l3 = l1 :->: l2 + +-- Testing flattening +ex0 :: [Logic] +ex0 = flattenr (from l3) + +-- Testing generic equality +ex1, ex2 :: Bool +ex1 = eq l3 l3 +ex2 = eq l3 l2 + +-- Testing generic show +ex3 :: String +ex3 = G.show l3 + +-- Testing generic read +ex4 :: Logic +ex4 = G.read ex3 + +-- Testing value generation +ex5, ex6 :: Logic +ex5 = left +ex6 = right + +-- Testing folding +ex7 :: Bool +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) +-}
regular.cabal view
@@ -1,66 +1,65 @@-name: regular-version: 0.3.4-synopsis: Generic programming library for regular datatypes.-description:-- This package provides generic functionality for regular datatypes.- Regular datatypes are recursive datatypes such as lists, binary trees,- etc. This library cannot be used with mutually recursive datatypes or- with nested datatypes. The multirec library [1] can deal with mutually- recursive datatypes.- . - This library has been described in the paper:- .- * /A Lightweight Approach to Datatype-Generic Rewriting./- Thomas van Noort, Alexey Rodriguez, Stefan Holdermans, Johan Jeuring, Bastiaan Heeren.- ACM SIGPLAN Workshop on Generic Programming 2008.- .- More information about this library can be found at- <http://www.cs.uu.nl/wiki/GenericProgramming/Regular>.- .- \[1] <http://hackage.haskell.org/package/multirec>--category: Generics-copyright: (c) 2011 Universiteit Utrecht-license: BSD3-license-file: LICENSE-author: Jose Pedro Magalhaes-maintainer: generics@haskell.org-stability: experimental-build-type: Custom-cabal-version: >= 1.6-tested-with: GHC == 6.10.4, GHC == 6.12.1, GHC == 7.0.1, GHC == 7.2.1-extra-source-files: examples/Test.hs- ChangeLog- CREDITS--source-repository head- type: svn- location: https://subversion.cs.uu.nl/repos/project.dgp-haskell.libraries/regular/trunk/--library- hs-source-dirs: src- exposed-modules: Generics.Regular- Generics.Regular.Base- 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.Show- Generics.Regular.Functions.Zip- - build-depends: base >= 4.0 && < 5- if impl(ghc >= 6.12)- build-depends: template-haskell >=2.4 && <2.8- cpp-options: -DTH_TYVARBNDR- else- build-depends: template-haskell >= 2.2 && < 2.4- ghc-options: -Wall+name: regular +version: 0.3.4.2 +synopsis: Generic programming library for regular datatypes. +description: + + This package provides generic functionality for regular datatypes. + Regular datatypes are recursive datatypes such as lists, binary trees, + etc. This library cannot be used with mutually recursive datatypes or + with nested datatypes. The multirec library [1] can deal with mutually + recursive datatypes. + . + This library has been described in the paper: + . + * /A Lightweight Approach to Datatype-Generic Rewriting./ + Thomas van Noort, Alexey Rodriguez, Stefan Holdermans, Johan Jeuring, Bastiaan Heeren. + ACM SIGPLAN Workshop on Generic Programming 2008. + . + More information about this library can be found at + <http://www.cs.uu.nl/wiki/GenericProgramming/Regular>. + . + \[1] <http://hackage.haskell.org/package/multirec> + +category: Generics +copyright: (c) 2011 Universiteit Utrecht, 2012 University of Oxford +license: BSD3 +license-file: LICENSE +author: Jose Pedro Magalhaes +maintainer: generics@haskell.org +stability: experimental +build-type: Custom +cabal-version: >= 1.6 +extra-source-files: examples/Test.hs + ChangeLog + CREDITS + +source-repository head + type: git + location: git://github.com/dreixel/regular.git + +library + hs-source-dirs: src + exposed-modules: Generics.Regular + Generics.Regular.Base + 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.Show + Generics.Regular.Functions.Zip + + build-depends: base >= 4.0 && < 5 + if impl(ghc >= 6.12) + build-depends: template-haskell >=2.4 && <2.9 + cpp-options: -DTH_TYVARBNDR + else + build-depends: template-haskell >= 2.2 && < 2.4 + ghc-options: -Wall
src/Generics/Regular.hs view
@@ -1,132 +1,132 @@--------------------------------------------------------------------------------- |--- Module : Generics.Regular--- Copyright : (c) 2008 Universiteit Utrecht--- License : BSD3------ Maintainer : generics@haskell.org--- Stability : experimental--- Portability : non-portable------ Summary: Top-level module for this library.--- By importing this module, the user is able to use all the generic--- functionality. The user is only required to provide an instance of--- @Regular@ for the datatype.------ Consider a datatype representing logical expressions:------ > data Logic = Var String--- > | Logic :->: Logic -- implication--- > | Logic :<->: Logic -- equivalence--- > | Logic :&&: Logic -- and (conjunction)--- > | Logic :||: Logic -- or (disjunction)--- > | Not Logic -- not--- > | T -- true--- > | F -- false------ First we import the relevant modules:------ > 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.TH,- module Generics.Regular.Functions- ) where--import Generics.Regular.Base-import Generics.Regular.TH-import Generics.Regular.Functions+----------------------------------------------------------------------------- +-- | +-- Module : Generics.Regular +-- Copyright : (c) 2008 Universiteit Utrecht +-- License : BSD3 +-- +-- Maintainer : generics@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- Summary: Top-level module for this library. +-- By importing this module, the user is able to use all the generic +-- functionality. The user is only required to provide an instance of +-- @Regular@ for the datatype. +-- +-- Consider a datatype representing logical expressions: +-- +-- > data Logic = Var String +-- > | Logic :->: Logic -- implication +-- > | Logic :<->: Logic -- equivalence +-- > | Logic :&&: Logic -- and (conjunction) +-- > | Logic :||: Logic -- or (disjunction) +-- > | Not Logic -- not +-- > | T -- true +-- > | F -- false +-- +-- First we import the relevant modules: +-- +-- > 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.TH, + module Generics.Regular.Functions + ) where + +import Generics.Regular.Base +import Generics.Regular.TH +import Generics.Regular.Functions
src/Generics/Regular/Base.hs view
@@ -1,124 +1,124 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE TypeFamilies #-}---------------------------------------------------------------------------------- |--- Module : Generics.Regular.Base--- Copyright : (c) 2008 Universiteit Utrecht--- License : BSD3------ Maintainer : generics@haskell.org--- Stability : experimental--- Portability : non-portable------ Summary: Types for structural representation.--------------------------------------------------------------------------------module Generics.Regular.Base (-- -- * Functorial structural representation types- K(..),- I(..),- U(..),- (:+:)(..),- (:*:)(..),- C(..),- S(..),-- Constructor(..), Fixity(..), Associativity(..),- Selector(..), -- -- * Fixed-point type- Fix (..),-- -- * Type class capturing the structural representation of a type and the corresponding embedding-projection pairs- Regular (..), PF- - ) where--import Generics.Regular.Constructor-import Generics.Regular.Selector----------------------------------------------------------------------------------- Functorial structural representation types.---------------------------------------------------------------------------------- | Structure type for constant values.-newtype K a r = K { unK :: a }---- | Structure type for recursive values.-newtype I r = I { unI :: r }---- | Structure type for empty constructors.-data U r = U---- | Structure type for alternatives in a type.-data (f :+: g) r = L (f r) | R (g r)---- | Structure type for fields of a constructor.-data (f :*: g) r = f r :*: g r---- | 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 :*:---------------------------------------------------------------------------------- Fixed-point type.---------------------------------------------------------------------------------- | The well-known fixed-point type.-newtype Fix f = In { out :: f (Fix f) }----------------------------------------------------------------------------------- Type class capturing the structural representation of a type and the--- corresponding embedding-projection pairs.--------------------------------------------------------------------------------- | The type family @PF@ represents the pattern functor of a datatype.--- --- To be able to use the generic functions, the user is required to provide--- an instance of this type family.-type family PF a :: * -> *---- | The type class @Regular@ captures the structural representation of a --- type and the corresponding embedding-projection pairs.------ To be able to use the generic functions, the user is required to provide--- an instance of this type class.-class Regular a where- from :: a -> PF a a- to :: PF a a -> a---------------------------------------------------------------------------------- Functorial map function.--------------------------------------------------------------------------------instance Functor I where- fmap f (I r) = I (f r)--instance Functor (K a) where- fmap _ (K a) = K a--instance Functor U where- fmap _ U = U--instance (Functor f, Functor g) => Functor (f :+: g) where- fmap f (L x) = L (fmap f x)- fmap f (R y) = R (fmap f y)--instance (Functor f, Functor g) => Functor (f :*: g) where- fmap f (x :*: y) = fmap f x :*: fmap f y--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)-+{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Generics.Regular.Base +-- Copyright : (c) 2008 Universiteit Utrecht +-- License : BSD3 +-- +-- Maintainer : generics@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- Summary: Types for structural representation. +----------------------------------------------------------------------------- + +module Generics.Regular.Base ( + + -- * Functorial structural representation types + K(..), + I(..), + U(..), + (:+:)(..), + (:*:)(..), + C(..), + S(..), + + Constructor(..), Fixity(..), Associativity(..), + Selector(..), + + -- * Fixed-point type + Fix (..), + + -- * Type class capturing the structural representation of a type and the corresponding embedding-projection pairs + Regular (..), PF + + ) where + +import Generics.Regular.Constructor +import Generics.Regular.Selector + + +----------------------------------------------------------------------------- +-- Functorial structural representation types. +----------------------------------------------------------------------------- + +-- | Structure type for constant values. +newtype K a r = K { unK :: a } + +-- | Structure type for recursive values. +newtype I r = I { unI :: r } + +-- | Structure type for empty constructors. +data U r = U + +-- | Structure type for alternatives in a type. +data (f :+: g) r = L (f r) | R (g r) + +-- | Structure type for fields of a constructor. +data (f :*: g) r = f r :*: g r + +-- | 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 :*: + +----------------------------------------------------------------------------- +-- Fixed-point type. +----------------------------------------------------------------------------- + +-- | The well-known fixed-point type. +newtype Fix f = In { out :: f (Fix f) } + + +----------------------------------------------------------------------------- +-- Type class capturing the structural representation of a type and the +-- corresponding embedding-projection pairs. +----------------------------------------------------------------------------- +-- | The type family @PF@ represents the pattern functor of a datatype. +-- +-- To be able to use the generic functions, the user is required to provide +-- an instance of this type family. +type family PF a :: * -> * + +-- | The type class @Regular@ captures the structural representation of a +-- type and the corresponding embedding-projection pairs. +-- +-- To be able to use the generic functions, the user is required to provide +-- an instance of this type class. +class Regular a where + from :: a -> PF a a + to :: PF a a -> a + +----------------------------------------------------------------------------- +-- Functorial map function. +----------------------------------------------------------------------------- + +instance Functor I where + fmap f (I r) = I (f r) + +instance Functor (K a) where + fmap _ (K a) = K a + +instance Functor U where + fmap _ U = U + +instance (Functor f, Functor g) => Functor (f :+: g) where + fmap f (L x) = L (fmap f x) + fmap f (R y) = R (fmap f y) + +instance (Functor f, Functor g) => Functor (f :*: g) where + fmap f (x :*: y) = fmap f x :*: fmap f y + +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
@@ -1,38 +1,38 @@-{-# LANGUAGE KindSignatures #-}---------------------------------------------------------------------------------- |--- Module : Generics.Regular.Constructor--- Copyright : (c) 2008 Universiteit Utrecht--- License : BSD3------ Maintainer : generics@haskell.org--- Stability : experimental--- Portability : non-portable------ Summary: Representation for constructors.--------------------------------------------------------------------------------module Generics.Regular.Constructor (- Constructor(..), Fixity(..), Associativity(..)- ) where----- | Class for datatypes that represent data constructors.--- For non-symbolic constructors, only 'conName' has to be defined.--- The weird argument is supposed to be instantiated with 'C' from--- base, hence the complex kind.-class Constructor c where- 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'.-data Fixity = Prefix | Infix Associativity Int- deriving (Eq, Show, Ord, Read)--data Associativity = LeftAssociative | RightAssociative | NotAssociative- deriving (Eq, Show, Ord, Read)+{-# LANGUAGE KindSignatures #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Generics.Regular.Constructor +-- Copyright : (c) 2008 Universiteit Utrecht +-- License : BSD3 +-- +-- Maintainer : generics@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- Summary: Representation for constructors. +----------------------------------------------------------------------------- + +module Generics.Regular.Constructor ( + Constructor(..), Fixity(..), Associativity(..) + ) where + + +-- | Class for datatypes that represent data constructors. +-- For non-symbolic constructors, only 'conName' has to be defined. +-- The weird argument is supposed to be instantiated with 'C' from +-- base, hence the complex kind. +class Constructor c where + 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'. +data Fixity = Prefix | Infix Associativity Int + deriving (Eq, Show, Ord, Read) + +data Associativity = LeftAssociative | RightAssociative | NotAssociative + deriving (Eq, Show, Ord, Read)
src/Generics/Regular/Functions.hs view
@@ -1,51 +1,51 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE TypeFamilies #-}---------------------------------------------------------------------------------- |--- Module : Generics.Regular.Functions--- Copyright : (c) 2010 Universiteit Utrecht--- License : BSD3------ Maintainer : generics@haskell.org--- Stability : experimental--- Portability : non-portable------ Summary: All of the generic functionality for regular dataypes: mapM, --- flatten, zip, equality, value generation, fold and unfold.--- Generic show ("Generics.Regular.Functions.Show"), generic read --- ("Generics.Regular.Functions.Read") and generic equality --- ("Generics.Regular.Functions.Eq") are not exported to prevent clashes--- with @Prelude@.--------------------------------------------------------------------------------module Generics.Regular.Functions (- - -- * Constructor names- module Generics.Regular.Functions.ConNames,- - -- * Crush- module Generics.Regular.Functions.Crush,- - -- * 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,- - -- * Zipping- module Generics.Regular.Functions.Zip-- ) where--import Generics.Regular.Functions.ConNames-import Generics.Regular.Functions.Crush-import Generics.Regular.Functions.Fold-import Generics.Regular.Functions.GMap-import Generics.Regular.Functions.LR-import Generics.Regular.Functions.Zip+{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Generics.Regular.Functions +-- Copyright : (c) 2010 Universiteit Utrecht +-- License : BSD3 +-- +-- Maintainer : generics@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- Summary: All of the generic functionality for regular dataypes: mapM, +-- flatten, zip, equality, value generation, fold and unfold. +-- Generic show ("Generics.Regular.Functions.Show"), generic read +-- ("Generics.Regular.Functions.Read") and generic equality +-- ("Generics.Regular.Functions.Eq") are not exported to prevent clashes +-- with @Prelude@. +----------------------------------------------------------------------------- + +module Generics.Regular.Functions ( + + -- * Constructor names + module Generics.Regular.Functions.ConNames, + + -- * Crush + module Generics.Regular.Functions.Crush, + + -- * 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, + + -- * Zipping + module Generics.Regular.Functions.Zip + + ) where + +import Generics.Regular.Functions.ConNames +import Generics.Regular.Functions.Crush +import Generics.Regular.Functions.Fold +import Generics.Regular.Functions.GMap +import Generics.Regular.Functions.LR +import Generics.Regular.Functions.Zip
src/Generics/Regular/Functions/ConNames.hs view
@@ -1,60 +1,60 @@-{-# 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 (S s f) where- hconNames _ = []--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))-+{-# 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 (S s f) where + hconNames _ = [] + +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
@@ -1,70 +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 (..), Assoc(..),- 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+{-# 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 (..), Assoc(..), + 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
@@ -1,56 +1,56 @@-{-# 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--instance Eq f => Eq (S s f) where- eqf f (S x) (S y) = eqf f x y--eq :: (Regular a, Eq (PF a)) => a -> a -> Bool-eq x y = eqf eq (from x) (from y)+{-# 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 + +instance Eq f => Eq (S s f) where + eqf f (S x) (S 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
@@ -1,182 +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)-(&) = (,)-+{-# 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
@@ -1,59 +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)+{-# 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
@@ -1,99 +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)+{-# 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
@@ -1,195 +1,195 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE ScopedTypeVariables #-}---------------------------------------------------------------------------------- |--- Module : Generics.Regular.Functions.Read--- Copyright : (c) 2010 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)---- * 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, CountAtoms 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"+{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ScopedTypeVariables #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Generics.Regular.Functions.Read +-- Copyright : (c) 2010 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) + +-- * 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, CountAtoms 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/Show.hs view
@@ -1,82 +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 ""+{-# 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
@@ -1,71 +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)+{-# 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
@@ -1,20 +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-+{-# 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
@@ -1,358 +1,358 @@-{-# LANGUAGE TemplateHaskell, CPP #-}-{-# OPTIONS_GHC -w #-}---------------------------------------------------------------------------------- |--- Module : Generics.Regular.TH--- Copyright : (c) 2008--2009 Universiteit Utrecht--- License : BSD3------ Maintainer : generics@haskell.org--- Stability : experimental--- Portability : non-portable------ This module contains Template Haskell code that can be used to--- automatically generate the boilerplate code for the regular--- library.------------------------------------------------------------------------------------- Adapted from Generics.Multirec.TH-module Generics.Regular.TH- ( 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.--deriveRegular :: Name -> String -> Q [Dec]-deriveRegular n pfn =- do- pf <- derivePF pfn n- fam <- deriveInst n- return $ pf ++ fam---- | Derive only the 'PF' instance. Not needed if 'deriveRegular'--- is used.--derivePF :: String -> Name -> Q [Dec]-derivePF pfn 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 . tyVarBndrToName) (ConT t) (typeVariables i)- fcs <- mkFrom t 1 0 t- tcs <- mkTo t 1 0 t- liftM (:[]) $- instanceD (cxt []) (conT ''Regular `appT` return typ)- [funD 'from fcs, funD 'to tcs]--constrInstance :: Name -> Q [Dec]-constrInstance 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 (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)--#ifdef TH_TYVARBNDR-typeVariables :: Info -> [TyVarBndr]-#else-typeVariables :: Info -> [Name]-#endif-typeVariables (TyConI (DataD _ _ tv _ _)) = tv-typeVariables (TyConI (NewtypeD _ _ tv _ _)) = tv-typeVariables _ = []--#ifdef TH_TYVARBNDR-tyVarBndrToName :: TyVarBndr -> Name-tyVarBndrToName (PlainTV name) = name-tyVarBndrToName (KindedTV name _) = name-#else-tyVarBndrToName :: Name -> Name-tyVarBndrToName = id-#endif--stripRecordNames :: Con -> Con-stripRecordNames (RecC n f) =- NormalC n (map (\(_, s, t) -> (s, t)) f)-stripRecordNames c = c--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 |]--instance Lift Associativity where- lift LeftAssociative = conE 'LeftAssociative- lift RightAssociative = conE 'RightAssociative- lift NotAssociative = conE 'NotAssociative--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 $ 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- convertDirection InfixL = LeftAssociative- 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 _ dt vs cs _) ->- foldr1 sum (map (pfCon (dt, map tyVarBndrToName vs)) cs)- TyConI (NewtypeD _ dt vs c _) ->- pfCon (dt, map tyVarBndrToName vs) c- TyConI (TySynD t _ _) ->- conT ''K `appT` conT t- _ -> error "unknown construct" - --appT b (conT $ mkName (nameBase n))- b- where- sum :: Q Type -> Q Type -> Q Type- sum a b = conT ''(:+:) `appT` a `appT` b---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 (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--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@(dt, vs) ns (f, _, t) | t == dataDeclToType d = conT ''S `appT` conT (genName [dt, ns, f]) `appT` 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 b = case i of- TyConI (DataD _ dt vs cs _) ->- zipWith (fromCon wrapE ns (dt, map tyVarBndrToName vs) (length cs)) [0..] cs- TyConI (NewtypeD _ dt vs c _) ->- [fromCon wrapE ns (dt, map tyVarBndrToName vs) 1 0 c]- TyConI (TySynD t _ _) ->- [clause [varP (field 0)] (normalB (wrapE $ conE 'K `appE` varE (field 0))) []]- _ -> error "unknown construct"- return b--mkTo :: Name -> Int -> Int -> Name -> Q [Q Clause]-mkTo ns m i n =- do- -- runIO $ putStrLn $ "processing " ++ show n- let wrapP p = lrP m i p- i <- reify n- let b = case i of- TyConI (DataD _ dt vs cs _) ->- zipWith (toCon wrapP ns (dt, map tyVarBndrToName vs) (length cs)) [0..] cs- TyConI (NewtypeD _ dt vs c _) ->- [toCon wrapP ns (dt, map tyVarBndrToName 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, [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 (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 (dt, vs)) [0..] (map snd fs))) []- where- prod x y = conE '(:*:) `appE` x `appE` y-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])--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 'S `appE` (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 (dt, vs) m i (NormalC cn fs) =- -- runIO (putStrLn ("constructor " ++ show ix)) >>- clause- [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 (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])--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, [Name]) -> Int -> (Name, Strict, Type) -> Q Pat-toField' (dt, vs) nr (_, _, t) | t == dataDeclToType (dt, vs) = conP 'S [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--lrP :: Int -> Int -> (Q Pat -> Q Pat)-lrP 1 0 p = p-lrP m 0 p = conP 'L [p]-lrP m i p = conP 'R [lrP (m-1) (i-1) p]--lrE :: Int -> Int -> (Q Exp -> Q Exp)-lrE 1 0 e = e-lrE m 0 e = conE 'L `appE` e-lrE m i e = conE 'R `appE` lrE (m-1) (i-1) e-+{-# LANGUAGE TemplateHaskell, CPP #-} +{-# OPTIONS_GHC -w #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Generics.Regular.TH +-- Copyright : (c) 2008--2009 Universiteit Utrecht +-- License : BSD3 +-- +-- Maintainer : generics@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- This module contains Template Haskell code that can be used to +-- automatically generate the boilerplate code for the regular +-- library. +-- +----------------------------------------------------------------------------- + +-- Adapted from Generics.Multirec.TH +module Generics.Regular.TH + ( 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. + +deriveRegular :: Name -> String -> Q [Dec] +deriveRegular n pfn = + do + pf <- derivePF pfn n + fam <- deriveInst n + return $ pf ++ fam + +-- | Derive only the 'PF' instance. Not needed if 'deriveRegular' +-- is used. + +derivePF :: String -> Name -> Q [Dec] +derivePF pfn 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 . tyVarBndrToName) (ConT t) (typeVariables i) + fcs <- mkFrom t 1 0 t + tcs <- mkTo t 1 0 t + liftM (:[]) $ + instanceD (cxt []) (conT ''Regular `appT` return typ) + [funD 'from fcs, funD 'to tcs] + +constrInstance :: Name -> Q [Dec] +constrInstance 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 (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) + +#ifdef TH_TYVARBNDR +typeVariables :: Info -> [TyVarBndr] +#else +typeVariables :: Info -> [Name] +#endif +typeVariables (TyConI (DataD _ _ tv _ _)) = tv +typeVariables (TyConI (NewtypeD _ _ tv _ _)) = tv +typeVariables _ = [] + +#ifdef TH_TYVARBNDR +tyVarBndrToName :: TyVarBndr -> Name +tyVarBndrToName (PlainTV name) = name +tyVarBndrToName (KindedTV name _) = name +#else +tyVarBndrToName :: Name -> Name +tyVarBndrToName = id +#endif + +stripRecordNames :: Con -> Con +stripRecordNames (RecC n f) = + NormalC n (map (\(_, s, t) -> (s, t)) f) +stripRecordNames c = c + +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 |] + +instance Lift Associativity where + lift LeftAssociative = conE 'LeftAssociative + lift RightAssociative = conE 'RightAssociative + lift NotAssociative = conE 'NotAssociative + +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 $ 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 + convertDirection InfixL = LeftAssociative + 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 _ dt vs cs _) -> + foldr1 sum (map (pfCon (dt, map tyVarBndrToName vs)) cs) + TyConI (NewtypeD _ dt vs c _) -> + pfCon (dt, map tyVarBndrToName vs) c + TyConI (TySynD t _ _) -> + conT ''K `appT` conT t + _ -> error "unknown construct" + --appT b (conT $ mkName (nameBase n)) + b + where + sum :: Q Type -> Q Type -> Q Type + sum a b = conT ''(:+:) `appT` a `appT` b + + +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 (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 + +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@(dt, vs) ns (f, _, t) | t == dataDeclToType d = conT ''S `appT` conT (genName [dt, ns, f]) `appT` 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 b = case i of + TyConI (DataD _ dt vs cs _) -> + zipWith (fromCon wrapE ns (dt, map tyVarBndrToName vs) (length cs)) [0..] cs + TyConI (NewtypeD _ dt vs c _) -> + [fromCon wrapE ns (dt, map tyVarBndrToName vs) 1 0 c] + TyConI (TySynD t _ _) -> + [clause [varP (field 0)] (normalB (wrapE $ conE 'K `appE` varE (field 0))) []] + _ -> error "unknown construct" + return b + +mkTo :: Name -> Int -> Int -> Name -> Q [Q Clause] +mkTo ns m i n = + do + -- runIO $ putStrLn $ "processing " ++ show n + let wrapP p = lrP m i p + i <- reify n + let b = case i of + TyConI (DataD _ dt vs cs _) -> + zipWith (toCon wrapP ns (dt, map tyVarBndrToName vs) (length cs)) [0..] cs + TyConI (NewtypeD _ dt vs c _) -> + [toCon wrapP ns (dt, map tyVarBndrToName 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, [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 (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 (dt, vs)) [0..] (map snd fs))) [] + where + prod x y = conE '(:*:) `appE` x `appE` y +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]) + +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 'S `appE` (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 (dt, vs) m i (NormalC cn fs) = + -- runIO (putStrLn ("constructor " ++ show ix)) >> + clause + [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 (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]) + +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, [Name]) -> Int -> (Name, Strict, Type) -> Q Pat +toField' (dt, vs) nr (_, _, t) | t == dataDeclToType (dt, vs) = conP 'S [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 + +lrP :: Int -> Int -> (Q Pat -> Q Pat) +lrP 1 0 p = p +lrP m 0 p = conP 'L [p] +lrP m i p = conP 'R [lrP (m-1) (i-1) p] + +lrE :: Int -> Int -> (Q Exp -> Q Exp) +lrE 1 0 e = e +lrE m 0 e = conE 'L `appE` e +lrE m i e = conE 'R `appE` lrE (m-1) (i-1) e +