diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ +Copyright (c) 2008 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/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,218 @@ + +Extensible and Modular Generics for the Masses +============================================== + +[Extensible and Modular Generics for the Masses] (EMGM) is a library for generic +programming in Haskell. + +[Extensible and Modular Generics for the Masses]: http://www.cs.uu.nl/wiki/GenericProgramming/EMGM + +Features +-------- + +The primary features of EMGM include: + +* Datatype-generic programming using sum-of-product views +* Large collection of ready-to-use generic functions +* Included support for standard datatypes: lists, Maybe, tuples +* Easy to add support for new datatypes +* Type classes make writing new functions straightforward in a structurally + inductive style +* Generic functions are extensible with ad-hoc cases for arbitrary datatypes +* Good performance of generic functions + +The features of this distribution include: + +* The API is thoroughly documented with Haddock +* Fully tested with QuickCheck and HUnit +* Program coverage ensures that all useful code has been touched by tests +* Tested on both Mac and Windows systems + + +Requirements +------------ + +EMGM has the following requirements: + +* [GHC] 6.8.1 - It has been tested with versions 6.8.3 and 6.9.20080916. +* [Cabal] library 1.2.1 - It has been tested with versions 1.2.3 and 1.4.0.1. + +[GHC]: http://www.haskell.org/ghc/ +[Cabal]: http://www.haskell.org/cabal/ + + +Download & Installation +----------------------- + +*If you have [cabal-install]*, you should use that to install the package, +because it will handle everything for you. + + cabal install emgm + +*If you don't have cabal-install*, you must download the [emgm package] from +the HackageDB and install it manually. Get the `tar.gz` file and decompress it. + +Once downloaded, use the following commands for configuring, building, and +installing the library. + + runghc Setup.lhs configure + runghc Setup.lhs build + runghc Setup.lhs install + +To generate the Haddock documentation, run this commmand: + + runghc Setup.lhs haddock + +For more details on the general options available, refer to the [Cabal User's +Guide]. + +For more details on library-specific options, see the [Development] section. + +[emgm package]: http://hackage.haskell.org/cgi-bin/hackage-scripts/package/emgm +[cabal-install]: http://hackage.haskell.org/cgi-bin/hackage-scripts/package/cabal-install +[Cabal User's Guide]: http://www.haskell.org/cabal/release/latest/doc/users-guide/ +[Development]: #development + + +Documentation +------------- + +The API is documented using [Haddock] and available on the [emgm package] site. + +[Haddock]: http://www.haskell.org/haddock/ +[emgm package]: http://hackage.haskell.org/cgi-bin/hackage-scripts/package/emgm + + +Examples +-------- + +You can find examples of using EMGM in the [`examples` directory] of the source +distribution. + +[`examples` directory]: https://svn.cs.uu.nl:12443/viewvc/dgp-haskell/EMGM/examples/ + + +Bugs & Support +-------------- + +To report bugs, use the Google Code [project page for EMGM]. + +For general concerns and questions, use the [Generics mailing list]. + +[project page for EMGM]: http://code.google.com/p/emgm/ +[Generics mailing list]: http://www.haskell.org/mailman/listinfo/generics + + +Licensing +--------- + +EMGM is licensed under the so-called [BSD3 license]. See the included `LICENSE` +file. + +[BSD3 license]: http://www.opensource.org/licenses/bsd-license.php + + +Credits +------- + +The research for EMGM originated with [Ralf Hinze]. It was extended with work by +[Bruno Oliveira] and [Andres Löh]. More details of the library functionality +were explored by [Alexey Rodriguez]. We are very grateful to all of these people +for the foundation on which this library was built. + +The current authors and maintainers of EMGM are: + +* [Sean Leather] +* [José Pedro Magalhães] +* [Alexey Rodriguez] +* [Andres Löh] + +[Ralf Hinze]: http://www.comlab.ox.ac.uk/ralf.hinze/ +[Bruno Oliveira]: http://web.comlab.ox.ac.uk/people/Bruno.Oliveira/ +[Andres Löh]: http://people.cs.uu.nl/andres/ +[Alexey Rodriguez]: http://www.cs.uu.nl/wiki/Alexey +[Sean Leather]: http://www.cs.uu.nl/staff/leather.html +[José Pedro Magalhães]: http://www.dreixel.net/ + + +Development +----------- + +If you're interesting in contributing to the development of EMGM or just in +playing with the code, there are some useful things to know. + +### Source ### + +The source can be checked out from its repository using [Subversion]. + + svn checkout https://svn.cs.uu.nl:12443/repos/dgp-haskell/EMGM + +You can also [view the files online]. + +[Subversion]: http://subversion.tigris.org/ +[view the files online]: https://svn.cs.uu.nl:12443/viewvc/dgp-haskell/EMGM/ + +### Requirements ### + +In addition to the requirements for using the library, EMGM has the following +requirements for development: + +* Cabal library 1.4.0.1 - This is preferred for uploading to HackageDB. Some + issues were encountered with the current flags setup in emgm.cabal that gave + errors in an older version of Cabal. +* [QuickCheck 2.0] - Required for testing. +* HUnit 1.2 - Required for testing. + +[QuickCheck 2.0]: http://darcs.haskell.org/QuickCheck/ + +### Configuring ### + +If you've been changing many files or the `emgm.cabal` file, you should clean +this distribution and build files. + + runghc Setup.lhs clean + +In order to test the library, configure it with the following options: + + runghc Setup.lhs configure -ftest -fnolib + +This enables building the test executable (while reducing the optimization level +to speed up the build) and disables building the library (thus also speeding up +the build). `nolib` is optional in case you actually do want to build the +library. + +To enable program coverage, add the `hpc` flag. This adds coverage only on the +test executable, so the `test` flag is required. + + runghc Setup.lhs configure -ftest -fnolib -fhpc + +### Testing ### + +After configuring with the `test` flag and building, you can run the test suite. + + runghc Setup.lhs test + +You will see some output from both QuickCheck and HUnit. It should all work! + +### Program coverage ### + +If you have configured the library for HPC (see above), then you can get the +program coverage using the included script after running the test suite. This +uses the `hpc` command in your path and passes a number of flags excluding +modules that should be ignored for coverage purposes. + +Run the script from the top-level directory to see its usage. + + runghc util/hpc.lhs + +To get a simple report of the coverage, use the `report` option. + + runghc util/hpc.lhs report + +To get a set of HTML files with code coverage indications, use the `markup` +option. + + runghc util/hpc.lhs markup + +At the end of this run, the command tells you where to find the HTML files. + diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,23 @@ +#! /usr/bin/env runhaskell + +\begin{code} + +{-# OPTIONS -Wall -fno-warn-missing-signatures #-} + +module Main (main) where + +import Distribution.Simple (defaultMainWithHooks, simpleUserHooks, UserHooks(..)) +import System.Cmd (system) +import System.FilePath (()) + +main :: IO () +main = defaultMainWithHooks hooks where + hooks = simpleUserHooks { runTests = runTests' } + +runTests' _ _ _ _ = system cmd >> return () + where testdir = "dist" "build" "test" + testcmd = "." "test" + cmd = "cd " ++ testdir ++ " && " ++ testcmd + +\end{code} + diff --git a/emgm.cabal b/emgm.cabal new file mode 100644 --- /dev/null +++ b/emgm.cabal @@ -0,0 +1,171 @@ +name: emgm +version: 0.1 +synopsis: Extensible and Modular Generics for the Masses +homepage: http://www.cs.uu.nl/wiki/GenericProgramming/EMGM +description: + + EMGM is a general-purpose library for generic programming with type classes. + . + The design is based on the idea of modeling algebraic datatypes as + sum-of-product structures. Many datatypes can be modeled this way, and, + because they all share a common structure, we can write generic functions that + work on this structure. + . + The library provides three main components: + . + (1) 'Common' - /A common foundation for building generic functions and adding support for datatypes./ + This includes the collection of datatypes (e.g. sum, product, unit) and type + classes (e.g. 'Generic', 'Rep'), that are used throughout the library. This is + what you need to define your own generic functions, to add generic support for + your datatype, or to define ad-hoc cases. + . + (2) 'Functions' - /A collection of useful generic functions./ + These work with a variety of datatypes and provide a wide range of operations. + For example, there is 'crush', a generalization of the fold functions. It is + one of the most useful functions, because it allows you to flexibly extract + the elements of a polymorphic container. + . + (3) 'Data' - /Support for using standard datatypes generically./ + Types such as @[a]@, tuples, and @Maybe@ are built into Haskell or come + included in the standard libraries. EMGM provides full support for generic + functions on these datatypes. The modules in this component are also useful as + guides when adding generic support for your own datatypes. + . + EMGM originated in the research of Ralf Hinze, Bruno Oliveira, and Andres Löh + [1,2]. The library was further explored in a comparison of generic programming + libraries by Alexey Rodriguez, et al [3]. Lastly, this released package was + developed simultaneously with the writing of lecture notes for the 2008 + Advanced Functional Programming Summer School [4] (forthcoming). These are + good resources for learning how the library works and how to use it, but be + aware that names may have been changed to protect the innocent. + . + (1) Ralf Hinze. Generics for the Masses. In ICFP 2004: Proceedings of the 9th ACM + SIGPLAN international conference on Functional programming, pages 236-243. ACM + Press, 2004. + () + . + (2) Bruno C. d. S. Oliveira, Ralf Hinze, and Andres Löh. Extensible and Modular + Generics for the Masses. In Henrik Nilsson, editor, Trends in Functional + Programming, pages 199-216, 2006. + () + . + (3) Alexey Rodriguez, Johan Jeuring, Patrik Jansson, Alex Gerdes, Oleg Kiselyov, + and Bruno C. d. S. Oliveira. Comparing Libraries for Generic Programming in + Haskell. Technical Report UU-CS-2008-010. Department of Information and + Computing Sciences, Utrecht University. + () + . + (4) Johan Jeuring, Sean Leather, José Pedro Magalhães, and Alexey Rodriguez + Yakushev. Libraries for Generic Programming in Haskell. Technical Report + UU-CS-2008-025. Department of Information and Computing Sciences, Utrecht + University. + () + +category: Generics +copyright: (c) 2008 Universiteit Utrecht +license: BSD3 +license-file: LICENSE +author: Sean Leather, + José Pedro Magalhães, + Alexey Rodriguez, + Andres Löh +maintainer: generics@haskell.org +stability: experimental +extra-source-files: README +extra-tmp-files: .hpc +build-type: Custom +cabal-version: >= 1.2.1 +tested-with: GHC == 6.8.3, GHC == 6.9.20080916 + +-------------------------------------------------------------------------------- + +flag test + description: Enable the test configuration: Build the test + executable, reduce build time. + default: False + +flag hpc + description: Enable program coverage on test executable. + default: False + +flag nolib + description: Don't build the library. This is useful for speeding up + the modify-build-test loop. With "-ftest" (only), the + build command will build both the library and the test + executable. With "-ftest -fnolib", the build command + builds only the test executable. + default: False + +-------------------------------------------------------------------------------- + +Library + hs-source-dirs: src + exposed-modules: Generics.EMGM + + -- Common foundation + Generics.EMGM.Common + Generics.EMGM.Common.Representation + Generics.EMGM.Common.Base + Generics.EMGM.Common.Base2 + Generics.EMGM.Common.Base3 + + -- Generic functions + Generics.EMGM.Functions + Generics.EMGM.Functions.Collect + Generics.EMGM.Functions.Compare + Generics.EMGM.Functions.Crush + Generics.EMGM.Functions.Enum + Generics.EMGM.Functions.Map + Generics.EMGM.Functions.Read + Generics.EMGM.Functions.Show + Generics.EMGM.Functions.ZipWith + Generics.EMGM.Functions.UnzipWith + + -- Supported datatypes + Generics.EMGM.Data + Generics.EMGM.Data.Bool + Generics.EMGM.Data.Either + Generics.EMGM.Data.List + Generics.EMGM.Data.Maybe + Generics.EMGM.Data.Tuple + + build-depends: base >= 3.0 + extensions: CPP + + ghc-options: -Wall + if flag(test) + -- Faster build + ghc-options: -O0 + else + -- Smaller binary, more optimized? + ghc-options: -O2 + + -- This adds even more optimization, but slows the build down a lot (e.g. + -- 5x) I think we shouldn't use it unless we can prove the benefit. [SPL] + --ghc-options: -fvia-C -optc-O3 + + -- Don't build the library + if flag(nolib) + buildable: False + +-------------------------------------------------------------------------------- + +Executable test + hs-source-dirs: src, tests, examples + other-modules: Generics.EMGM + extensions: CPP + main-is: Main.hs + + ghc-options: -Wall -O0 -fno-warn-missing-signatures + + -- Add program coverage if configured with "-fhpc". + if flag(hpc) + ghc-options: -fhpc + + -- Only enable the build-depends here if configured with "-ftest". This + -- keeps users from having to install QuickCheck 2 in order to use EMGM. + if flag(test) + build-depends: QuickCheck >= 2.0, HUnit >= 1.2 + else + buildable: False + diff --git a/src/Generics/EMGM.hs b/src/Generics/EMGM.hs new file mode 100644 --- /dev/null +++ b/src/Generics/EMGM.hs @@ -0,0 +1,34 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Generics.EMGM +-- Copyright : (c) 2008 Universiteit Utrecht +-- License : BSD3 +-- +-- Maintainer : generics@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- \"Extensible and Modular Generics for the Masses\" --- EMGM. +-- +-- This top-level module re-exports all other modules of the +-- Generics.EMGM library. +-- +----------------------------------------------------------------------------- + +module Generics.EMGM ( + + -- * Common foundation + module Generics.EMGM.Common, + + -- * Generic functions + module Generics.EMGM.Functions, + + -- * Supported datatypes + module Generics.EMGM.Data, + +) where + +import Generics.EMGM.Common +import Generics.EMGM.Functions +import Generics.EMGM.Data + diff --git a/src/Generics/EMGM/Common.hs b/src/Generics/EMGM/Common.hs new file mode 100644 --- /dev/null +++ b/src/Generics/EMGM/Common.hs @@ -0,0 +1,27 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Generics.EMGM.Common +-- Copyright : (c) 2008 Universiteit Utrecht +-- License : BSD3 +-- +-- Maintainer : generics@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- Exports all modules in the Generics.EMGM.Common.* hierarchy. +----------------------------------------------------------------------------- + +module Generics.EMGM.Common ( + + module Generics.EMGM.Common.Representation, + module Generics.EMGM.Common.Base, + module Generics.EMGM.Common.Base2, + module Generics.EMGM.Common.Base3, + +) where + +import Generics.EMGM.Common.Representation +import Generics.EMGM.Common.Base +import Generics.EMGM.Common.Base2 +import Generics.EMGM.Common.Base3 + diff --git a/src/Generics/EMGM/Common/Base.hs b/src/Generics/EMGM/Common/Base.hs new file mode 100644 --- /dev/null +++ b/src/Generics/EMGM/Common/Base.hs @@ -0,0 +1,173 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE OverlappingInstances #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Generics.EMGM.Common.Base +-- Copyright : (c) 2008 Universiteit Utrecht +-- License : BSD3 +-- +-- Maintainer : generics@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- Summary: Type classes used for generic functions with /one/ generic argument. +-- +-- Generic functions using one generic argument are defined as instances of +-- 'Generic'. This class contains all of the methods (called \"type cases\" in +-- datatype-generic language) used to define the run-time type representation of +-- a datatype. +-- +-- To simplify generic functions, we use type classes for representation +-- dispatching. There are \"dispatchers\" for each category of function (see +-- below) and each category has one \"Rep\" class. +-- +-- Some 'Generic'-based functions operate on monomorphic values (using 'Rep'). +-- The functions included with the library are: +-- +-- * "Generics.EMGM.Functions.Collect" +-- +-- * "Generics.EMGM.Functions.Compare" +-- +-- * "Generics.EMGM.Functions.Enum" +-- +-- * "Generics.EMGM.Functions.Read" +-- +-- * "Generics.EMGM.Functions.Show" +-- +-- Other 'Generic'-based functions operate on types of the form @f a@ (using +-- 'FRep') where @f@ is the actual generic argument (the one that needs a +-- run-time representation). The functions included with the library are: +-- +-- * "Generics.EMGM.Functions.Crush" +----------------------------------------------------------------------------- + +module Generics.EMGM.Common.Base ( + + -- * Generic function class + Generic(..), + + -- * Representation dispatcher classes + Rep(..), + FRep(..), +) where + +import Generics.EMGM.Common.Representation + +infixr 5 `rsum` +infixr 6 `rprod` + +-- | This class forms the foundation for defining generic functions with a +-- single generic argument. Each method represents a type case. The class +-- includes cases for primitive types, cases for the structural representation, +-- and the 'rtype' case for adding support for new datatypes. +class Generic g where + + -- | Many functions perform the same operation on the non-structural cases (as + -- well as 'Unit'). The cases for constant datatypes ('Int', 'Integer', + -- 'Float', 'Double', 'Char', and 'Unit') have a default implementation of + -- 'rconstant', thus a generic function may only override 'rconstant' if + -- desired. Note that there is no default implementation for 'rconstant' + -- itself. + -- + -- The class context represents the intersection set of supported type + -- classes. + rconstant :: (Enum a, Eq a, Ord a, Read a, Show a) => g a + + -- | Case for the primitive type 'Int'. (Default implementation: + -- 'rconstant'.) + rint :: g Int + + -- | Case for the primitive type 'Integer'. (Default implementation: + -- 'rconstant'.) + rinteger :: g Integer + + -- | Case for the primitive type 'Float'. (Default implementation: + -- 'rconstant'.) + rfloat :: g Float + + -- | Case for the primitive type 'Double'. (Default implementation: + -- 'rconstant'.) + rdouble :: g Double + + -- | Case for the primitive type 'Char'. (Default implementation: + -- 'rconstant'.) + rchar :: g Char + + -- | Case for the structural representation type 'Unit'. It is used to + -- represent a constructor with no arguments. (Default implementation: + -- 'rconstant'.) + runit :: g Unit + + -- | Case for the structural representation type '(:+:)', called \"sum\". It + -- is used to represent alternative choices between constructors. (No + -- default implementation.) + rsum :: g a -> g b -> g (a :+: b) + + -- | Case for the structural representation type '(:*:)', called \"product\". + -- It is used to represent multiple arguments to a constructor. (No + -- default implementation.) + rprod :: g a -> g b -> g (a :*: b) + + -- | Case for constructors. While not necessary for every generic function, + -- this method is required for 'Read' and 'Show'. It is used to hold the + -- meta-information about a constructor ('ConDescr'), e.g. name, arity, + -- fixity, etc. (Since most generic functions do not use 'rcon' and simply pass + -- the value through, the default implementation is @const id@.) + rcon :: ConDescr -> g a -> g a + + -- | Case for datatypes. This method is used to define the structural + -- representation of an arbitrary Haskell datatype. The first argument is the + -- embedding-projection pair, necessary for establishing the isomorphism + -- between datatype and representation. The second argument is the + -- run-time representation using the methods of 'Generic'. (No default + -- implementation.) + rtype :: EP b a -> g a -> g b + + rint = rconstant + rinteger = rconstant + rfloat = rconstant + rdouble = rconstant + rchar = rconstant + runit = rconstant + + rcon = const id + +-- | The 'Generic' representation dispatcher for monomorphic types (kind @*@). +-- Every structure type and supported datatype should have an instance of +-- 'Rep'. (No default implementation.) +class Rep g a where + rep :: g a + +instance (Generic g) => Rep g Int where + rep = rint + +instance (Generic g) => Rep g Integer where + rep = rinteger + +instance (Generic g) => Rep g Float where + rep = rfloat + +instance (Generic g) => Rep g Double where + rep = rdouble + +instance (Generic g) => Rep g Char where + rep = rchar + +instance (Generic g) => Rep g Unit where + rep = runit + +instance (Generic g, Rep g a, Rep g b) => Rep g (a :+: b) where + rep = rsum rep rep + +instance (Generic g, Rep g a, Rep g b) => Rep g (a :*: b) where + rep = rprod rep rep + +-- | The 'Generic' representation dispatcher for datatypes of functional kind +-- @* -> *@, often called container types, type constructors, or functor types. +-- (No default implementation.) +class FRep g f where + frep :: g a -> g (f a) + diff --git a/src/Generics/EMGM/Common/Base2.hs b/src/Generics/EMGM/Common/Base2.hs new file mode 100644 --- /dev/null +++ b/src/Generics/EMGM/Common/Base2.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeOperators #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Generics.EMGM.Common.Base2 +-- Copyright : (c) 2008 Universiteit Utrecht +-- License : BSD3 +-- +-- Maintainer : generics@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- Summary: Type classes used for generic functions with /two/ generic +-- arguments. +-- +-- Generic functions using two generic arguments are defined as instances of +-- 'Generic2'. This class contains all of the methods (called \"type cases\" in +-- datatype-generic language) used to define the run-time type representation of +-- a datatype. +-- +-- 'Generic2'-based functions have a representation dispatcher type class +-- 'FRep2'. +-- +-- The functions included with the library are: +-- +-- * "Generics.EMGM.Functions.Map" +----------------------------------------------------------------------------- + +module Generics.EMGM.Common.Base2 ( + + -- * Generic function class + Generic2(..), + + -- * Representation dispatcher classes + FRep2(..), +) where + +import Generics.EMGM.Common.Representation + +infixr 5 `rsum2` +infixr 6 `rprod2` + +-- | This class forms the foundation for defining generic functions with two +-- generic arguments. Each method represents a type case. The class includes +-- cases for primitive types, cases for the structural representation, and the +-- 'rtype' case for adding support for new datatypes. +class Generic2 g where + + -- | Many functions perform the same operation on the non-structural cases (as + -- well as 'Unit'). The cases for constant datatypes ('Int', 'Integer', + -- 'Float', 'Double', 'Char', and 'Unit') have a default implementation of + -- 'rconstant2', thus a generic function may only override 'rconstant2' if + -- desired. Note that there is no default implementation for 'rconstant2' + -- itself. + -- + -- The class context represents the intersection set of supported type + -- classes. + rconstant2 :: (Enum a, Eq a, Ord a, Read a, Show a) => g a a + + -- | Case for the primitive type 'Int'. (Default implementation: + -- 'rconstant2'.) + rint2 :: g Int Int + + -- | Case for the primitive type 'Integer'. (Default implementation: + -- 'rconstant2'.) + rinteger2 :: g Integer Integer + + -- | Case for the primitive type 'Float'. (Default implementation: + -- 'rconstant2'.) + rfloat2 :: g Float Float + + -- | Case for the primitive type 'Double'. (Default implementation: + -- 'rconstant2'.) + rdouble2 :: g Double Double + + -- | Case for the primitive type 'Char'. (Default implementation: + -- 'rconstant2'.) + rchar2 :: g Char Char + + -- | Case for the structural representation type 'Unit'. It is used to + -- represent a constructor with no arguments. (Default implementation: + -- 'rconstant2'.) + runit2 :: g Unit Unit + + -- | Case for the structural representation type '(:+:)', called \"sum\". It + -- is used to represent alternative choices between constructors. (No + -- default implementation.) + rsum2 :: g a1 a2 -> g b1 b2 -> g (a1 :+: b1) (a2 :+: b2) + + -- | Case for the structural representation type '(:*:)', called \"product\". + -- It is used to represent multiple arguments to a constructor. (No + -- default implementation.) + rprod2 :: g a1 a2 -> g b1 b2 -> g (a1 :*: b1) (a2 :*: b2) + + -- | Case for constructors. It is used to hold the meta-information about a + -- constructor ('ConDescr'), e.g. name, arity, fixity, etc. (Since most + -- generic functions do not use 'rcon' and simply pass the value through, the + -- default implementation is @const id@.) + rcon2 :: ConDescr -> g a1 a2 -> g a1 a2 + + -- | Case for datatypes. This method is used to define the structural + -- representation of an arbitrary Haskell datatype. The first two arguments + -- are the embedding-projection pairs, necessary for establishing the + -- isomorphisms between datatype and representation of the two generic types. + -- The third argument is the run-time representation using the methods of + -- 'Generic2'. (No default implementation.) + rtype2 :: EP a2 a1 -> EP b2 b1 -> g a1 b1 -> g a2 b2 + + rint2 = rconstant2 + rinteger2 = rconstant2 + rfloat2 = rconstant2 + rdouble2 = rconstant2 + rchar2 = rconstant2 + runit2 = rconstant2 + + rcon2 = const id + +-- | The 'Generic2' representation dispatcher for datatypes of functional kind +-- @* -> *@, often called container types, type constructors, or functor types. +-- (No default implementation.) +class FRep2 g f where + frep2 :: g a b -> g (f a) (f b) + diff --git a/src/Generics/EMGM/Common/Base3.hs b/src/Generics/EMGM/Common/Base3.hs new file mode 100644 --- /dev/null +++ b/src/Generics/EMGM/Common/Base3.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeOperators #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Generics.EMGM.Common.Base3 +-- Copyright : (c) 2008 Universiteit Utrecht +-- License : BSD3 +-- +-- Maintainer : generics@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- Summary: Type classes used for generic functions with /three/ generic +-- arguments. +-- +-- Generic functions using three generic arguments are defined as instances of +-- 'Generic3'. This class contains all of the methods (called \"type cases\" in +-- datatype-generic language) used to define the run-time type representation of +-- a datatype. +-- +-- 'Generic3'-based functions have a non-extensible representation dispatcher +-- type class, 'FRep3'. +-- +-- The functions included with the library are: +-- +-- * "Generics.EMGM.Functions.UnzipWith" +-- +-- * "Generics.EMGM.Functions.ZipWith" +----------------------------------------------------------------------------- + +module Generics.EMGM.Common.Base3 ( + + -- * Generic function class + Generic3(..), + + -- * Representation dispatcher classes + FRep3(..), +) where + +import Generics.EMGM.Common.Representation + +infixr 5 `rsum3` +infixr 6 `rprod3` + +-- | This class forms the foundation for defining generic functions with three +-- generic arguments. Each method represents a type case. The class includes +-- cases for primitive types, cases for the structural representation, and the +-- 'rtype' case for adding support for new datatypes. +class Generic3 g where + + -- | Many functions perform the same operation on the non-structural cases (as + -- well as 'Unit'). The cases for constant datatypes ('Int', 'Integer', + -- 'Float', 'Double', 'Char', and 'Unit') have a default implementation of + -- 'rconstant3', thus a generic function may only override 'rconstant3' if + -- desired. Note that there is no default implementation for 'rconstant3' + -- itself. + -- + -- The class context represents the intersection set of supported type + -- classes. + rconstant3 :: (Enum a, Eq a, Ord a, Read a, Show a) => g a a a + + -- | Case for the primitive type 'Int'. (Default implementation: + -- 'rconstant3'.) + rint3 :: g Int Int Int + + -- | Case for the primitive type 'Integer'. (Default implementation: + -- 'rconstant3'.) + rinteger3 :: g Integer Integer Integer + + -- | Case for the primitive type 'Float'. (Default implementation: + -- 'rconstant3'.) + rfloat3 :: g Float Float Float + + -- | Case for the primitive type 'Double'. (Default implementation: + -- 'rconstant3'.) + rdouble3 :: g Double Double Double + + -- | Case for the primitive type 'Char'. (Default implementation: + -- 'rconstant3'.) + rchar3 :: g Char Char Char + + -- | Case for the structural representation type 'Unit'. It is used to + -- represent a constructor with no arguments. (Default implementation: + -- 'rconstant3'.) + runit3 :: g Unit Unit Unit + + -- | Case for the structural representation type '(:+:)', called \"sum\". It + -- is used to represent alternative choices between constructors. (No + -- default implementation.) + rsum3 :: g a1 a2 a3 -> g b1 b2 b3 -> g (a1 :+: b1) (a2 :+: b2) (a3 :+: b3) + + -- | Case for the structural representation type '(:*:)', called \"product\". + -- It is used to represent multiple arguments to a constructor. (No + -- default implementation.) + rprod3 :: g a1 a2 a3 -> g b1 b2 b3 -> g (a1 :*: b1) (a2 :*: b2) (a3 :*: b3) + + -- | Case for constructors. It is used to hold the meta-information about a + -- constructor ('ConDescr'), e.g. name, arity, fixity, etc. (Since most + -- generic functions do not use 'rcon' and simply pass the value through, the + -- default implementation is @const id@.) + rcon3 :: ConDescr -> g a1 a2 a3 -> g a1 a2 a3 + + -- | Case for datatypes. This method is used to define the structural + -- representation of an arbitrary Haskell datatype. The first three arguments + -- are the embedding-projection pairs, necessary for establishing the + -- isomorphisms between datatype and representation of the four generic types. + -- The fourth argument is the run-time representation using the methods of + -- 'Generic3'. (No default implementation.) + rtype3 :: EP a2 a1 -> EP b2 b1 -> EP c2 c1 -> g a1 b1 c1 -> g a2 b2 c2 + + rint3 = rconstant3 + rinteger3 = rconstant3 + rfloat3 = rconstant3 + rdouble3 = rconstant3 + rchar3 = rconstant3 + runit3 = rconstant3 + + rcon3 = const id + +-- | The 'Generic3' representation dispatcher for datatypes of functional kind +-- @* -> *@, often called container types, type constructors, or functor types. +-- (No default implementation.) +class FRep3 g f where + frep3 :: g a b c -> g (f a) (f b) (f c) + diff --git a/src/Generics/EMGM/Common/Representation.hs b/src/Generics/EMGM/Common/Representation.hs new file mode 100644 --- /dev/null +++ b/src/Generics/EMGM/Common/Representation.hs @@ -0,0 +1,169 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Generics.EMGM.Common.Representation +-- Copyright : (c) 2008 Universiteit Utrecht +-- License : BSD3 +-- +-- Maintainer : generics@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- Summary: Types and related functions for the representation used in EMGM. +-- +-- EMGM uses a generic sum-of-products view of datatypes encoded into the +-- 'Unit', '(:^:)' (sum), and '(:*:)' (product). Many Haskell datatypes can be +-- represented in this way. Right-nested sums replace the @|@, and right-nested +-- products replace the arguments to a constructor. Units replace constructors +-- with no arguments. +-- +-- Since constructors encode more than just a list of arguments, this library +-- uses 'ConDescr' to store that information. This includes name, arity, record +-- labels, fixity, and operator precedence. Constructor descriptions are useful +-- for generic operations such as 'Read' and 'Show' and possibly others. +-- +-- Generic functions need to convert values between the Haskell datatype and its +-- structure representation. This is done using the embedding-projection pair, +-- which is simply a pair a functions for translating between two types. +-- +----------------------------------------------------------------------------- + +module Generics.EMGM.Common.Representation ( + + -- * Structure representation + -- | The generic sum-of-products view of a Haskell datatype. + + Unit(..), + (:+:)(..), + (:*:)(..), + + -- * Constructor description + -- | Since this library does not have access to the syntax of a @data@ + -- declaration, it relies on 'ConDescr' for meta-information. It is + -- important that the 'ConDescr' for a constructor accurately describe the + -- actual syntax in the declaration. An incorrect description may lead to + -- bad 'Read' or 'Show' operation. + + ConDescr(..), + ConType(..), + + -- * Fixity and precedence + -- | These are used to determine whether a constructor is infix or not and, if + -- it is infix, what its associativity and precedence are. + + Fixity(..), + Prec, + prec, + minPrec, + maxPrec, + appPrec, + recPrec, + + -- * Embedding-projection pair + + EP(..), + + ) where + +import Text.ParserCombinators.ReadPrec (minPrec, Prec) + +infixr 5 :+: +infixr 6 :*: + +-- | 'Unit' encodes a constructor with no arguments. An analogous standard +-- Haskell type is @()@. +data Unit + = Unit -- ^ The only value of type 'Unit' (ignoring @_|_@). + deriving (Enum, Eq, Ord) + +-- | The Read instance for Unit should always return a value and consume nothing +-- of the input, because there is no string representation for it. This allows +-- us to use 'readPrec' in the 'rconstant' method of the generic 'Read' +-- definition. +instance Read Unit where + readsPrec _ s = [(Unit, s)] + +-- | The Show instance for Unit should return an empty string, because there is +-- no representation for it. This allows us to use 'showsPrec' in the +-- 'rconstant' method of the generic 'Show' definition. +instance Show Unit where + showsPrec _ _ = id + +-- | The \"sum\" encodes 2 constructor alternatives. An analogous standard +-- Haskell type is @'Either' a b@. +data a :+: b + = L a -- ^ Left alternative + | R b -- ^ Right alternative + deriving (Eq, Ord, Read, Show) + +-- | The \"product\" encodes 2 constructor arguments. An analogous standard +-- Haskell type is @(a, b)@. +data a :*: b + = a :*: b -- ^ A pair of arguments + deriving (Eq, Ord, Read, Show) + +-- | The Embedding-Projection pair contains two functions for converting between +-- the datatype and its representation. This pair preserves an isomorphism +-- (ignoring @_|_@s) between a datatype and its structure. +data EP d r + = EP + { from :: (d -> r) -- ^ Embed a @d@atatype into its @r@epresentation. + , to :: (r -> d) -- ^ Project @d@atatype from its @r@epresentation. + } + +-- | A constructor description containing useful meta-information about the +-- syntax used in the data declaration. This is particularly useful in 'Read' +-- and 'Show' but may also be helpful in other generic functions. +data ConDescr + = ConDescr + { conName :: String -- ^ Name of the constructor. If it is infix, + -- don't provide parentheses. + + , conArity :: Int -- ^ Arity or number of arguments. + + , conLabels :: [String] -- ^ A list of labels used in record syntax. + -- They must be declared in the same order as + -- the @data@ declaration. The list should be + -- empty if the constructor is not a record. + + , conFixity :: Fixity -- ^ Infix or not, associativity, precedence. + } + deriving Show + +-- | The constructor type used in 'Read' and 'Show' to determine how to parse or +-- print the constructor. +data ConType + = ConStd -- ^ Standard (function-type, nonfix) + | ConRec [String] -- ^ Record-style (nonfix or infix) + | ConIfx String -- ^ Infix (no record syntax) + deriving Show + +-- TODO: Need smart constructor(s) for ConDescr, so we can verify things. + +-- | Determine an identifier's status as infix or not. If infix, the +-- associativity and precedence are also determined. +data Fixity + = Nonfix -- ^ Not infix. Precedence is same as function application (see 'appPrec'). + | Infix Prec -- ^ Non-associative infix with precedence. + | Infixl Prec -- ^ Left-associative infix with precedence. + | Infixr Prec -- ^ Right-associative Infix with precedence. + deriving (Eq, Show) + +-- | Get the precedence of a fixity value. +prec :: Fixity -> Prec +prec Nonfix = appPrec +prec (Infix n) = n +prec (Infixl n) = n +prec (Infixr n) = n + +-- | Maximum precedence: 11 +maxPrec :: Prec +maxPrec = 11 + +-- | Precedence for function application: 10 +appPrec :: Prec +appPrec = 10 + +-- | Precedence for record construction: 11 +recPrec :: Prec +recPrec = appPrec + 1 + diff --git a/src/Generics/EMGM/Data.hs b/src/Generics/EMGM/Data.hs new file mode 100644 --- /dev/null +++ b/src/Generics/EMGM/Data.hs @@ -0,0 +1,29 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Generics.EMGM.Data +-- Copyright : (c) 2008 Universiteit Utrecht +-- License : BSD3 +-- +-- Maintainer : generics@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- Exports all modules in the Generics.EMGM.Data.* hierarchy. +----------------------------------------------------------------------------- + +module Generics.EMGM.Data ( + + module Generics.EMGM.Data.Bool, + module Generics.EMGM.Data.Either, + module Generics.EMGM.Data.List, + module Generics.EMGM.Data.Maybe, + module Generics.EMGM.Data.Tuple, + +) where + +import Generics.EMGM.Data.Bool +import Generics.EMGM.Data.Either +import Generics.EMGM.Data.List +import Generics.EMGM.Data.Maybe +import Generics.EMGM.Data.Tuple + diff --git a/src/Generics/EMGM/Data/Bool.hs b/src/Generics/EMGM/Data/Bool.hs new file mode 100644 --- /dev/null +++ b/src/Generics/EMGM/Data/Bool.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE OverlappingInstances #-} +{-# OPTIONS -fno-warn-orphans #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Generics.EMGM.Data.Bool +-- Copyright : (c) 2008 Universiteit Utrecht +-- License : BSD3 +-- +-- Maintainer : generics@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- Summary: Generic representation and instances for 'Bool'. +-- +-- This module exports the reusable components of the 'Bool' +-- representation. These include the embedding-projection pair used in a type +-- representation as well as the type representation of 'Bool' for +-- 'Generic'. +-- +-- This module also exports the instance for the representation dispatcher +-- 'Rep'. +----------------------------------------------------------------------------- + +module Generics.EMGM.Data.Bool ( + + -- * Embedding-projection pair + epBool, + + -- * Representation + rBool, +) where + +import Generics.EMGM.Common + +----------------------------------------------------------------------------- +-- Embedding-projection pair +----------------------------------------------------------------------------- + +fromBool :: Bool -> Unit :+: Unit +fromBool False = L Unit +fromBool True = R Unit + +toBool :: Unit :+: Unit -> Bool +toBool (L Unit) = False +toBool (R Unit) = True + +-- | Embedding-projection pair for @Bool@ +epBool :: EP Bool (Unit :+: Unit) +epBool = EP fromBool toBool + +----------------------------------------------------------------------------- +-- Representation values +----------------------------------------------------------------------------- + +conFalse, conTrue :: ConDescr +conFalse = ConDescr "False" 0 [] Nonfix +conTrue = ConDescr "True" 0 [] Nonfix + +-- | Representation for @Bool@ in 'Generic' +rBool :: (Generic g) => g Bool +rBool = rtype epBool (rcon conFalse runit `rsum` rcon conTrue runit) + +----------------------------------------------------------------------------- +-- Instance declarations +----------------------------------------------------------------------------- + +instance (Generic g) => Rep g Bool where + rep = rBool + diff --git a/src/Generics/EMGM/Data/Either.hs b/src/Generics/EMGM/Data/Either.hs new file mode 100644 --- /dev/null +++ b/src/Generics/EMGM/Data/Either.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE OverlappingInstances #-} +{-# OPTIONS -fno-warn-orphans #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Generics.EMGM.Data.Either +-- Copyright : (c) 2008 Universiteit Utrecht +-- License : BSD3 +-- +-- Maintainer : generics@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- Summary: Generic representation and instances for @'Either' a b@. +-- +-- This module exports the reusable components of the @'Either' a b@ +-- representation. These include the embedding-projection pair used in a type +-- representation as well as the type representation of @'Either' a b@ for +-- 'Generic'. +-- +-- This module also exports the instance for the representation dispatcher +-- 'Rep'. +----------------------------------------------------------------------------- + +module Generics.EMGM.Data.Either ( + + -- * Embedding-projection pair + epEither, + + -- * Representation + rEither, +) where + +import Generics.EMGM.Common + +----------------------------------------------------------------------------- +-- Embedding-projection pair +----------------------------------------------------------------------------- + +fromEither :: Either a b -> a :+: b +fromEither (Left a) = L a +fromEither (Right b) = R b + +toEither :: a :+: b -> Either a b +toEither (L a) = Left a +toEither (R b) = Right b + +-- | Embedding-projection pair for @Either a b@ +epEither :: EP (Either a b) (a :+: b) +epEither = EP fromEither toEither + +----------------------------------------------------------------------------- +-- Representation values +----------------------------------------------------------------------------- + +conLeft, conRight :: ConDescr +conLeft = ConDescr "Left" 1 [] Nonfix +conRight = ConDescr "Right" 1 [] Nonfix + +-- | Representation for @Either a b@ in 'Generic' +rEither :: (Generic g) => g a -> g b -> g (Either a b) +rEither ra rb = rtype epEither (rcon conLeft ra `rsum` rcon conRight rb) + +----------------------------------------------------------------------------- +-- Instance declarations +----------------------------------------------------------------------------- + +instance (Generic g, Rep g a, Rep g b) => Rep g (Either a b) where + rep = rEither rep rep + diff --git a/src/Generics/EMGM/Data/List.hs b/src/Generics/EMGM/Data/List.hs new file mode 100644 --- /dev/null +++ b/src/Generics/EMGM/Data/List.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverlappingInstances #-} +{-# OPTIONS -fno-warn-orphans #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Generics.EMGM.Data.List +-- Copyright : (c) 2008 Universiteit Utrecht +-- License : BSD3 +-- +-- Maintainer : generics@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- Summary: Generic representation and instances for @[a]@. +-- +-- This module exports the reusable components of the @[a]@ representation. +-- These include the embedding-projection pair used in a type representation as +-- well as the type representations of @[a]@ for 'Generic', 'Generic2', and +-- 'Generic3'. +-- +-- This module also exports the instances for the representation dispatchers +-- 'Rep', 'FRep', 'FRep2', and 'FRep3'. +----------------------------------------------------------------------------- + +module Generics.EMGM.Data.List ( + + -- * Embedding-projection pair + epList, + + -- * Representations + rList, + rList2, + rList3 +) where + +import Generics.EMGM.Common + +----------------------------------------------------------------------------- +-- Embedding-projection pair +----------------------------------------------------------------------------- + +fromList :: [a] -> Unit :+: (a :*: [a]) +fromList [] = L Unit +fromList (a : as) = R (a :*: as) + +toList :: Unit :+: (a :*: [a]) -> [a] +toList (L Unit) = [] +toList (R (a :*: as)) = a : as + +-- | Embedding-projection pair for @[a]@ +epList :: EP [a] (Unit :+: (a :*: [a])) +epList = EP fromList toList + +----------------------------------------------------------------------------- +-- Representation values +----------------------------------------------------------------------------- + +conNil, conCons :: ConDescr +conNil = ConDescr "[]" 0 [] Nonfix +conCons = ConDescr ":" 2 [] (Infixr 5) + +-- | Representation for @[a]@ in 'Generic' +rList :: (Generic g) => g a -> g [a] +rList ra = + rtype epList + (rcon conNil runit `rsum` rcon conCons (ra `rprod` rList ra)) + +-- | Representation for @[a]@ in 'Generic2' +rList2 :: (Generic2 g) => g a b -> g [a] [b] +rList2 ra = + rtype2 epList epList + (rcon2 conNil runit2 `rsum2` rcon2 conCons (ra `rprod2` rList2 ra)) + +-- | Representation for @[a]@ in 'Generic3' +rList3 :: (Generic3 g) => g a b c -> g [a] [b] [c] +rList3 ra = + rtype3 epList epList epList + (rcon3 conNil runit3 `rsum3` rcon3 conCons (ra `rprod3` rList3 ra)) + +----------------------------------------------------------------------------- +-- Instance declarations +----------------------------------------------------------------------------- + +instance (Generic g, Rep g a) => Rep g [a] where + rep = rList rep + +instance (Generic g) => FRep g [] where + frep = rList + +instance (Generic2 g) => FRep2 g [] where + frep2 = rList2 + +instance (Generic3 g) => FRep3 g [] where + frep3 = rList3 + diff --git a/src/Generics/EMGM/Data/Maybe.hs b/src/Generics/EMGM/Data/Maybe.hs new file mode 100644 --- /dev/null +++ b/src/Generics/EMGM/Data/Maybe.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE OverlappingInstances #-} +{-# OPTIONS -fno-warn-orphans #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Generics.EMGM.Data.Maybe +-- Copyright : (c) 2008 Universiteit Utrecht +-- License : BSD3 +-- +-- Maintainer : generics@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- Summary: Generic representation and instances for @'Maybe' a@. +-- +-- This module exports the reusable components of the @'Maybe' a@ representation. +-- These include the embedding-projection pair used in a type representation as +-- well as the type representations of @'Maybe' a@ for 'Generic', 'Generic2', +-- and 'Generic3'. +-- +-- This module also exports the instances for the representation dispatchers +-- 'Rep', 'FRep', 'FRep2', and 'FRep3'. +-- +----------------------------------------------------------------------------- + +module Generics.EMGM.Data.Maybe ( + + -- * Embedding-projection pair + epMaybe, + + -- * Representations + rMaybe, + rMaybe2, + rMaybe3, +) where + +import Generics.EMGM.Common + +----------------------------------------------------------------------------- +-- Embedding-projection pair +----------------------------------------------------------------------------- + +fromMaybe :: Maybe a -> Unit :+: a +fromMaybe Nothing = L Unit +fromMaybe (Just a) = R a + +toMaybe :: Unit :+: a -> Maybe a +toMaybe (L Unit) = Nothing +toMaybe (R a) = Just a + +-- | Embedding-projection pair for @Maybe a@ +epMaybe :: EP (Maybe a) (Unit :+: a) +epMaybe = EP fromMaybe toMaybe + +----------------------------------------------------------------------------- +-- Representation values +----------------------------------------------------------------------------- + +conNothing, conJust :: ConDescr +conNothing = ConDescr "Nothing" 0 [] Nonfix +conJust = ConDescr "Just" 1 [] Nonfix + +-- | Representation for @Maybe a@ in 'Generic' +rMaybe :: (Generic g) => g a -> g (Maybe a) +rMaybe ra = + rtype epMaybe + (rcon conNothing runit `rsum` rcon conJust ra) + +-- | Representation for @Maybe a@ in 'Generic2' +rMaybe2 :: (Generic2 g) => g a b -> g (Maybe a) (Maybe b) +rMaybe2 ra = + rtype2 epMaybe epMaybe + (rcon2 conNothing runit2 `rsum2` rcon2 conJust ra) + +-- | Representation for @Maybe a@ in 'Generic3' +rMaybe3 :: (Generic3 g) => g a b c -> g (Maybe a) (Maybe b) (Maybe c) +rMaybe3 ra = + rtype3 epMaybe epMaybe epMaybe + (rcon3 conNothing runit3 `rsum3` rcon3 conJust ra) + +----------------------------------------------------------------------------- +-- Instance declarations +----------------------------------------------------------------------------- + +instance (Generic g, Rep g a) => Rep g (Maybe a) where + rep = rMaybe rep + +instance (Generic g) => FRep g Maybe where + frep = rMaybe + +instance (Generic2 g) => FRep2 g Maybe where + frep2 = rMaybe2 + +instance (Generic3 g) => FRep3 g Maybe where + frep3 = rMaybe3 + diff --git a/src/Generics/EMGM/Data/Tuple.hs b/src/Generics/EMGM/Data/Tuple.hs new file mode 100644 --- /dev/null +++ b/src/Generics/EMGM/Data/Tuple.hs @@ -0,0 +1,203 @@ +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverlappingInstances #-} +{-# OPTIONS -fno-warn-orphans #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Generics.EMGM.Data.Tuple +-- Copyright : (c) 2008 Universiteit Utrecht +-- License : BSD3 +-- +-- Maintainer : generics@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- Summary: Generic representation and instances for tuples of arity 0 +-- (a.k.a. unit) and 2 to 7. +-- +-- This module exports the reusable components of tuple representations. These +-- include the embedding-projection pair used in a type representation as well +-- as the type representations for 'Generic'. +-- +-- This module also exports the instances for the representation dispatcher +-- 'Rep'. +----------------------------------------------------------------------------- + +module Generics.EMGM.Data.Tuple ( + + -- * Embedding-projection pairs + epTuple0, + epTuple2, + epTuple3, + epTuple4, + epTuple5, + epTuple6, + epTuple7, + + -- * Representations + rTuple0, + rTuple2, + rTuple3, + rTuple4, + rTuple5, + rTuple6, + rTuple7, +) where + +import Generics.EMGM.Common + +----------------------------------------------------------------------------- +-- 0: () +----------------------------------------------------------------------------- + +-- | Embedding-projection pair for @()@ +epTuple0 :: EP () Unit +epTuple0 = EP (\() -> Unit) + (\Unit -> ()) + +conTuple0 :: ConDescr +conTuple0 = ConDescr "()" 0 [] Nonfix + +-- | Representation for @()@ in 'Generic' +rTuple0 :: Generic g => g () +rTuple0 = + rtype epTuple0 $ + rcon conTuple0 runit + +----------------------------------------------------------------------------- +-- 2: (a,b) +----------------------------------------------------------------------------- + +-- | Embedding-projection pair for @(a,b)@ +epTuple2 :: EP (a,b) (a :*: b) +epTuple2 = EP (\(a,b) -> a :*: b) + (\(a :*: b) -> (a,b)) + +conTuple2 :: ConDescr +conTuple2 = ConDescr "(,)" 2 [] Nonfix + +-- | Representation for @(a,b)@ in 'Generic' +rTuple2 :: Generic g => g a -> g b -> g (a,b) +rTuple2 ra rb = + rtype epTuple2 $ + rcon conTuple2 (ra `rprod` rb) + +----------------------------------------------------------------------------- +-- 3: (a,b,c) +----------------------------------------------------------------------------- + +-- | Embedding-projection pair for @(a,b,c)@ +epTuple3 :: EP (a,b,c) (a :*: b :*: c) +epTuple3 = EP (\(a,b,c) -> a :*: b :*: c) + (\(a :*: b :*: c) -> (a,b,c)) + +conTuple3 :: ConDescr +conTuple3 = ConDescr "(,,)" 3 [] Nonfix + +-- | Representation for @(a,b,c)@ in 'Generic' +rTuple3 :: Generic g => g a -> g b -> g c -> g (a,b,c) +rTuple3 ra rb rc = + rtype epTuple3 $ + rcon conTuple3 (ra `rprod` rb `rprod` rc) + +----------------------------------------------------------------------------- +-- 4: (a,b,c,d) +----------------------------------------------------------------------------- + +-- | Embedding-projection pair for @(a,b,c,d)@ +epTuple4 :: EP (a,b,c,d) (a :*: b :*: c :*: d) +epTuple4 = EP (\(a,b,c,d) -> a :*: b :*: c :*: d) + (\(a :*: b :*: c :*: d) -> (a,b,c,d)) + +conTuple4 :: ConDescr +conTuple4 = ConDescr "(,,,)" 4 [] Nonfix + +-- | Representation for @(a,b,c,d)@ in 'Generic' +rTuple4 :: Generic g => g a -> g b -> g c -> g d -> g (a,b,c,d) +rTuple4 ra rb rc rd = + rtype epTuple4 $ + rcon conTuple4 (ra `rprod` rb `rprod` rc `rprod` rd) + +----------------------------------------------------------------------------- +-- 5: (a,b,c,d,e) +----------------------------------------------------------------------------- + +-- | Embedding-projection pair for @(a,b,c,d,e)@ +epTuple5 :: EP (a,b,c,d,e) (a :*: b :*: c :*: d :*: e) +epTuple5 = EP (\(a,b,c,d,e) -> a :*: b :*: c :*: d :*: e) + (\(a :*: b :*: c :*: d :*: e) -> (a,b,c,d,e)) + +conTuple5 :: ConDescr +conTuple5 = ConDescr "(,,,,)" 5 [] Nonfix + +-- | Representation for @(a,b,c,d,e)@ in 'Generic' +rTuple5 :: Generic g => g a -> g b -> g c -> g d -> g e -> g (a,b,c,d,e) +rTuple5 ra rb rc rd re = + rtype epTuple5 $ + rcon conTuple5 (ra `rprod` rb `rprod` rc `rprod` rd `rprod` re) + +----------------------------------------------------------------------------- +-- 6: (a,b,c,d,e,f) +----------------------------------------------------------------------------- + +-- | Embedding-projection pair for @(a,b,c,d,e,f)@ +epTuple6 :: EP (a,b,c,d,e,f) (a :*: b :*: c :*: d :*: e :*: f) +epTuple6 = EP (\(a,b,c,d,e,f) -> a :*: b :*: c :*: d :*: e :*: f) + (\(a :*: b :*: c :*: d :*: e :*: f) -> (a,b,c,d,e,f)) + +conTuple6 :: ConDescr +conTuple6 = ConDescr "(,,,,,)" 6 [] Nonfix + +-- | Representation for @(a,b,c,d,e,f)@ in 'Generic' +rTuple6 :: Generic g => g a -> g b -> g c -> g d -> g e -> g f -> g (a,b,c,d,e,f) +rTuple6 ra rb rc rd re rf = + rtype epTuple6 $ + rcon conTuple6 (ra `rprod` rb `rprod` rc `rprod` rd `rprod` re `rprod` rf) + + +----------------------------------------------------------------------------- +-- 7: (a,b,c,d,e,f,h) +----------------------------------------------------------------------------- + +-- | Embedding-projection pair for @(a,b,c,d,e,f,h)@ +epTuple7 :: EP (a,b,c,d,e,f,h) (a :*: b :*: c :*: d :*: e :*: f :*: h) +epTuple7 = EP (\(a,b,c,d,e,f,h) -> a :*: b :*: c :*: d :*: e :*: f :*: h) + (\(a :*: b :*: c :*: d :*: e :*: f :*: h) -> (a,b,c,d,e,f,h)) + +conTuple7 :: ConDescr +conTuple7 = ConDescr "(,,,,,)" 7 [] Nonfix + +-- | Representation for @(a,b,c,d,e,f,h)@ in 'Generic' +rTuple7 :: Generic g => g a -> g b -> g c -> g d -> g e -> g f -> g h -> g (a,b,c,d,e,f,h) +rTuple7 ra rb rc rd re rf rh = + rtype epTuple7 $ + rcon conTuple7 (ra `rprod` rb `rprod` rc `rprod` rd `rprod` re `rprod` rf `rprod` rh) + +----------------------------------------------------------------------------- +-- Instance declarations +----------------------------------------------------------------------------- + +instance (Generic g) => Rep g () where + rep = rTuple0 + +instance (Generic g, Rep g a, Rep g b) => Rep g (a,b) where + rep = rTuple2 rep rep + +instance (Generic g, Rep g a, Rep g b, Rep g c) => Rep g (a,b,c) where + rep = rTuple3 rep rep rep + +instance (Generic g, Rep g a, Rep g b, Rep g c, Rep g d) => Rep g (a,b,c,d) where + rep = rTuple4 rep rep rep rep + +instance (Generic g, Rep g a, Rep g b, Rep g c, Rep g d, Rep g e) => Rep g (a,b,c,d,e) where + rep = rTuple5 rep rep rep rep rep + +instance (Generic g, Rep g a, Rep g b, Rep g c, Rep g d, Rep g e, Rep g f) => Rep g (a,b,c,d,e,f) where + rep = rTuple6 rep rep rep rep rep rep + +instance (Generic g, Rep g a, Rep g b, Rep g c, Rep g d, Rep g e, Rep g f, Rep g h) => Rep g (a,b,c,d,e,f,h) where + rep = rTuple7 rep rep rep rep rep rep rep + + diff --git a/src/Generics/EMGM/Functions.hs b/src/Generics/EMGM/Functions.hs new file mode 100644 --- /dev/null +++ b/src/Generics/EMGM/Functions.hs @@ -0,0 +1,36 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Generics.EMGM.Functions +-- Copyright : (c) 2008 Universiteit Utrecht +-- License : BSD3 +-- +-- Maintainer : generics@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- Exports all modules in the Generics.EMGM.Functions.* hierarchy. +----------------------------------------------------------------------------- + +module Generics.EMGM.Functions ( + + module Generics.EMGM.Functions.Collect, + module Generics.EMGM.Functions.Compare, + module Generics.EMGM.Functions.Crush, + module Generics.EMGM.Functions.Enum, + module Generics.EMGM.Functions.Map, + module Generics.EMGM.Functions.Read, + module Generics.EMGM.Functions.Show, + module Generics.EMGM.Functions.UnzipWith, + module Generics.EMGM.Functions.ZipWith, + +) where + +import Generics.EMGM.Functions.Collect +import Generics.EMGM.Functions.Compare +import Generics.EMGM.Functions.Crush +import Generics.EMGM.Functions.Enum +import Generics.EMGM.Functions.Map +import Generics.EMGM.Functions.Read +import Generics.EMGM.Functions.Show +import Generics.EMGM.Functions.UnzipWith +import Generics.EMGM.Functions.ZipWith diff --git a/src/Generics/EMGM/Functions/Collect.hs b/src/Generics/EMGM/Functions/Collect.hs new file mode 100644 --- /dev/null +++ b/src/Generics/EMGM/Functions/Collect.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverlappingInstances #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Generics.EMGM.Functions.Collect +-- Copyright : (c) 2008 Universiteit Utrecht +-- License : BSD3 +-- +-- Maintainer : generics@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- Summary: Generic function that collects all values of a specified type from a +-- generic value. +-- +-- 'collect' works by searching a datatype for values that are the same type as +-- the return type specified. Here are some examples using the same value but +-- different return types: +-- +-- @ +-- GHCi> collect [Just 1, Nothing, Just (2 :: Int)] :: [Int] +-- [1,2] +-- GHCi> collect [Just 1, Nothing, Just (2 :: Int)] :: [Maybe Int] +-- [Just 1,Nothing,Just 2] +-- GHCi> collect [Just 1, Nothing, Just (2 :: Int)] :: [[Maybe Int]] +-- [[Just 1,Nothing,Just 2]] +-- @ +-- +-- Note that the number @2@ has the type @Int@. Some arguments (such as numeric +-- constants which have type @Num a => a@) may need explicit type annotations. +-- By design, there is no connection that can be inferred between the return +-- type and the argument type. +-- +-- 'collect' only works if the return type has been made an instance of 'Rep'. +-- The library provides instances for all datatypes with included +-- representation. +-- +-- An instance is trivial to write. Given a type @D@, the 'Rep' instance looks +-- like this: +-- +-- > {-# LANGUAGE OverlappingInstances #-} +-- > +-- > data D = ... +-- > +-- > instance Rep (Collect D) D where +-- > rep = Collect (:[]) +-- +-- (Note the requirement of overlapping instances.) This instance triggers when +-- the result type (the first @D@) matches some value type (the second @D@) +-- contained within the argument to 'collect'. See the source of this module for +-- more examples. +----------------------------------------------------------------------------- + +module Generics.EMGM.Functions.Collect ( + Collect(..), + collect, +) where + +import Generics.EMGM.Common + +----------------------------------------------------------------------------- +-- Types +----------------------------------------------------------------------------- + +-- | Type for 'collect' +newtype Collect b a = Collect { selCollect :: a -> [b] } + +----------------------------------------------------------------------------- +-- Generic instance declaration +----------------------------------------------------------------------------- + +rconstantCollect :: a -> [b] +rconstantCollect _ = [] + +rsumCollect :: Collect c a -> Collect c b -> a :+: b -> [c] +rsumCollect ra _ (L a) = selCollect ra a +rsumCollect _ rb (R b) = selCollect rb b + +rprodCollect :: Collect c a -> Collect c b -> a :*: b -> [c] +rprodCollect ra rb (a :*: b) = selCollect ra a ++ selCollect rb b + +rtypeCollect :: EP b a -> Collect c a -> b -> [c] +rtypeCollect ep ra b = selCollect ra (from ep b) + +rconCollect :: ConDescr -> Collect c a -> a -> [c] +rconCollect _ = selCollect + +instance Generic (Collect b) where + rconstant = Collect rconstantCollect + rsum ra rb = Collect (rsumCollect ra rb) + rprod ra rb = Collect (rprodCollect ra rb) + rcon cd ra = Collect (rconCollect cd ra) + rtype ep ra = Collect (rtypeCollect ep ra) + +----------------------------------------------------------------------------- +-- Rep instance declarations +----------------------------------------------------------------------------- + +instance Rep (Collect Int) Int where + rep = Collect (:[]) + +instance Rep (Collect Integer) Integer where + rep = Collect (:[]) + +instance Rep (Collect Float) Float where + rep = Collect (:[]) + +instance Rep (Collect Double) Double where + rep = Collect (:[]) + +instance Rep (Collect Char) Char where + rep = Collect (:[]) + +instance Rep (Collect Bool) Bool where + rep = Collect (:[]) + +instance Rep (Collect (Either a b)) (Either a b) where + rep = Collect (:[]) + +instance Rep (Collect [a]) [a] where + rep = Collect (:[]) + +instance Rep (Collect (Maybe a)) (Maybe a) where + rep = Collect (:[]) + +instance Rep (Collect ()) () where + rep = Collect (:[]) + +instance Rep (Collect (a,b)) (a,b) where + rep = Collect (:[]) + +instance Rep (Collect (a,b,c)) (a,b,c) where + rep = Collect (:[]) + +instance Rep (Collect (a,b,c,d)) (a,b,c,d) where + rep = Collect (:[]) + +instance Rep (Collect (a,b,c,d,e)) (a,b,c,d,e) where + rep = Collect (:[]) + +instance Rep (Collect (a,b,c,d,e,f)) (a,b,c,d,e,f) where + rep = Collect (:[]) + +instance Rep (Collect (a,b,c,d,e,f,h)) (a,b,c,d,e,f,h) where + rep = Collect (:[]) + +----------------------------------------------------------------------------- +-- Exported functions +----------------------------------------------------------------------------- + +-- | Collect values of type @b@ from some value of type @a@. An empty list means +-- no values were collected. If you expected otherwise, be sure that you have an +-- instance such as @'Rep' ('Collect' B) B@ for the type @B@ that you are +-- collecting. See the description of this module for details. +collect :: (Rep (Collect b) a) => a -> [b] +collect = selCollect rep + diff --git a/src/Generics/EMGM/Functions/Compare.hs b/src/Generics/EMGM/Functions/Compare.hs new file mode 100644 --- /dev/null +++ b/src/Generics/EMGM/Functions/Compare.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Generics.EMGM.Functions.Compare +-- Copyright : (c) 2008 Universiteit Utrecht +-- License : BSD3 +-- +-- Maintainer : generics@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- Summary: Generic functions for comparing two values in different ways. +-- +-- The fundamental function here is 'compare', a function that returns the +-- 'Ordering' of two values (less than, equal to, or greater than). It uses the +-- same lexicographical ordering as @deriving Ord@ (e.g. left alternative of a +-- sum is less than the right alternative, the first component of a product is +-- compared first while the second is only compared if the first is equal, +-- etc.). +-- +-- All of the remaining functions are simply derived (in the most obvious way) +-- from 'compare'. All of these functions are equivalent to methods in the 'Eq' +-- and 'Ord' type classes. The difference with using this approach vs. @deriving +-- (Eq, Ord)@ is that you can write ad-hoc cases for certain datatypes while +-- most of the functionality is handled generically. +----------------------------------------------------------------------------- + +module Generics.EMGM.Functions.Compare ( + + -- * Compare + -- | 'compare' is equivalent to the function of the same name when @deriving + -- Ord@. All other comparison functions in this module are derived from + -- 'compare'. + Compare(..), + compare, + + -- * Equality, inequality + -- | These functions are equivalent to @(==)@ and @(/=)@ when @deriving Eq@. + eq, + neq, + + -- * Less than, greater than + -- | These functions are equivalent to @(\<)@, @(\<=)@, @(>)@, and @(>=)@ when + -- @deriving Ord@. + lt, + lteq, + gt, + gteq, + + -- * Minimum and maximum + -- | These functions are equivalent to functions of the same name when + -- @deriving Ord@. + min, + max, +) where + +import Prelude hiding (compare, min, max) +import qualified Prelude as P (compare) + +import Generics.EMGM.Common + +----------------------------------------------------------------------------- +-- Types +----------------------------------------------------------------------------- + +-- | Type for 'compare' +newtype Compare a = Compare { selCompare :: a -> a -> Ordering } + +----------------------------------------------------------------------------- +-- Generic instance declaration +----------------------------------------------------------------------------- + +rconstantCompare :: Ord a => a -> a -> Ordering +rconstantCompare = P.compare + +rsumCompare :: Compare a -> Compare b -> a :+: b -> a :+: b -> Ordering +rsumCompare ra _ (L a1) (L a2) = {-EQ-} selCompare ra a1 a2 +rsumCompare _ rb (R b1) (R b2) = {-EQ-} selCompare rb b1 b2 +rsumCompare _ _ (L _) (R _) = LT +rsumCompare _ _ (R _) (L _) = GT + +rprodCompare :: Compare a -> Compare b -> a :*: b -> a :*: b -> Ordering +rprodCompare ra rb (a1 :*: b1) (a2 :*: b2) = + case selCompare ra a1 a2 of + EQ -> selCompare rb b1 b2 + other -> other + +rconCompare :: ConDescr -> Compare a -> a -> a -> Ordering +rconCompare _ = selCompare + +rtypeCompare :: EP a b -> Compare b -> a -> a -> Ordering +rtypeCompare ep rb a1 a2 = selCompare rb (from ep a1) (from ep a2) + +instance Generic Compare where + rconstant = Compare rconstantCompare + rsum ra rb = Compare (rsumCompare ra rb) + rprod ra rb = Compare (rprodCompare ra rb) + rcon cd ra = Compare (rconCompare cd ra) + rtype ep ra = Compare (rtypeCompare ep ra) + +----------------------------------------------------------------------------- +-- Exported functions +----------------------------------------------------------------------------- + +-- | Compare two values and return an 'Ordering' (i.e. @LT@, @GT@, or @EQ@). +-- This is implemented exactly as if the datatype was @deriving Ord@. + +compare :: Rep Compare a => a -> a -> Ordering +compare = selCompare rep + +-- | Less than. Returns @x < y@. +lt :: Rep Compare a => a -> a -> Bool +lt x y = + case compare x y of + LT -> True + _ -> False + +-- | Less than or equal to. Returns @x <= y@. +lteq :: Rep Compare a => a -> a -> Bool +lteq x y = + case compare x y of + GT -> False + _ -> True + +-- | Equal to. Returns @x == y@. +eq :: Rep Compare a => a -> a -> Bool +eq x y = + case compare x y of + EQ -> True + _ -> False + +-- | Not equal to. Returns @x /= y@. +neq :: Rep Compare a => a -> a -> Bool +neq x y = + case compare x y of + EQ -> False + _ -> True + +-- | Greater than. Returns @x > y@. +gt :: Rep Compare a => a -> a -> Bool +gt x y = + case compare x y of + GT -> True + _ -> False + +-- | Greater than or equal to. Returns @x >= y@. +gteq :: Rep Compare a => a -> a -> Bool +gteq x y = + case compare x y of + LT -> False + _ -> True + +-- | The minimum of two values. +min :: Rep Compare a => a -> a -> a +min x y = if x `lteq` y then x else y + +-- | The maximum of two values. +max :: Rep Compare a => a -> a -> a +max x y = if x `gteq` y then x else y + diff --git a/src/Generics/EMGM/Functions/Crush.hs b/src/Generics/EMGM/Functions/Crush.hs new file mode 100644 --- /dev/null +++ b/src/Generics/EMGM/Functions/Crush.hs @@ -0,0 +1,244 @@ +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Generics.EMGM.Functions.Crush +-- Copyright : (c) 2008 Universiteit Utrecht +-- License : BSD3 +-- +-- Maintainer : generics@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- Summary: Generic functions that crush a container into an iteration over +-- its elements. +-- +-- Crush is a datatype-generic operation on container types. It is a +-- generalization of folds, but it is not a catamorphism. To understand how +-- crush works, one can think of it as generating a list of all elements and +-- mapping an accumulating function over each one. With this image in mind, it +-- is evident that (unlike a catamorphism) very little information can be +-- determined about the structure of the container. +-- +-- The EMGM implementation of 'crush' can not inherently know the associativity +-- of the binary operator. Consequently, associativity is left as an argument, +-- but there are variants specific to left- and right-associativity for +-- convenience. +-- +-- Many standard Haskell datatypes (e.g. '[]', 'Data.Tree') are designed such +-- that a constructor with more than one argument (i.e. a product structurally +-- represented by '(:*:)') has the element on the left and any recursive points +-- towards the right. Due to this, the right-associative functions would +-- typically produce the expected values. See examples in the comments for +-- 'flattenr' and 'firstr'. +----------------------------------------------------------------------------- + +module Generics.EMGM.Functions.Crush ( + + -- * Crush functions + + Crush(..), + Assoc(..), + crush, + crushl, + crushr, + + -- * Left- and right-associative derived functions + -- | The operation of these functions changes depending on the associativity + -- of the binary operator. + + flatten, + flattenl, + flattenr, + + first, + firstl, + firstr, + + -- * Other derived functions + -- | The operation of these functions is independent of the associativity of + -- the binary operator. Many of these functions are generalizations of the + -- 'Prelude' functions of the same name + + and, + or, + any, + all, + sum, + product, + maximum, + minimum, + elem, + notElem, + +) where + +import Prelude hiding (and, or, any, all, elem, notElem, sum, product, maximum, minimum) + +import Generics.EMGM.Common + +----------------------------------------------------------------------------- +-- Types +----------------------------------------------------------------------------- + +-- | Associativity of the binary operator used for 'crush' +data Assoc = AssocLeft -- ^ Left-associative + | AssocRight -- ^ Right-associative + +-- | Type for 'crush' +newtype Crush b a = Crush { selCrush :: Assoc -> a -> b -> b } + +----------------------------------------------------------------------------- +-- Generic instance declaration +----------------------------------------------------------------------------- + +rconstantCrush :: Assoc -> a -> b -> b +rconstantCrush _ _ = id + +rsumCrush :: Crush d a -> Crush d b -> Assoc -> a :+: b -> d -> d +rsumCrush ra _ asc (L a) = selCrush ra asc a +rsumCrush _ rb asc (R b) = selCrush rb asc b + +rprodCrush :: Crush d a -> Crush d b -> Assoc -> a :*: b -> d -> d +rprodCrush ra rb asc@AssocLeft (a :*: b) = selCrush rb asc b . selCrush ra asc a +rprodCrush ra rb asc@AssocRight (a :*: b) = selCrush ra asc a . selCrush rb asc b + +rconCrush :: ConDescr -> Crush d a -> Assoc -> a -> d -> d +rconCrush _ = selCrush + +rtypeCrush :: EP b a -> Crush d a -> Assoc -> b -> d -> d +rtypeCrush ep ra asc = selCrush ra asc . from ep + +instance Generic (Crush b) where + rconstant = Crush rconstantCrush + rsum ra rb = Crush (rsumCrush ra rb) + rprod ra rb = Crush (rprodCrush ra rb) + rcon cd ra = Crush (rconCrush cd ra) + rtype ep ra = Crush (rtypeCrush ep ra) + +----------------------------------------------------------------------------- +-- Exported functions +----------------------------------------------------------------------------- + +-- | Apply a function (@a -> b -> b@) to each element (@a@) of a container (@f +-- a@) and an accumulator value (@b@) to produce an accumulated result (@b@). +-- +-- This is the most general form in which you must specify the associativity. +-- You may prefer to use 'crushr' or 'crushl'. +crush :: + (FRep (Crush b) f) + => Assoc -- ^ Associativity of the binary operator (left or right). + -> (a -> b -> b) -- ^ Binary operator on @a@-elements with an accumulator. + -> b -- ^ The initial @b@-value for the binary operator. + -> f a -- ^ Container of @a@-values. + -> b -- ^ The result after applying the above operator on all + -- @a@-values. +crush asc f z x = selCrush (frep (Crush f')) asc x z + where f' _ = f -- necessary to skip the asc arg + +-- | A right-associative variant of 'crush'. +crushr :: (FRep (Crush b) f) => (a -> b -> b) -> b -> f a -> b +crushr = crush AssocRight + +-- | A left-associative variant of 'crush'. +crushl :: (FRep (Crush b) f) => (a -> b -> b) -> b -> f a -> b +crushl = crush AssocLeft + +-- | Flatten the elements of a container into a list. +-- +-- This is the most general form in which you must specify the associativity. +-- You may prefer to use 'flattenr' or 'flattenl'. +flatten :: (FRep (Crush [a]) f) => Assoc -> f a -> [a] +flatten asc = crush asc (:) [] + +-- | A right-associative variant of 'flatten'. +-- +-- Note that, for a list @ls :: [a]@, @flattenr ls == ls@. +flattenr :: (FRep (Crush [a]) f) => f a -> [a] +flattenr = flatten AssocRight + +-- | A left-associative variant of 'flatten'. +-- +-- Note that, for a list @ls :: [a]@, @flattenl ls == reverse ls@. +flattenl :: (FRep (Crush [a]) f) => f a -> [a] +flattenl = flatten AssocLeft + +-- | Extract the first element of a container. If the container is empty, return +-- @Nothing@. +-- +-- This is the most general form in which you must specify the associativity. +-- You may prefer to use 'firstr' or 'firstl'. +first :: (FRep (Crush [a]) f) => Assoc -> f a -> Maybe a +first asc as = case flatten asc as of + [] -> Nothing + a:_ -> Just a + +-- | A right-associative variant of 'first'. +-- +-- Note that, for a list @ls :: [a]@, @fromJust (firstr ls) == head ls@. +firstr :: (FRep (Crush [a]) f) => f a -> Maybe a +firstr = first AssocRight + +-- | A left-associative variant of 'first'. +-- +-- Note that, for a list @ls :: [a]@, @fromJust (firstl ls) == last ls@. +firstl :: (FRep (Crush [a]) f) => f a -> Maybe a +firstl = first AssocLeft + +-- | Determine if an element is a member of a container. This is a +-- generalization of the 'Prelude' function of the same name. +elem :: (Eq a, FRep (Crush Bool) f) => a -> f a -> Bool +elem x = any (== x) + +-- | Determine if an element is not a member of a container. This is a +-- generalization of the 'Prelude' function of the same name. +notElem :: (Eq a, FRep (Crush Bool) f) => a -> f a -> Bool +notElem x = all (/= x) + +-- | Compute the sum of all elements in a container. This is a generalization of +-- the 'Prelude' function of the same name. +sum :: (Num a, FRep (Crush a) f) => f a -> a +sum = crushr (+) 0 + +-- | Compute the product of all elements in a container. This is a +-- generalization of the 'Prelude' function of the same name. +product :: (Num a, FRep (Crush a) f) => f a -> a +product = crushr (*) 1 + +-- | Determine the maximum element of a container. If the container is empty, +-- return 'Nothing'. This is a generalization of the 'Prelude' function of the +-- same name. +maximum :: (Ord a, FRep (Crush (Maybe a)) f) => f a -> Maybe a +maximum = crushr f Nothing + where f x Nothing = Just x + f x (Just y) = Just $ max x y + +-- | Determine the minimum element of a container. If the container is empty, +-- return 'Nothing'. This is a generalization of the 'Prelude' function of the +-- same name. +minimum :: (Ord a, FRep (Crush (Maybe a)) f) => f a -> Maybe a +minimum = crushr f Nothing + where f x Nothing = Just x + f x (Just y) = Just $ min x y + +-- | Compute the conjunction of all elements in a container. This is a +-- generalization of the 'Prelude' function of the same name. +and :: (FRep (Crush Bool) f) => f Bool -> Bool +and = crushr (&&) True + +-- | Compute the disjunction of all elements in a container. This is a +-- generalization of the 'Prelude' function of the same name. +or :: (FRep (Crush Bool) f) => f Bool -> Bool +or = crushr (||) False + +-- | Determine if any element in a container satisfies the predicate @p@. This +-- is a generalization of the 'Prelude' function of the same name. +any :: (FRep (Crush Bool) f) => (a -> Bool) -> f a -> Bool +any p = crushr (\x b -> b || p x) False + +-- | Determine if all elements in a container satisfy the predicate @p@. This +-- is a generalization the 'Prelude' function of the same name. +all :: (FRep (Crush Bool) f) => (a -> Bool) -> f a -> Bool +all p = crushr (\x b -> b && p x) True + diff --git a/src/Generics/EMGM/Functions/Enum.hs b/src/Generics/EMGM/Functions/Enum.hs new file mode 100644 --- /dev/null +++ b/src/Generics/EMGM/Functions/Enum.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Generics.EMGM.Functions.Enum +-- Copyright : (c) 2008 Universiteit Utrecht +-- License : BSD3 +-- +-- Maintainer : generics@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- Summary: Generic function that enumerates the values of a datatype. +-- +-- 'enum' generates a list of the values of a datatypes. It will produce all +-- values of all supported datatypes (with only a few exceptions [1]). For +-- datatypes that have an infinite enumeration (e.g. 'Integer' and @[a]@), +-- 'enum' produces an infinite list. +-- +-- A number of the techniques used to write 'enum' came from a talk by Mark +-- Jones at the 2008 Advanced Functional Programming Summer School. The authors +-- gratefully acknowledge his contribution. +-- +-- [1] The exceptions are 'Float' and 'Double'. These are treated in the same way +-- as their 'Enum' instances are treated. The result looks like this: +-- @[0.0,-1.0,1.0,-2.0,..]@, thus skipping all non-integral values. Note that +-- these may overflow, because they are unbounded. +----------------------------------------------------------------------------- + +module Generics.EMGM.Functions.Enum ( + Enum(..), + enum, + enumN, + empty, +) where + +import Prelude hiding (Enum) +import qualified Prelude as P (Enum) +import Data.List (genericTake) + +import Generics.EMGM.Common + +----------------------------------------------------------------------------- +-- Types +----------------------------------------------------------------------------- + +-- | Type for 'enum' +newtype Enum a = Enum { selEnum :: [a] } + +----------------------------------------------------------------------------- +-- Utility functions +----------------------------------------------------------------------------- + +infixr 5 ||| + +-- | Interleave elements from two lists. Similar to (++), but swap left and +-- right arguments on every recursive application. +-- +-- From Mark Jones' talk at AFP2008 +(|||) :: [a] -> [a] -> [a] +[] ||| ys = ys +(x:xs) ||| ys = x : ys ||| xs + +-- | Diagonalization of nested lists. Ensure that some elements from every +-- sublist will be included. Handles infinite sublists. +-- +-- From Mark Jones' talk at AFP2008 +diag :: [[a]] -> [a] +diag = concat . foldr skew [] . map (map (\x -> [x])) + +skew :: [[a]] -> [[a]] -> [[a]] +skew [] ys = ys +skew (x:xs) ys = x : combine (++) xs ys + +combine :: (a -> a -> a) -> [a] -> [a] -> [a] +combine _ xs [] = xs +combine _ [] ys = ys +combine f (x:xs) (y:ys) = f x y : combine f xs ys + +infixr 6 >< + +-- | Cartesian product with diagonalization. +-- +-- From Mark Jones' talk at AFP2008 +(><) :: [a] -> [b] -> [a :*: b] +xs >< ys = diag [ [ x :*: y | y <- ys ] | x <- xs ] + +----------------------------------------------------------------------------- +-- Generic instance declaration +----------------------------------------------------------------------------- + +-- | 'Int' values starting with 0 and enumerating to the positive and negative +-- bounds. +intEnum :: [Int] +intEnum = [0..maxBound] ||| pred 0 `downTo` minBound + where downTo :: Int -> Int -> [Int] + downTo n m | n < m = [] + downTo n m = n : downTo (n - 1) m + +-- | Numeric and enumerable values starting with 0 and enumerating in the +-- positive and negative directions. Useful for 'Integer', 'Float', and +-- 'Double'. +numEnum :: (Num a, P.Enum a) => [a] +numEnum = [0..] ||| map negate [1..] + +rsumEnum :: Enum a -> Enum b -> [a :+: b] +rsumEnum ra rb = [L x | x <- selEnum ra] + ||| [R y | y <- selEnum rb] + +rprodEnum :: Enum a -> Enum b -> [a :*: b] +rprodEnum ra rb = selEnum ra >< selEnum rb + +rtypeEnum :: EP b a -> Enum a -> [b] +rtypeEnum ep ra = map (to ep) $ selEnum ra + +instance Generic Enum where + rconstant = error "Unreachable" + rint = Enum intEnum + rinteger = Enum numEnum + rfloat = Enum numEnum + rdouble = Enum numEnum + rchar = Enum [minBound..maxBound] + runit = Enum [Unit] + rsum ra rb = Enum (rsumEnum ra rb) + rprod ra rb = Enum (rprodEnum ra rb) + rtype ep ra = Enum (rtypeEnum ep ra) + +----------------------------------------------------------------------------- +-- Exported functions +----------------------------------------------------------------------------- + +-- | Enumerate the values of a datatype. If the number of values is infinite, +-- the result will be an infinite list. The remaining functions are derived from +-- 'enum'. +enum :: (Rep Enum a) => [a] +enum = selEnum rep + +-- | Enumerate the first @n@ values of a datatype. This is a shortcut for +-- @'genericTake' n ('enum')@. +enumN :: (Integral n, Rep Enum a) => n -> [a] +enumN n = genericTake n $ enum + +-- | Returns the first element of the enumeration from 'enum'. This is +-- often called the neutral or empty value. +empty :: (Rep Enum a) => a +empty = head $ enumN (1::Int) + diff --git a/src/Generics/EMGM/Functions/Map.hs b/src/Generics/EMGM/Functions/Map.hs new file mode 100644 --- /dev/null +++ b/src/Generics/EMGM/Functions/Map.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Generics.EMGM.Functions.Map +-- Copyright : (c) 2008 Universiteit Utrecht +-- License : BSD3 +-- +-- Maintainer : generics@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- Summary: Generic function that applies a (non-generic) function to all +-- elements contained in a polymorphic datatype. +-- +-- 'map' is a generic version of the @Prelude@ @map@ function. It works on all +-- supported container datatypes of kind @* -> *@. The 'map' function is +-- equivalent to 'fmap' after @deriving 'Functor'@ if that were possible. +----------------------------------------------------------------------------- + +module Generics.EMGM.Functions.Map ( + Map(..), + map, + replace, +) where + +import Prelude hiding (map) + +import Generics.EMGM.Common + +----------------------------------------------------------------------------- +-- Types +----------------------------------------------------------------------------- + +-- | Type for 'map' +newtype Map a b = Map { selMap :: a -> b } + +----------------------------------------------------------------------------- +-- Generic2 instance declaration +----------------------------------------------------------------------------- + +rconstantMap :: a -> a +rconstantMap = id + +rsumMap :: Map a1 a2 -> Map b1 b2 -> a1 :+: b1 -> a2 :+: b2 +rsumMap ra _ (L a) = L (selMap ra a) +rsumMap _ rb (R b) = R (selMap rb b) + +rprodMap :: Map a1 a2 -> Map b1 b2 -> a1 :*: b1 -> a2 :*: b2 +rprodMap ra rb (a :*: b) = selMap ra a :*: selMap rb b + +rtypeMap :: EP b r -> EP d a -> Map r a -> b -> d +rtypeMap ep1 ep2 ra = to ep2 . selMap ra . from ep1 + +instance Generic2 Map where + rconstant2 = Map rconstantMap + rsum2 ra rb = Map (rsumMap ra rb) + rprod2 ra rb = Map (rprodMap ra rb) + rtype2 ep1 ep2 ra = Map (rtypeMap ep1 ep2 ra) + +----------------------------------------------------------------------------- +-- Exported functions +----------------------------------------------------------------------------- + +-- | Apply a function to all elements of a container datatype (kind @* -> *@). +map :: (FRep2 Map f) => (a -> b) -> f a -> f b +map = selMap . frep2 . Map + +-- | Replace all @a@-values in @as@ with @b@. +replace :: (FRep2 Map f) => f a -> b -> f b +replace as b = map (const b) as + diff --git a/src/Generics/EMGM/Functions/Read.hs b/src/Generics/EMGM/Functions/Read.hs new file mode 100644 --- /dev/null +++ b/src/Generics/EMGM/Functions/Read.hs @@ -0,0 +1,399 @@ +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverlappingInstances #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Generics.EMGM.Functions.Read +-- Copyright : (c) 2008 Universiteit Utrecht +-- License : BSD3 +-- +-- Maintainer : generics@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- Summary: Generic functions that parse strings to produce values. +-- +-- The functions in this module involve generically parsing a string and +-- producing a value. They rely on the return type to determine the structure +-- for parsing. Often, this can be determined by the type checker, but +-- you will occasionally need to give an explicit type signature. +-- +-- The underlying parser is designed to be as similar to @deriving Read@ (as +-- implemented by GHC) as possible. Refer to documentation in "Text.Read" for +-- details. +-- +-- Since this library does not have access to the syntax of a @data@ +-- declaration, it relies on 'ConDescr' for information. It is important that +-- 'ConDescr' accurately describe, for each constructor, the name, record +-- labels (in same order as declared) if present, and fixity. +-- +-- See also "Generics.EMGM.Functions.Show". +----------------------------------------------------------------------------- + +module Generics.EMGM.Functions.Read ( + Read(..), + readPrec, + readP, + readsPrec, + reads, + read, +) where + +import Prelude hiding (Read, read, reads, readsPrec) +import qualified Prelude as P (Read) +import Data.List (find) +import Control.Monad +import Debug.Trace + +import Text.ParserCombinators.ReadPrec (ReadPrec, step, (+++), pfail, lift, + look, readPrec_to_S, readPrec_to_P) +import qualified Text.ParserCombinators.ReadPrec as RP (prec) +import Text.ParserCombinators.ReadP (ReadP) +import Text.Read (Lexeme(Punc), lexP, parens, reset) +import qualified Text.Read as TR (readPrec) +import Text.Read.Lex (hsLex) + +import qualified GHC.Read as GHC (list) + +import Generics.EMGM.Common + +----------------------------------------------------------------------------- +-- Types +----------------------------------------------------------------------------- + +-- | Type for 'readPrec' +newtype Read a = Read { selRead :: ConType -> ReadPrec a } + +----------------------------------------------------------------------------- +-- Utility functions +----------------------------------------------------------------------------- + +-- | "Look and trace" - print the unconsumed part of the input string +ltrace :: String -> ReadPrec () +ltrace = + let debug = False + in if debug + then \s -> do la <- look + (trace $ "<<" ++ la ++ ">> " ++ s) $ return () + else const $ do return () + +comma :: ReadPrec () +comma = do Punc "," <- lexP + return () + +equals :: ReadPrec () +equals = do Punc "=" <- lexP + return () + +-- | @(paren p)@ parses \"(P0)\" where @p@ parses \"P0\" at precedence 0 +paren :: ReadPrec a -> ReadPrec a +paren p = do Punc "(" <- lexP + x <- reset p + Punc ")" <- lexP + return x + +-- | Read optional parentheses plus a single required pair. +wrapTuple :: ReadPrec a -> ReadPrec a +wrapTuple = parens . paren + +-- | Read "a , b" without parens. +tuple2 :: ReadPrec a -> ReadPrec b -> ReadPrec (a,b) +tuple2 pa pb = + do a <- pa + comma + b <- pb + return (a,b) + +-- | Read "a , b , c" without parens. +tuple3 :: ReadPrec a -> ReadPrec b -> ReadPrec c -> ReadPrec (a,b,c) +tuple3 pa pb pc = + do (a,b) <- tuple2 pa pb + comma + c <- pc + return (a,b,c) + +-- | Read "a , b , c , d" without parens. +tuple4 :: ReadPrec a -> ReadPrec b -> ReadPrec c -> ReadPrec d -> ReadPrec (a,b,c,d) +tuple4 pa pb pc pd = + do (a,b) <- tuple2 pa pb + comma + (c,d) <- tuple2 pc pd + return (a,b,c,d) + +-- | @(paren p)@ parses \"{P0}\" where @p@ parses \"P0\" at precedence 0 +braces :: ReadPrec a -> ReadPrec a +braces p = do ltraceme "{ before" + Punc "{" <- lexP + ltraceme "{ after" + x <- reset p + ltraceme "} before" + Punc "}" <- lexP + ltraceme "} after" + return x + where ltraceme s = ltrace $ "braces: " ++ s + +-- | Parse a Haskell token and verify that it is the one expected. +lexT :: String -> ReadPrec () +lexT expected = + do found <- lift hsLex + if found == expected + then do ltraceme "success" + return () + else do ltraceme $ "fnd=" ++ found ++ " FAIL" + pfail + where ltraceme s = ltrace $ "lexT: exp=" ++ expected ++ " -> " ++ s + +-- | Parse a record entry: "label = x[,]" where x comes from the parameter +-- parser @p@. +recEntry :: Bool -> String -> ReadPrec a -> ReadPrec a +recEntry isComma label p = + do lexT label + ltraceme "before =" + equals + ltraceme "after =" + x <- p + ltraceme "after p" + if isComma + then do ltraceme "before ," + comma + return x + else do ltraceme "no ," + return x + where ltraceme s = + ltrace $ "recEntry: com=" ++ show isComma ++ + " lbl=" ++ label ++ " " ++ s + +----------------------------------------------------------------------------- +-- Generic instance declaration +----------------------------------------------------------------------------- + +rconstantRead :: (P.Read a) => ConType -> ReadPrec a +rconstantRead ct = + case ct of + + -- Standard constructor + ConStd -> + do ltraceme "ConStd" + TR.readPrec + + -- Record-style constructor with 1 label + ConRec (label:[]) -> + do ltraceme "ConRec1" + recEntry False label TR.readPrec + + -- No other patterns expected + _ -> + do ltraceme "FAIL" + pfail + + where ltraceme s = ltrace $ "rconstantRead: " ++ s + +rsumRead :: Read a -> Read b -> ConType -> ReadPrec (a :+: b) +rsumRead ra rb _ = + do ltrace "rsumRead:" + (return . L =<< selRead ra ConStd) +++ (return . R =<< selRead rb ConStd) + +rprodRead :: Read a -> Read b -> ConType -> ReadPrec (a :*: b) +rprodRead ra rb ct = + case ct of + + -- Standard nonfix constructor + ConStd -> + do ltraceme "ConStd (a)" + a <- step (selRead ra ConStd) + ltraceme "ConStd (b)" + b <- step (selRead rb ConStd) + return (a :*: b) + + -- Standard infix constructor + ConIfx symbol -> + do ltraceme "ConIfx (a)" + a <- step (selRead ra ConStd) + lexT symbol + ltraceme "ConIfx (b)" + b <- step (selRead rb ConStd) + return (a :*: b) + + -- Record-style constructor + ConRec (label:labels) -> + do ltraceme "ConRec2 (a)" + a <- step (recEntry True label (selRead ra ConStd)) + ltraceme "ConRec2 (b)" + b <- step $ selRead rb (ConRec (labels)) + return (a :*: b) + + -- No other patterns expected + _ -> + do ltraceme "FAIL" + pfail + + where + ltraceme s = ltrace $ "rprodRead: " ++ show ct ++ " " ++ s + +rconRead :: ConDescr -> Read a -> ConType -> ReadPrec a +rconRead cd ra _ = + parens $ + case cd of + + -- Standard nonfix constructor + ConDescr name _ [] Nonfix -> + do ltraceme "ConStd" + lexT name + step $ selRead ra ConStd + + -- Standard infix constructor + ConDescr name _ [] fixity -> + do ltraceme "ConIfx" + let p = prec fixity + RP.prec p $ step $ selRead ra $ ConIfx name + + -- Record-style nonfix constructor + ConDescr name _ labels Nonfix -> + do ltraceme "ConRec (a)" + lexT name + braces $ step $ selRead ra $ ConRec labels + + -- Record-style infix constructor + ConDescr name _ labels _ -> + do ltraceme "ConRec (b)" + paren (lexT name) + braces $ step $ selRead ra $ ConRec labels + + where ltraceme s = ltrace $ "rconRead: " ++ show cd ++ " " ++ s + +rtypeRead :: EP d a -> Read a -> ConType -> ReadPrec d +rtypeRead ep ra ct = + case ct of + + -- Standard constructor + ConStd -> + do ltraceme "ConStd" + fmap (to ep) $ selRead ra ConStd + + -- Record-style constructor + ConRec (label:[]) -> + do ltraceme "ConRec" + fmap (to ep) $ recEntry False label (selRead ra ConStd) + + -- No other patterns expected + _ -> + do ltraceme "FAIL" + pfail + + where + ltraceme s = ltrace $ "rtypeRead: " ++ show ct ++ " " ++ s + +instance Generic Read where + rconstant = Read rconstantRead + rsum ra rb = Read (rsumRead ra rb) + rprod ra rb = Read (rprodRead ra rb) + rcon cd ra = Read (rconRead cd ra) + rtype ep ra = Read (rtypeRead ep ra) + +----------------------------------------------------------------------------- +-- Rep instance declarations +----------------------------------------------------------------------------- + +-- | Ad-hoc instance for lists +instance (Rep Read a) => Rep Read [a] where + rep = Read $ const $ GHC.list $ readPrec + +-- | Ad-hoc instance for strings +instance Rep Read String where + rep = Read $ const TR.readPrec + +-- | Ad-hoc instance for @()@ +instance Rep Read () where + rep = Read $ const TR.readPrec + +-- | Ad-hoc instance for @(a,b)@ +instance (Rep Read a, Rep Read b) => Rep Read (a,b) where + rep = Read $ const $ wrapTuple $ + tuple2 readPrec readPrec + +-- | Ad-hoc instance for @(a,b,c)@ +instance (Rep Read a, Rep Read b, Rep Read c) + => Rep Read (a,b,c) where + rep = Read $ const $ wrapTuple $ + tuple3 readPrec readPrec readPrec + +-- | Ad-hoc instance for @(a,b,c,d)@ +instance (Rep Read a, Rep Read b, Rep Read c, Rep Read d) + => Rep Read (a,b,c,d) where + rep = Read $ const $ wrapTuple $ + tuple4 readPrec readPrec readPrec readPrec + +-- | Ad-hoc instance for @(a,b,c,d,e)@ +instance (Rep Read a, Rep Read b, Rep Read c, Rep Read d, Rep Read e) + => Rep Read (a,b,c,d,e) where + rep = Read $ const $ wrapTuple $ + do (a,b,c,d) <- tuple4 readPrec readPrec readPrec readPrec + comma + e <- readPrec + return (a,b,c,d,e) + +-- | Ad-hoc instance for @(a,b,c,d,e,f)@ +instance (Rep Read a, Rep Read b, Rep Read c, Rep Read d, Rep Read e, + Rep Read f) + => Rep Read (a,b,c,d,e,f) where + rep = Read $ const $ wrapTuple $ + do (a,b,c,d) <- tuple4 readPrec readPrec readPrec readPrec + comma + (e,f) <- tuple2 readPrec readPrec + return (a,b,c,d,e,f) + +-- | Ad-hoc instance for @(a,b,c,d,e,f,h)@ +instance (Rep Read a, Rep Read b, Rep Read c, Rep Read d, Rep Read e, + Rep Read f, Rep Read h) + => Rep Read (a,b,c,d,e,f,h) where + rep = Read $ const $ wrapTuple $ + do (a,b,c,d) <- tuple4 readPrec readPrec readPrec readPrec + comma + (e,f,h) <- tuple3 readPrec readPrec readPrec + return (a,b,c,d,e,f,h) + +----------------------------------------------------------------------------- +-- Exported functions +----------------------------------------------------------------------------- + +-- | Generate a 'ReadPrec' parser combinator for the datatype @a@ that handles +-- operator precedence. This uses the library in +-- "Text.ParserCombinators.ReadPrec" and should be similar to a derived +-- implementation of 'Text.Read.readPrec'. +-- +-- Note that all of the other read functions in this module are derived from +-- 'readPrec'. +readPrec :: (Rep Read a) => ReadPrec a +readPrec = selRead rep ConStd + +-- | Attempt to parse a value from the front of the string using the given +-- precedence. 'readsPrec' returns a list of (parsed value, remaining string) +-- pairs. If parsing fails, 'readsPrec' returns an empty list. +readsPrec :: + (Rep Read a) + => Int -- ^ Operator precedence of the enclosing context (a number from 0 to 11). + -> ReadS a -- ^ Equivalent to @String -> [(a,String)]@. +readsPrec = readPrec_to_S readPrec + +-- | Generate a 'ReadP' parser combinator for the datatype @a@. This can be used +-- with 'Text.ParserCombinators.ReadP'. +readP :: + (Rep Read a) + => Int -- ^ Operator precedence of the enclosing context (a number from 0 to 11). + -> ReadP a +readP = readPrec_to_P readPrec + +-- | A variant of 'readsPrec' with the minimum precedence (0). +reads :: (Rep Read a) => ReadS a +reads = readsPrec minPrec + +-- | A variant of 'reads' that returns @Just value@ on a successful parse. +-- Otherwise, 'read' returns 'Nothing'. Note that a successful parse requires +-- the input to be completely consumed. +read :: (Rep Read a) => String -> Maybe a +read = fmap fst . find (null . snd) . reads + diff --git a/src/Generics/EMGM/Functions/Show.hs b/src/Generics/EMGM/Functions/Show.hs new file mode 100644 --- /dev/null +++ b/src/Generics/EMGM/Functions/Show.hs @@ -0,0 +1,279 @@ +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverlappingInstances #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Generics.EMGM.Functions.Show +-- Copyright : (c) 2008 Universiteit Utrecht +-- License : BSD3 +-- +-- Maintainer : generics@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- Summary: Generic functions that convert values to readable strings. +-- +-- The functions in this module involve generically producing a string from a +-- value of a supported datatype. The functions 'showsPrec' and 'show' are +-- modeled after those in the class @Show@, and 'shows' after the related +-- function of the same name. +-- +-- The underlying unparser is designed to be as similar to @deriving Show@ as +-- possible. Refer to documentation in "Text.Show" for details. +-- +-- Since this library does not have access to the syntax of a @data@ +-- declaration, it relies on 'ConDescr' for information. It is important that +-- 'ConDescr' accurately describe, for each constructor, the name, arity, record +-- labels (in same order as declared) if present, and fixity. +-- +-- See also "Generics.EMGM.Functions.Read". +----------------------------------------------------------------------------- + +module Generics.EMGM.Functions.Show ( + Show(..), + showsPrec, + shows, + show, +) where + +import Prelude hiding (Show, showsPrec, show, shows) +import qualified Prelude as P (Show, showsPrec) + +import qualified GHC.Show as GHC (showList__) + +import Generics.EMGM.Common + +----------------------------------------------------------------------------- +-- Types +----------------------------------------------------------------------------- + +type ShowsPrec a = Int -> a -> ShowS + +-- | Type for 'showsPrec' +newtype Show a = Show { selShow :: ConType -> ShowsPrec a } + +----------------------------------------------------------------------------- +-- Utility functions +----------------------------------------------------------------------------- + +showSpace :: ShowS +showSpace = showChar ' ' + +showBraces :: ShowsPrec a -> ShowsPrec a +showBraces showsPrec' p x = + showChar '{' . + showsPrec' p x . + showChar '}' + +showTuple :: [ShowS] -> ShowS +showTuple ss = showParen True $ + foldr1 (\s r -> s . showChar ',' . r) ss + +recEntry :: Bool -> String -> ShowsPrec a -> ShowsPrec a +recEntry comma label showsPrec' _ x = + showString label . + showString " = " . + showsPrec' minPrec x . -- Reset precedence for record fields + showString (if comma then ", " else "") + +----------------------------------------------------------------------------- +-- Generic instance declaration +----------------------------------------------------------------------------- + +rconstantShow :: (P.Show a) => ConType -> ShowsPrec a +rconstantShow ct = + case ct of + + -- Standard constructor + ConStd -> P.showsPrec + + -- Record-style constructor with 1 label + ConRec (label:[]) -> recEntry False label P.showsPrec + + -- No other patterns expected + _ -> error "Should not reach here!" + +rsumShow :: Show a -> Show b -> ConType -> ShowsPrec (a :+: b) +rsumShow ra _ _ p (L a) = selShow ra ConStd p a +rsumShow _ rb _ p (R b) = selShow rb ConStd p b + +rprodShow :: Show a -> Show b -> ConType -> ShowsPrec (a :*: b) +rprodShow ra rb ct p (a :*: b) = + case ct of + + -- Standard nonfix constructor + ConStd -> + selShowStep ra ConStd p a . + showSpace . + selShowStep rb ConStd p b + + -- Standard infix constructor + ConIfx symbol -> + selShowStep ra ConStd p a . + showSpace . + showString symbol . + showSpace . + selShowStep rb ConStd p b + + -- Record-style constructor + ConRec (label:labels) -> + let p' = p + 1 in + recEntry True label (selShowStep ra ConStd) p' a . + selShowStep rb (ConRec (labels)) p' b + + -- No other patterns expected + _ -> error "Should not reach here!" + + where selShowStep r ct' = selShow r ct' . (+1) + +rconShow :: ConDescr -> Show a -> ConType -> ShowsPrec a +rconShow cd ra _ p a = + case cd of + + -- Standard nonfix constructor + ConDescr name arity [] Nonfix -> + let hasArgs = arity > 0 in + -- Don't show parens if constructor has no arguments + showParen (p > appPrec && hasArgs) $ + showString name . + showString (if hasArgs then " " else "") . + showConStep ConStd appPrec a + + -- Standard infix constructor + ConDescr name _ [] fixity -> + let conPrec = prec fixity in + showParen (p > conPrec) $ + showConStep (ConIfx name) conPrec a + + -- Record-style nonfix constructor + ConDescr name _ labels Nonfix -> + -- NOTE: Technically, we can use 'recPrec' below, because the precedence + -- for record construction is higher than function application. However, + -- since GHC puts parens for 'appRec', we'll put them. That way, we can + -- compare string output to deriving Show for testing. + showParen (p > appPrec) $ + showString name . + showSpace . + showBraces (selShow ra (ConRec labels)) minPrec a + + -- Record-style infix constructor + ConDescr name _ labels _ -> + showParen True (showString name) . + showSpace . + showBraces (showConStep (ConRec labels)) p a + + where showConStep ct = selShow ra ct . (+1) + +rtypeShow :: EP b a -> Show a -> ConType -> ShowsPrec b +rtypeShow ep ra ct = + case ct of + + -- Standard constructor + ConStd -> + selShowFrom ConStd + + -- Record-style constructor + ConRec (label:[]) -> + recEntry False label (selShowFrom ConStd) + + -- No other patterns expected + _ -> error "Should not reach here!" + + where selShowFrom ct' p = selShow ra ct' p . from ep + +instance Generic Show where + rconstant = Show rconstantShow + rsum ra rb = Show (rsumShow ra rb) + rprod ra rb = Show (rprodShow ra rb) + rcon cd ra = Show (rconShow cd ra) + rtype ep ra = Show (rtypeShow ep ra) + +----------------------------------------------------------------------------- +-- Rep instance declarations +----------------------------------------------------------------------------- + +-- | Ad-hoc instance for lists +instance (Rep Show a) => Rep Show [a] where + rep = Show $ const $ const $ GHC.showList__ $ selShow rep ConStd minPrec + +-- | Ad-hoc instance for strings +instance Rep Show String where + rep = Show $ const P.showsPrec + +-- | Ad-hoc instance for @()@ +instance Rep Show () where + rep = Show $ const P.showsPrec + +-- | Ad-hoc instance for @(a,b)@ +instance (Rep Show a, Rep Show b) => Rep Show (a,b) where + rep = Show s + where s _ _ (a,b) = + showTuple [shows a, shows b] + +-- | Ad-hoc instance for @(a,b,c)@ +instance (Rep Show a, Rep Show b, Rep Show c) + => Rep Show (a,b,c) where + rep = Show s + where s _ _ (a,b,c) = + showTuple [shows a, shows b, shows c] + +-- | Ad-hoc instance for @(a,b,c,d)@ +instance (Rep Show a, Rep Show b, Rep Show c, Rep Show d) + => Rep Show (a,b,c,d) where + rep = Show s + where s _ _ (a,b,c,d) = + showTuple [shows a, shows b, shows c, shows d] + +-- | Ad-hoc instance for @(a,b,c,d,e)@ +instance (Rep Show a, Rep Show b, Rep Show c, Rep Show d, + Rep Show e) + => Rep Show (a,b,c,d,e) where + rep = Show s + where s _ _ (a,b,c,d,e) = + showTuple [shows a, shows b, shows c, shows d, + shows e] + +-- | Ad-hoc instance for @(a,b,c,d,e,f)@ +instance (Rep Show a, Rep Show b, Rep Show c, Rep Show d, + Rep Show e, Rep Show f) + => Rep Show (a,b,c,d,e,f) where + rep = Show s + where s _ _ (a,b,c,d,e,f) = + showTuple [shows a, shows b, shows c, shows d, + shows e, shows f] + +-- | Ad-hoc instance for @(a,b,c,d,e,f,h)@ +instance (Rep Show a, Rep Show b, Rep Show c, Rep Show d, + Rep Show e, Rep Show f, Rep Show h) + => Rep Show (a,b,c,d,e,f,h) where + rep = Show s + where s _ _ (a,b,c,d,e,f,h) = + showTuple [shows a, shows b, shows c, shows d, + shows e, shows f, shows h] + +----------------------------------------------------------------------------- +-- Exported functions +----------------------------------------------------------------------------- + +-- | Convert a value to a readable string starting with the operator precedence +-- of the enclosing context. All of the remaining functions are derived from +-- 'showsPrec'. +showsPrec :: + (Rep Show a) + => Int -- ^ Operator precedence of the enclosing context (a number from 0 to 11). + -> a -- ^ The value to be converted to a 'String'. + -> ShowS +showsPrec = selShow rep ConStd + +-- | A variant of 'showsPrec' with the minimum precedence (0). +shows :: (Rep Show a) => a -> ShowS +shows = showsPrec 0 + +-- | A variant of 'shows' that returns a 'String' instead of 'ShowS'. +show :: (Rep Show a) => a -> String +show = flip shows "" + diff --git a/src/Generics/EMGM/Functions/UnzipWith.hs b/src/Generics/EMGM/Functions/UnzipWith.hs new file mode 100644 --- /dev/null +++ b/src/Generics/EMGM/Functions/UnzipWith.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Generics.EMGM.Functions.UnzipWith +-- Copyright : (c) 2008 Universiteit Utrecht +-- License : BSD3 +-- +-- Maintainer : generics@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- Summary: Generic function that applies a (non-generic) function to every +-- element in a value, splitting the element into two. The result are two +-- structurally equivalent values, one with the elements from the first +-- component of the splitting function and the other with the elements from the +-- second component. +-- +-- 'unzipWith' can be seen as the dual of the 'zipWith' function. It has no +-- @Prelude@ counterpart. +-- +-- See also "Generics.EMGM.Functions.ZipWith". +----------------------------------------------------------------------------- + +module Generics.EMGM.Functions.UnzipWith ( + UnzipWith(..), + unzipWith, + unzip, +) where + +import Prelude hiding (unzip) + +import Generics.EMGM.Common + +----------------------------------------------------------------------------- +-- Types +----------------------------------------------------------------------------- + +-- | Type for 'unzipWith' +newtype UnzipWith a b c = UnzipWith { selUnzipWith :: a -> (b, c) } + +----------------------------------------------------------------------------- +-- Generic3 instance declaration +----------------------------------------------------------------------------- + +rconstantUnzipWith :: a -> (a, a) +rconstantUnzipWith x = (x, x) + +runitUnzipWith :: Unit -> (Unit, Unit) +runitUnzipWith _ = (Unit, Unit) + +rsumUnzipWith :: + UnzipWith a1 a2 a3 + -> UnzipWith b1 b2 b3 + -> a1 :+: b1 + -> (a2 :+: b2, a3 :+: b3) +rsumUnzipWith ra _ (L a1) = let (a2, a3) = selUnzipWith ra a1 + in (L a2, L a3) +rsumUnzipWith _ rb (R b1) = let (b2, b3) = selUnzipWith rb b1 + in (R b2, R b3) + +rprodUnzipWith :: + UnzipWith a1 a2 a3 + -> UnzipWith b1 b2 b3 + -> (a1 :*: b1) + -> (a2 :*: b2, a3 :*: b3) +rprodUnzipWith ra rb (a1 :*: b1) = let (a2, a3) = selUnzipWith ra a1 + (b2, b3) = selUnzipWith rb b1 + in (a2 :*: b2, a3 :*: b3) + +rtypeUnzipWith :: + EP b1 a1 + -> EP b2 a2 + -> EP b3 a3 + -> UnzipWith a1 a2 a3 + -> b1 + -> (b2, b3) +rtypeUnzipWith ep1 ep2 ep3 ra b1 = let (a2, a3) = selUnzipWith ra (from ep1 b1) + in (to ep2 a2, to ep3 a3) + +rconUnzipWith :: ConDescr -> UnzipWith a1 a2 a3 -> a1 -> (a2, a3) +rconUnzipWith _ = selUnzipWith + +instance Generic3 UnzipWith where + rconstant3 = UnzipWith rconstantUnzipWith + runit3 = UnzipWith runitUnzipWith + rsum3 ra rb = UnzipWith (rsumUnzipWith ra rb) + rprod3 ra rb = UnzipWith (rprodUnzipWith ra rb) + rcon3 cd ra = UnzipWith (rconUnzipWith cd ra) + rtype3 ep1 ep2 ep3 ra = UnzipWith (rtypeUnzipWith ep1 ep2 ep3 ra) + +----------------------------------------------------------------------------- +-- Exported functions +----------------------------------------------------------------------------- + +-- | Splits a container into two structurally equivalent containers by applying +-- a function to every element, which splits it into two corresponding elements. +-- All other functions in this module are derived from 'unzipWith'. +unzipWith :: + (FRep3 UnzipWith f) + => (a -> (b, c)) -- ^ Splitting function. + -> f a -- ^ Container of @a@-values. + -> (f b, f c) -- ^ Pair of containers. +unzipWith f = selUnzipWith (frep3 (UnzipWith f)) + +-- | Transforms a container of pairs into a container of first components and a +-- container of second components. This is a generic version of the @Prelude@ +-- function of the same name. +unzip :: (FRep3 UnzipWith f) => f (a, b) -> (f a, f b) +unzip = unzipWith id + diff --git a/src/Generics/EMGM/Functions/ZipWith.hs b/src/Generics/EMGM/Functions/ZipWith.hs new file mode 100644 --- /dev/null +++ b/src/Generics/EMGM/Functions/ZipWith.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Generics.EMGM.Functions.ZipWith +-- Copyright : (c) 2008 Universiteit Utrecht +-- License : BSD3 +-- +-- Maintainer : generics@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- Summary: Generic function that applies a (non-generic) function to every +-- pair of corresponding elements in two structurally equivalent polymorphic +-- values to produce a third (also structurally equivalent) value with the +-- result of each application in every element location. +-- +-- 'zipWith' is a generic version of the @Prelude@ @zipWith@ function. It works +-- on all supported container datatypes of kind @* -> *@. +-- +-- The important concepts for `zipWith` are /structural equivalence/ and +-- /corresponding elements/. A regular, algebraic datatype can be visualized as +-- some sort of tree representing its structure. For 'zipWith' to be successful +-- (and not return 'Nothing'), its two container arguments must have exactly the +-- same tree shape. If the shapes of the arguments differ, then it is unclear +-- what the shape of the result is supposed to be. As a result, 'zipWith' +-- safely returns 'Nothing'. +-- +-- Corresponding elements are those elements that are located in the same place +-- in the tree of each argument. If you were to traverse the tree to get to +-- element x in one tree, then its corresponding element y in the other tree +-- should require the exact same path to reach it. +-- +-- See also "Generics.EMGM.Functions.UnzipWith". +----------------------------------------------------------------------------- + +module Generics.EMGM.Functions.ZipWith ( + ZipWith(..), + zipWith, + zip, +) where + +import Prelude hiding (zipWith, zip) + +import Generics.EMGM.Common + +----------------------------------------------------------------------------- +-- Types +----------------------------------------------------------------------------- + +-- | Type for 'zipWith' +newtype ZipWith a b c = ZipWith { selZipWith :: a -> b -> Maybe c } + +----------------------------------------------------------------------------- +-- Generic3 instance declaration +----------------------------------------------------------------------------- + +rconstantZipWith :: (Eq a) => a -> a -> Maybe a +rconstantZipWith x y = if x == y then Just x else Nothing + +runitZipWith :: Unit -> Unit -> Maybe Unit +runitZipWith _ _ = Just Unit + +rsumZipWith :: + ZipWith a1 a2 a3 + -> ZipWith b1 b2 b3 + -> a1 :+: b1 + -> a2 :+: b2 + -> Maybe (a3 :+: b3) +rsumZipWith ra _ (L a1) (L a2) = selZipWith ra a1 a2 >>= return . L +rsumZipWith _ rb (R b1) (R b2) = selZipWith rb b1 b2 >>= return . R +rsumZipWith _ _ _ _ = Nothing + +rprodZipWith :: + ZipWith a1 a2 a3 + -> ZipWith b1 b2 b3 + -> (a1 :*: b1) + -> (a2 :*: b2) + -> Maybe (a3 :*: b3) +rprodZipWith ra rb (a1 :*: b1) (a2 :*: b2) = + do a <- selZipWith ra a1 a2 + b <- selZipWith rb b1 b2 + return (a :*: b) + +rtypeZipWith :: + EP b1 a1 + -> EP b2 a2 + -> EP b3 a3 + -> ZipWith a1 a2 a3 + -> b1 + -> b2 + -> Maybe b3 +rtypeZipWith ep1 ep2 ep3 ra b1 b2 = + selZipWith ra (from ep1 b1) (from ep2 b2) >>= return . to ep3 + +rconZipWith :: ConDescr -> ZipWith a1 a2 a3 -> a1 -> a2 -> Maybe a3 +rconZipWith _ = selZipWith + +instance Generic3 ZipWith where + rconstant3 = ZipWith rconstantZipWith + runit3 = ZipWith runitZipWith + rsum3 ra rb = ZipWith (rsumZipWith ra rb) + rprod3 ra rb = ZipWith (rprodZipWith ra rb) + rcon3 cd ra = ZipWith (rconZipWith cd ra) + rtype3 ep1 ep2 ep3 ra = ZipWith (rtypeZipWith ep1 ep2 ep3 ra) + +----------------------------------------------------------------------------- +-- Exported functions +----------------------------------------------------------------------------- + +-- | Combine two structurally equivalent containers into one by applying a +-- function to every corresponding pair of elements. Returns 'Nothing' if @f a@ +-- and @f b@ have different shapes. All other functions in this module are +-- derived from 'zipWith'. +zipWith :: + (FRep3 ZipWith f) + => (a -> b -> c) -- ^ Binary operator on elements of containers. + -> f a -- ^ Container of @a@-values. + -> f b -- ^ Container of @b@-values. + -> Maybe (f c) -- ^ Container of @c@-values if successful or 'Nothing' + -- if failed. +zipWith f = selZipWith (frep3 (ZipWith f')) + where f' a b = Just $ f a b + +-- | Combine two containers into a single container with pairs of the original +-- elements. See 'zipWith' for restrictions. This is a generic version of the +-- @Prelude@ function of the same name. +zip :: (FRep3 ZipWith f) => f a -> f b -> Maybe (f (a, b)) +zip = zipWith (,) + diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,32 @@ + +module Main where + +import Test.HUnit + +import qualified TestQC +import qualified Crush +import qualified ReadShow +import qualified Compare +import qualified Collect +import qualified Enum +import qualified ZipWith +import qualified UnzipWith +import qualified Map + +-- Make sure the examples compile: +import Ex00StartHere () + +tests = + "All" ~: [ Crush.tests + , ReadShow.tests + , Compare.tests + , Collect.tests + , Enum.tests + , ZipWith.tests + , UnzipWith.tests + , Map.tests + ] + +main = do TestQC.main + runTestTT tests +