diff --git a/CREDITS b/CREDITS --- a/CREDITS +++ b/CREDITS @@ -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 diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -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 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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. + diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -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 diff --git a/examples/Test.hs b/examples/Test.hs --- a/examples/Test.hs +++ b/examples/Test.hs @@ -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) +-} diff --git a/regular.cabal b/regular.cabal --- a/regular.cabal +++ b/regular.cabal @@ -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 - . - . - \[1] - -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 + . + . + \[1] + +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 diff --git a/src/Generics/Regular.hs b/src/Generics/Regular.hs --- a/src/Generics/Regular.hs +++ b/src/Generics/Regular.hs @@ -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 diff --git a/src/Generics/Regular/Base.hs b/src/Generics/Regular/Base.hs --- a/src/Generics/Regular/Base.hs +++ b/src/Generics/Regular/Base.hs @@ -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) + diff --git a/src/Generics/Regular/Constructor.hs b/src/Generics/Regular/Constructor.hs --- a/src/Generics/Regular/Constructor.hs +++ b/src/Generics/Regular/Constructor.hs @@ -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) diff --git a/src/Generics/Regular/Functions.hs b/src/Generics/Regular/Functions.hs --- a/src/Generics/Regular/Functions.hs +++ b/src/Generics/Regular/Functions.hs @@ -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 diff --git a/src/Generics/Regular/Functions/ConNames.hs b/src/Generics/Regular/Functions/ConNames.hs --- a/src/Generics/Regular/Functions/ConNames.hs +++ b/src/Generics/Regular/Functions/ConNames.hs @@ -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)) + -------------------------------------------------------------------------------- diff --git a/src/Generics/Regular/Functions/Crush.hs b/src/Generics/Regular/Functions/Crush.hs --- a/src/Generics/Regular/Functions/Crush.hs +++ b/src/Generics/Regular/Functions/Crush.hs @@ -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 diff --git a/src/Generics/Regular/Functions/Eq.hs b/src/Generics/Regular/Functions/Eq.hs --- a/src/Generics/Regular/Functions/Eq.hs +++ b/src/Generics/Regular/Functions/Eq.hs @@ -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) diff --git a/src/Generics/Regular/Functions/Fold.hs b/src/Generics/Regular/Functions/Fold.hs --- a/src/Generics/Regular/Functions/Fold.hs +++ b/src/Generics/Regular/Functions/Fold.hs @@ -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) +(&) = (,) + diff --git a/src/Generics/Regular/Functions/GMap.hs b/src/Generics/Regular/Functions/GMap.hs --- a/src/Generics/Regular/Functions/GMap.hs +++ b/src/Generics/Regular/Functions/GMap.hs @@ -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) diff --git a/src/Generics/Regular/Functions/LR.hs b/src/Generics/Regular/Functions/LR.hs --- a/src/Generics/Regular/Functions/LR.hs +++ b/src/Generics/Regular/Functions/LR.hs @@ -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) diff --git a/src/Generics/Regular/Functions/Read.hs b/src/Generics/Regular/Functions/Read.hs --- a/src/Generics/Regular/Functions/Read.hs +++ b/src/Generics/Regular/Functions/Read.hs @@ -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" diff --git a/src/Generics/Regular/Functions/Show.hs b/src/Generics/Regular/Functions/Show.hs --- a/src/Generics/Regular/Functions/Show.hs +++ b/src/Generics/Regular/Functions/Show.hs @@ -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 "" diff --git a/src/Generics/Regular/Functions/Zip.hs b/src/Generics/Regular/Functions/Zip.hs --- a/src/Generics/Regular/Functions/Zip.hs +++ b/src/Generics/Regular/Functions/Zip.hs @@ -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) diff --git a/src/Generics/Regular/Selector.hs b/src/Generics/Regular/Selector.hs --- a/src/Generics/Regular/Selector.hs +++ b/src/Generics/Regular/Selector.hs @@ -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 + diff --git a/src/Generics/Regular/TH.hs b/src/Generics/Regular/TH.hs --- a/src/Generics/Regular/TH.hs +++ b/src/Generics/Regular/TH.hs @@ -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 +