diff --git a/CREDITS.md b/CREDITS.md new file mode 100644 --- /dev/null +++ b/CREDITS.md @@ -0,0 +1,42 @@ + +Credits for EMGM +================ + +This is a list of those who have contributed to the design and development of +Extensible and Modular Generics for the Masses library. + +History +------- + +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. + +Research +-------- + +* Ralf Hinze +* Bruno C. d. S. Oliveira +* Andres Löh +* Alexey Rodriguez + +Primary Contributors +-------------------- + +* Sean Leather +* José Pedro Magalhães + +Current Maintainer +------------------ + +* Sean Leather + +Other Contributions +------------------- + +* Johan Jeuring +* Lambert Meertens +* Larry Evans +* Antoine Latter (for Ratio) + diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2008, 2009 Universiteit Utrecht +Copyright (c) 2008 - 2011 Universiteit Utrecht All rights reserved. Redistribution and use in source and binary forms, with or without modification, diff --git a/README b/README deleted file mode 100644 --- a/README +++ /dev/null @@ -1,219 +0,0 @@ - -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] version 6.8.1 or later - It has been tested with versions 6.8.3 and 6.10.1. -* [Cabal] library version 1.2.1 or later - It has been tested with versions 1.2.4.0 and 1.6.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 or later - 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.1 - Required for testing. -* [HUnit] 1.2 - Required for testing. - -[QuickCheck]: http://hackage.haskell.org/cgi-bin/hackage-scripts/package/QuickCheck -[HUnit]: http://hackage.haskell.org/cgi-bin/hackage-scripts/package/HUnit - -### 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/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,47 @@ + +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 + +Examples +-------- + +You can find examples of using EMGM in the [`examples` directory] of the source +distribution. + +[`examples` directory]: https://github.com/spl/emgm/tree/master/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 + diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -1,7 +1,6 @@ #! /usr/bin/env runhaskell \begin{code} -{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS -Wall #-} ----------------------------------------------------------------------------- @@ -15,134 +14,10 @@ module Main (main) where -import System.Cmd - ( system - ) - -import System.FilePath - ( () - ) - -import Data.Version - ( Version(..) - ) - -import Distribution.Simple - ( defaultMainWithHooks - , simpleUserHooks - , UserHooks(runTests, haddockHook, buildHook) - , Args - ) - -import Distribution.Simple.LocalBuildInfo - ( LocalBuildInfo(..) - ) - -import Distribution.Simple.Program - ( userSpecifyArgs - ) - -import Distribution.Simple.Setup - ( HaddockFlags - , BuildFlags - ) - -import Distribution.Package - -import Distribution.PackageDescription - ( PackageDescription(..) - , BuildInfo(..) - , Library(..) - , Executable(..) - ) +import Distribution.Simple (defaultMain) main :: IO () -main = defaultMainWithHooks hooks - where - hooks = simpleUserHooks - { runTests = runTests' - , haddockHook = haddockHook' - , buildHook = buildHook' - } - --- Run a 'test' binary that gets built when configured with '-ftest'. -runTests' :: Args -> Bool -> PackageDescription -> LocalBuildInfo -> IO () -runTests' _ _ _ _ = system cmd >> return () - where testdir = "dist" "build" "test" - testcmd = "." "test" - cmd = "cd " ++ testdir ++ " && " ++ testcmd - --- Define __HADDOCK__ for CPP when running haddock. This is a workaround for --- Haddock not building the documentation due to some issue with Template --- Haskell. -haddockHook' :: PackageDescription -> LocalBuildInfo -> UserHooks -> HaddockFlags -> IO () -haddockHook' pkg lbi = - haddockHook simpleUserHooks pkg (lbi { withPrograms = p }) - where - p = userSpecifyArgs "haddock" ["--optghc=-D__HADDOCK__"] (withPrograms lbi) - --- Insert CPP flag for building with template-haskell versions >= 2.3. This was --- previously done in the .cabal file, but it was not backwards compatible with --- Cabal 1.2. This should work with Cabal from 1.2 to 1.6 at least. -buildHook' :: PackageDescription -> LocalBuildInfo -> UserHooks -> BuildFlags -> IO () -buildHook' pkg lbi hooks flags = do - buildHook simpleUserHooks pkg (lbi { localPkgDescr = newPkgDescr }) hooks flags - where - - -- Old local package description - oldPkgDescr = localPkgDescr lbi - - -- New local package description - newPkgDescr = - case thVersion of - Nothing -> - oldPkgDescr - Just version -> - if version >= Version [2,3] [] - then - oldPkgDescr - { library = addThCppToLibrary (library oldPkgDescr) - , executables = map addThCppToExec (executables oldPkgDescr) - } - else - oldPkgDescr - - -- Template Haskell package name - thPackageName = mkPackageName "template-haskell" - - mkPackageName :: (Read a) => String -> a - mkPackageName nm = - fst $ head $ reads shownNm ++ reads ("PackageName " ++ shownNm) - where - shownNm = show nm - - -- template-haskell version - thVersion = findThVersion (packageDeps lbi) - - -- CPP options for template-haskell >= 2.3 - thCppOpt = "-DTH_LOC_DERIVEREP" - - -- Find the version of the template-haskell package - findThVersion [] = Nothing - findThVersion (PackageIdentifier name version:ps) - | name == thPackageName = Just version - | otherwise = findThVersion ps - - -- Add the template-haskell CPP flag to a BuildInfo - addThCppToBuildInfo :: BuildInfo -> BuildInfo - addThCppToBuildInfo bi = - bi { cppOptions = thCppOpt : cppOptions bi } - - -- Add the template-haskell CPP flag to a library package description - addThCppToLibrary :: Maybe Library -> Maybe Library - addThCppToLibrary ml = do - lib <- ml - return (lib { libBuildInfo = addThCppToBuildInfo (libBuildInfo lib) }) - - -- Add the template-haskell CPP flag to an executable package description - addThCppToExec :: Executable -> Executable - addThCppToExec exec = - exec { buildInfo = addThCppToBuildInfo (buildInfo exec) } +main = defaultMain \end{code} diff --git a/emgm.cabal b/emgm.cabal --- a/emgm.cabal +++ b/emgm.cabal @@ -1,10 +1,10 @@ name: emgm -version: 0.3.1 +version: 0.4 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. + EMGM is a general-purpose library for datatype-generic programming. . The design is based on the idea of modeling algebraic datatypes as sum-of-product structures. Many datatypes can be modeled this way, and @@ -13,37 +13,26 @@ . The primary features of the library are: . - * /A platform for building generic functions and adding support for user-defined datatypes./ - . - EMGM includes an important collection of datatypes (e.g. sum, product, and - unit) and type classes (e.g. @Generic@ and @Rep@). Everything you need for - your own generic functions or datatypes can be found here. - . - * /Many useful generic functions./ - . - These provide a wide range of functionality. For example, there is @crush@ - ("Generics.EMGM.Functions.Crush"), a generalization of the foldl/foldr - functions, that allows you to flexibly extract the elements of a polymorphic - container. Now, you can do many of the operations with your container that - were previously only available for lists. - . - Different generic functions work with different kinds of types as well. For - example, @collect@ ("Generics.EMGM.Functions.Collect") works with any fully - applied type while @bimap@ ("Generics.EMGM.Functions.Map") only works with - bifunctor types such as @Either@ or @(,)@ (pairs). + * /A foundation for building generic functions./ EMGM includes a collection of + datatypes (e.g. sum, product, and unit) and type classes (e.g. @Generic@ and + @Rep@). Everything you need for defining generic functions and supporting + datatypes can be found here. . - * /Support for standard and user-defined datatypes./ + * /Many useful generic functions./ These provide a wide range of + functionality. For example, there is @crush@, a generalization of the + foldl/foldr functions, that allows you to flexibly extract the elements of a + polymorphic container. Now, you can do many of the operations with your + container that were previously only available for lists. . - EMGM provides full support for standard types such as @[]@ (lists), tuples, - and @Maybe@ as well as many types you define in your own code. Using the - Template Haskell functions provided in "Generics.EMGM.Derive", it is very - simple to add support for using generic functions with your datatype + * /Support for standard datatypes./ EMGM supports standard types: primitives + (e.g. @Int@ and @Float@), @Bool@, lists, tuples, @Maybe@, etc. . - For more information on EMGM, see - + /NOTE:/ As of version 0.4, this library does not have Template Haskell for + generating the representation. We are working on another library for a + solution to this problem. category: Generics -copyright: (c) 2008, 2009 Universiteit Utrecht +copyright: (c) 2008 - 2011 Universiteit Utrecht license: BSD3 license-file: LICENSE author: Sean Leather, @@ -52,49 +41,35 @@ Andres Löh maintainer: generics@haskell.org stability: experimental -extra-source-files: README, +extra-source-files: README.md, + CREDITS.md, examples/Ex00StartHere.hs, examples/Ex01UsingFunctions.hs, examples/Ex02AddingDatatypeSupport.hs, examples/Ex03DefiningFunctions.hs, + tests/A.hs, + tests/B.hs, tests/Base.hs, tests/Bimap.hs, tests/Collect.hs, tests/Compare.hs, tests/Crush.hs, - tests/Derive.hs, tests/Enum.hs, tests/Everywhere.hs, tests/Main.hs, tests/Map.hs, tests/ReadShow.hs, - tests/TTree.hs, tests/UnzipWith.hs, tests/ZipWith.hs, util/hpc.lhs extra-tmp-files: .hpc -build-type: Custom -cabal-version: >= 1.2.1 -tested-with: GHC == 6.8.3, GHC == 6.10.1 - --------------------------------------------------------------------------------- - -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 +build-type: Simple +cabal-version: >= 1.9.2 +tested-with: GHC == 7.0.1 -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 +Source-Repository head + type: git + location: git://github.com/spl/emgm.git -------------------------------------------------------------------------------- @@ -103,87 +78,45 @@ 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 + -- Foundation + Generics.EMGM.Representation + Generics.EMGM.Base -- Generic functions - Generics.EMGM.Functions Generics.EMGM.Functions.Collect Generics.EMGM.Functions.Compare Generics.EMGM.Functions.Crush Generics.EMGM.Functions.Enum Generics.EMGM.Functions.Everywhere Generics.EMGM.Functions.Map + Generics.EMGM.Functions.Meta Generics.EMGM.Functions.Read Generics.EMGM.Functions.Show - Generics.EMGM.Functions.ZipWith + Generics.EMGM.Functions.Transpose Generics.EMGM.Functions.UnzipWith + Generics.EMGM.Functions.ZipWith -- Supported datatypes Generics.EMGM.Data.Bool Generics.EMGM.Data.Either Generics.EMGM.Data.List Generics.EMGM.Data.Maybe + Generics.EMGM.Data.Ratio Generics.EMGM.Data.Tuple - Generics.EMGM.Data.TH - -- Deriving - Generics.EMGM.Derive - - other-modules: Generics.EMGM.Derive.Common - Generics.EMGM.Derive.ConDescr - Generics.EMGM.Derive.EP - Generics.EMGM.Derive.Functions - Generics.EMGM.Derive.Instance - Generics.EMGM.Derive.Internal - - build-depends: base >= 3.0 && < 4.0, - template-haskell >= 2.2 && < 2.4 - - extensions: CPP + build-depends: base >= 3.0 && < 5.0 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 + ghc-options: -O2 -------------------------------------------------------------------------------- -Executable test - hs-source-dirs: src, tests, examples - other-modules: Generics.EMGM - extensions: CPP +Test-Suite test + type: exitcode-stdio-1.0 + hs-source-dirs: tests, src, examples main-is: Main.hs - - build-depends: base >= 3.0 && < 4.0, - template-haskell >= 2.2 && < 2.4 - - -- Only enable the build-depends here if configured with "-ftest". This - -- allows users to use EMGM without having to install QuickCheck. - if flag(test) - build-depends: QuickCheck >= 2.1 && < 2.2, - HUnit >= 1.2 && < 1.3 - else - buildable: False - - ghc-options: -Wall -O0 -fno-warn-missing-signatures - - -- Add program coverage if configured with "-fhpc". - if flag(hpc) - ghc-options: -fhpc + build-depends: base >= 3.0 && < 5.0, + HUnit >= 1.2 && < 1.3, + syb >= 0.3 && < 0.4, + QuickCheck >= 2.4 && < 2.5 diff --git a/examples/Ex02AddingDatatypeSupport.hs b/examples/Ex02AddingDatatypeSupport.hs --- a/examples/Ex02AddingDatatypeSupport.hs +++ b/examples/Ex02AddingDatatypeSupport.hs @@ -25,8 +25,8 @@ module Ex02AddingDatatypeSupport where -import Generics.EMGM.Derive -import qualified Generics.EMGM.Functions as G +import qualified Generics.EMGM as G +import Generics.EMGM.Base -- Using generic functions on your own datatypes @@ -46,11 +46,12 @@ conLeaf, conBranch :: ConDescr conLeaf = ConDescr { conName = "Leaf", - conArity = 1, conLabels = [], conFixity = Nonfix + conArity = 1, conRecord = False, conFixity = Prefix } + conBranch = ConDescr { conName = "Branch", - conArity = 2, conLabels = [], conFixity = Nonfix + conArity = 2, conRecord = False, conFixity = Prefix } -- More structural definition: diff --git a/examples/Ex03DefiningFunctions.hs b/examples/Ex03DefiningFunctions.hs --- a/examples/Ex03DefiningFunctions.hs +++ b/examples/Ex03DefiningFunctions.hs @@ -28,7 +28,6 @@ -- Instance of Generic instance Generic Empty where - rconstant = error "Unreachable" rint = Empty 0 rinteger = Empty 0 rfloat = Empty 0 diff --git a/src/Generics/EMGM.hs b/src/Generics/EMGM.hs --- a/src/Generics/EMGM.hs +++ b/src/Generics/EMGM.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE CPP #-} - ----------------------------------------------------------------------------- -- | -- Module : Generics.EMGM @@ -15,21 +13,13 @@ -- -- This module exports the most commonly used types, classes, and functions. The -- documentation is organized by topic for convenient access. --- --- For more in-depth documentation, refer to one of the modules in these --- hierarchies: --- --- * "Generics.EMGM.Common" - Common infrastructure for supporting datatypes and --- defining functions. --- --- * "Generics.EMGM.Functions" - Generic functions included with EMGM. --- --- * "Generics.EMGM.Derive" - Generating the EMGM representation for a datatype. ----------------------------------------------------------------------------- +{-# OPTIONS_GHC -Wall #-} + module Generics.EMGM ( - -- * Common Infrastructure + -- * Foundation -- -- | This is the collection of types, classes, and functions used to define -- generic functions and to build representations for datatypes. @@ -61,15 +51,27 @@ -- information for some generic functions. ConDescr(..), - ConType(..), - + LblDescr(..), Fixity(..), + Associativity(..), + Prec, prec, - minPrec, - maxPrec, - appPrec, - recPrec, + -- ** Generic Function Classes + -- + -- | Generic functions are instances of these classes. The value-level + -- structure representation of datatypes is implemented using the members of + -- these classes. Thus, a generic function is simply a case statement on the + -- value-level structure. + -- + -- Note that the numerical suffix represents the number of generic type + -- variables used in the generic function. No suffix represents 1 generic type + -- variable. + + Generic(..), + Generic2(..), + Generic3(..), + -- ** Representation Dispatchers -- -- | Type classes simplify the application of generic functions by providing @@ -104,31 +106,6 @@ BiFRep2(..), - -- ** Generic Function Definition - -- - -- | Generic functions are instances of these classes. The value-level - -- structure representation of datatypes is implemented using the members of - -- these classes. Thus, a generic function is simply a case statement on the - -- value-level structure. - -- - -- Note that the numerical suffix represents the number of generic type - -- variables used in the generic function. No suffix represents 1 generic type - -- variable. - - Generic(..), - Generic2(..), - Generic3(..), - - -- ** Deriving Representation - -- - -- | The necessary values and instances for using EMGM with a user-defined - -- datatype can be generated automatically using Template Haskell. By - -- necessity, there are a number of exported values for this process that are - -- unrelated to other uses of the EMGM library. In order to not export these - -- signatures more than necessary, you should import "Generics.EMGM.Derive" - -- for deriving the representation. Note that "Generics.EMGM" does not export - -- anything in "Generics.EMGM.Derive". - -- * Generic Functions -- -- | The following collection of functions use the common EMGM infrastructure @@ -139,105 +116,80 @@ -- -- More information for each of these is available in its respective module. - -- ** Collect Function + -- ** Collect -- -- | Function that collects values of one type from values of a possibly -- different type. -- -- For more details, see "Generics.EMGM.Functions.Collect". - Collect(..), - collect, - -- ** Compare Functions + -- ** Compare -- -- | Functions that compare two values to determine an ordering. -- -- For more details, see "Generics.EMGM.Functions.Compare". - Compare(..), - compare, - eq, neq, - lt, lteq, - gt, gteq, - min, max, - -- ** Crush Functions + -- ** Crush -- -- | Functions that crush a polymorphic functor container into an iteration -- over its elements. -- -- For more details, see "Generics.EMGM.Functions.Crush". - Crush(..), Assoc(..), - crush, crushl, crushr, - flatten, flattenl, flattenr, - first, firstl, firstr, - and, or, - any, all, - sum, product, - minimum, maximum, - elem, notElem, - -- ** Enum Functions + -- ** Enum -- -- | Functions that enumerate the values of a datatype. -- -- For more details, see "Generics.EMGM.Functions.Enum". - Enum(..), - enum, enumN, - empty, - -- ** Everywhere Functions + -- ** Everywhere -- -- | Functions that apply a transformation at every location of one type in a -- value of a possibly different type. -- -- For more details, see "Generics.EMGM.Functions.Everywhere". - Everywhere(..), - everywhere, - - Everywhere'(..), - everywhere', - -- ** Map Functions + -- ** Map -- -- | Functions that translate values of one type to values of another. This -- includes map-like functions that apply non-generic functions to every @@ -246,77 +198,93 @@ -- -- For more details, see "Generics.EMGM.Functions.Map". - Map(..), - map, - replace, - bimap, - cast, - -- ** Read Functions + -- ** Meta -- - -- | Functions similar to @deriving 'Prelude.Read'@ that parse a string and return a + -- | Functions for extracting meta-information about the representation. + -- + -- For more details, see "Generics.EMGM.Functions.Meta". + + HasEP(..), + conDescr, + lblDescrs, + + -- ** Read + -- + -- | Functions similar to @deriving Prelude.Read@ that parse a string and return a -- value of a datatype. -- -- For more details, see "Generics.EMGM.Functions.Read". - Read(..), - readPrec, readP, - readsPrec, reads, - read, - -- ** Show Functions + -- ** Show -- - -- | Functions similar to @deriving 'Prelude.Show'@ that return a string + -- | Functions similar to @deriving Prelude.Show@ that return a string -- representation of a value of a datatype. -- -- For more details, see "Generics.EMGM.Functions.Show". - Show(..), - showsPrec, shows, - show, - -- ** UnzipWith Functions + -- ** Transpose -- + -- | Functions that transpose polymorphic functor values. + -- + -- For more details, see "Generics.EMGM.Functions.Transpose". + + transpose, + transposeE, + + -- ** UnzipWith + -- -- | Functions that split a polymorphic functor values into two structurally -- equilvalent values. -- -- For more details, see "Generics.EMGM.Functions.UnzipWith". - UnzipWith(..), - - unzip, + unzipWithM, unzipWith, + unzip, - -- ** ZipWith Functions + -- ** ZipWith -- -- | Functions that combine two structurally equilvalent, polymorphic functor -- values into one. -- -- For more details, see "Generics.EMGM.Functions.ZipWith". - ZipWith(..), - - zip, + zipWithM, zipWith, + zip, ) where -import qualified Prelude +import qualified Prelude () -import Generics.EMGM.Common -import Generics.EMGM.Functions +import Generics.EMGM.Base +import Generics.EMGM.Functions.Collect +import Generics.EMGM.Functions.Compare +import Generics.EMGM.Functions.Crush +import Generics.EMGM.Functions.Enum +import Generics.EMGM.Functions.Everywhere +import Generics.EMGM.Functions.Map +import Generics.EMGM.Functions.Meta +import Generics.EMGM.Functions.Read +import Generics.EMGM.Functions.Show +import Generics.EMGM.Functions.Transpose +import Generics.EMGM.Functions.UnzipWith +import Generics.EMGM.Functions.ZipWith -- Export the instances from these import Generics.EMGM.Data.Bool() diff --git a/src/Generics/EMGM/Base.hs b/src/Generics/EMGM/Base.hs new file mode 100644 --- /dev/null +++ b/src/Generics/EMGM/Base.hs @@ -0,0 +1,270 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Generics.EMGM.Base +-- Copyright : (c) 2008, 2009 Universiteit Utrecht +-- License : BSD3 +-- +-- Maintainer : generics@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- Summary: Type classes used for generic functions with /one/ generic argument. +-- +-- A /generic function/ is defined as an instance of 'Generic', 'Generic2', or +-- 'Generic3'. Each method in the class serves for a case in the datatype +-- representation +-- +-- A /representation dispatcher/ simplifies the use of a generic function. There +-- must be an instance of each of the classes 'Rep', 'FRep', 'FRep2', etc. (that +-- apply) for every datatype. +----------------------------------------------------------------------------- + +{-# OPTIONS_GHC -Wall #-} + +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE OverlappingInstances #-} + +module Generics.EMGM.Base ( + + -- | Re-export the types and related functions for the structure + -- representation. + + module Generics.EMGM.Representation, + + -- * Classes for Generic Functions + + Generic(..), + Generic2(..), + Generic3(..), + + -- * Classes for Representation Dispatchers + + Rep(..), + FRep(..), + FRep2(..), + BiFRep2(..), + FRep3(..), + +) where + +import Generics.EMGM.Representation + +-- | This class forms the foundation for defining generic functions with a +-- single generic argument. Each method represents a type case. There are cases +-- for primitive types, structural representation types, and for user-defined +-- datatypes. +-- +-- The included modules using @Generic@ are: +-- +-- * "Generics.EMGM.Functions.Collect" +-- +-- * "Generics.EMGM.Functions.Compare" +-- +-- * "Generics.EMGM.Functions.Constructor" +-- +-- * "Generics.EMGM.Functions.Crush" +-- +-- * "Generics.EMGM.Functions.Enum" +-- +-- * "Generics.EMGM.Functions.Read" +-- +-- * "Generics.EMGM.Functions.Show" + +class Generic g where + + -- | Case for the primitive type 'Int'. + rint :: g Int + + -- | Case for the primitive type 'Integer'. + + rinteger :: g Integer + + -- | Case for the primitive type 'Float'. + + rfloat :: g Float + + -- | Case for the primitive type 'Double'. + + rdouble :: g Double + + -- | Case for the primitive type 'Char'. + + rchar :: g Char + + -- | Case for the structural representation type 'Unit'. Represents a + -- constructor with no arguments. + + runit :: g Unit + + -- | Case for the structural representation type @:+:@ (sum). Represents + -- alternative constructors. + + rsum :: g a -> g b -> g (a :+: b) + + -- | Case for the structural representation type @:*:@ (product). Represents + -- the fields of a constructor. + + rprod :: g a -> g b -> g (a :*: b) + + -- | Case for constructors. It is used to hold the meta-information about a + -- constructor, e.g. name, arity, fixity, etc. This is not needed for many + -- generic functions, so the default implementation is: + -- + -- @ + -- rcon = const id + -- @ + + rcon :: ConDescr -> g a -> g a + rcon = const id + + -- | Case for labeled field. Contains the label string. This is not needed for + -- many generic functions, so the default implementation is: + -- + -- @ + -- rlbl = const id + -- @ + + rlbl :: LblDescr -> g a -> g a + rlbl = const id + + -- | 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'. + + rtype :: EP b a -> g a -> g b + + +infixr 5 `rsum` +infixr 6 `rprod` + +-- | This class forms the foundation for defining generic functions with two +-- generic arguments. See 'Generic' for details. +-- +-- The included modules using @Generic2@ are: +-- +-- * "Generics.EMGM.Functions.Map" +-- +-- * "Generics.EMGM.Functions.Transpose" + +class Generic2 g where + + rint2 :: g Int Int + rinteger2 :: g Integer Integer + rfloat2 :: g Float Float + rdouble2 :: g Double Double + rchar2 :: g Char Char + runit2 :: g Unit Unit + rsum2 :: g a1 a2 -> g b1 b2 -> g (a1 :+: b1) (a2 :+: b2) + rprod2 :: g a1 a2 -> g b1 b2 -> g (a1 :*: b1) (a2 :*: b2) + + rcon2 :: ConDescr -> g a1 a2 -> g a1 a2 + rcon2 = const id + + rlbl2 :: LblDescr -> g a1 a2 -> g a1 a2 + rlbl2 = const id + + -- | See 'rtype'. This case is the primary difference that separates + -- 'Generic2' from 'Generic'. Since we have two generic type parameters, we + -- need to have two 'EP' values. Each translates between the Haskell type and + -- its generic representation. + rtype2 :: EP a2 a1 -> EP b2 b1 -> g a1 b1 -> g a2 b2 + + +infixr 5 `rsum2` +infixr 6 `rprod2` + +-- | This class forms the foundation for defining generic functions with three +-- generic arguments. See 'Generic' for details. +-- +-- The included modules using @Generic3@ are: +-- +-- * "Generics.EMGM.Functions.UnzipWith" +-- +-- * "Generics.EMGM.Functions.ZipWith" + +class Generic3 g where + + rint3 :: g Int Int Int + rinteger3 :: g Integer Integer Integer + rfloat3 :: g Float Float Float + rdouble3 :: g Double Double Double + rchar3 :: g Char Char Char + runit3 :: g Unit Unit Unit + rsum3 :: g a1 a2 a3 -> g b1 b2 b3 -> g (a1 :+: b1) (a2 :+: b2) (a3 :+: b3) + rprod3 :: g a1 a2 a3 -> g b1 b2 b3 -> g (a1 :*: b1) (a2 :*: b2) (a3 :*: b3) + + rcon3 :: ConDescr -> g a1 a2 a3 -> g a1 a2 a3 + rcon3 = const id + + rlbl3 :: LblDescr -> g a1 a2 a3 -> g a1 a2 a3 + rlbl3 = const id + + -- | See 'rtype'. This case is the primary difference that separates + -- 'Generic3' from 'Generic'. Since we have three generic type parameters, we + -- need three 'EP' values. Each translates between the Haskell type and its + -- generic representation. + rtype3 :: EP a2 a1 -> EP b2 b1 -> EP c2 c1 -> g a1 b1 c1 -> g a2 b2 c2 + + +infixr 5 `rsum3` +infixr 6 `rprod3` + +-- | Representation dispatcher for monomorphic types (kind @*@) used with +-- 'Generic'. Every structure type and supported datatype should have an +-- instance of 'Rep'. + +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 + +-- | Representation dispatcher for functor types (kind @* -> *@) used with +-- 'Generic'. + +class FRep g f where + frep :: g a -> g (f a) + +-- | Representation dispatcher for functor types (kind @* -> *@) used with +-- 'Generic2'. + +class FRep2 g f where + frep2 :: g a b -> g (f a) (f b) + +-- | Representation dispatcher for bifunctor types (kind @* -> *@) used with +-- 'Generic2'. + +class BiFRep2 g f where + bifrep2 :: g a1 b1 -> g a2 b2 -> g (f a1 a2) (f b1 b2) + +-- | Representation dispatcher for functor types (kind @* -> *@) used with +-- 'Generic3'. + +class FRep3 g f where + frep3 :: g a b c -> g (f a) (f b) (f c) + diff --git a/src/Generics/EMGM/Common.hs b/src/Generics/EMGM/Common.hs deleted file mode 100644 --- a/src/Generics/EMGM/Common.hs +++ /dev/null @@ -1,27 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Generics.EMGM.Common --- Copyright : (c) 2008, 2009 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 deleted file mode 100644 --- a/src/Generics/EMGM/Common/Base.hs +++ /dev/null @@ -1,172 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE OverlappingInstances #-} - ------------------------------------------------------------------------------ --- | --- Module : Generics.EMGM.Common.Base --- Copyright : (c) 2008, 2009 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 @:+:@ (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 @:*:@ (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 functor types (kind @* -> *@), --- sometimes called container 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 deleted file mode 100644 --- a/src/Generics/EMGM/Common/Base2.hs +++ /dev/null @@ -1,129 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeOperators #-} - ------------------------------------------------------------------------------ --- | --- Module : Generics.EMGM.Common.Base2 --- Copyright : (c) 2008, 2009 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(..), - BiFRep2(..), -) 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 @:+:@ (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 @:*:@ (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 functor types (kind @* -> *@), --- sometimes called container types. (No default implementation.) -class FRep2 g f where - frep2 :: g a b -> g (f a) (f b) - --- | The 'Generic2' representation dispatcher for bifunctor types (kind --- @* -> * -> *@). (No default implementation.) -class BiFRep2 g f where - bifrep2 :: g a1 b1 -> g a2 b2 -> g (f a1 a2) (f b1 b2) - diff --git a/src/Generics/EMGM/Common/Base3.hs b/src/Generics/EMGM/Common/Base3.hs deleted file mode 100644 --- a/src/Generics/EMGM/Common/Base3.hs +++ /dev/null @@ -1,125 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeOperators #-} - ------------------------------------------------------------------------------ --- | --- Module : Generics.EMGM.Common.Base3 --- Copyright : (c) 2008, 2009 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 @:+:@ (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 @:*:@ (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 functor types (kind @* -> *@), --- sometimes called container 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 deleted file mode 100644 --- a/src/Generics/EMGM/Common/Representation.hs +++ /dev/null @@ -1,179 +0,0 @@ - ------------------------------------------------------------------------------ --- | --- Module : Generics.EMGM.Common.Representation --- Copyright : (c) 2008, 2009 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 unit, sum, and product types form the sum-of-products view for a - -- Haskell datatype. - - Unit(..), - (:+:)(..), - (:*:)(..), - - -- * Embedding-Projection Pair - -- - -- | A pair of a function and its inverse form the isomorphism between a - -- datatype and its structure representation. - - EP(..), - - -- * Constructor Description - -- - -- | A description of the syntax of each constructor provides useful auxiliary - -- information for some generic functions. - - 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, - - ) where - -import Text.ParserCombinators.ReadPrec (minPrec, Prec) - -infixr 5 :+: -infixr 6 :*: - --- | The \"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. An @EP@ value preserves an isomorphism --- (ignoring @_|_@s) between a datatype and its structure representation. -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. --- --- NOTE: It is important that the 'ConDescr' value accurately describe the --- syntax in a constructor declaration. An incorrect description may lead to --- faulty 'Read' or 'Show' operation. -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 (Eq, 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 (Eq, Show) - --- TODO: Need smart constructor(s) for ConDescr, so we can verify things. - --- | An identifier's fixity, associativity, and precedence. If not infix --- ('Nonfix'), the associativity and precedence of the identifier is the same as --- function application. If infix, the associativity is indicated by the --- constructor and the precedence is an argument to it. -data Fixity - = Nonfix -- ^ Not infix. Associativity and precedence are the same as function application. - | 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/Bool.hs b/src/Generics/EMGM/Data/Bool.hs --- a/src/Generics/EMGM/Data/Bool.hs +++ b/src/Generics/EMGM/Data/Bool.hs @@ -1,13 +1,3 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverlappingInstances #-} -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS -fno-warn-orphans #-} -{- OPTIONS -ddump-splices -} - ----------------------------------------------------------------------------- -- | -- Module : Generics.EMGM.Data.Bool @@ -21,8 +11,19 @@ -- Summary: Generic representation and instances for 'Bool'. ----------------------------------------------------------------------------- +{-# OPTIONS_GHC -Wall #-} + +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverlappingInstances #-} +{-# OPTIONS -fno-warn-orphans #-} +{- OPTIONS -ddump-splices -} + module Generics.EMGM.Data.Bool ( - epBool, + BoolS, conFalse, conTrue, repBool, @@ -32,43 +33,42 @@ bifrep2Bool, ) where -import Generics.EMGM.Derive.Internal - -#ifndef __HADDOCK__ - -$(derive ''Bool) +import Control.Applicative (Alternative, pure) -#else --- The following code is used by Haddock to generate documentation. It may be --- useful to keep around for debugging TH, so don't remove it. +import Generics.EMGM.Base +import Generics.EMGM.Functions.Collect +import Generics.EMGM.Functions.Everywhere +import Generics.EMGM.Functions.Meta ----------------------------------------------------------------------------- -- 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 +-- Structure representation type for 'Bool'. +type BoolS = Unit :+: Unit --- | Embedding-projection pair for 'Bool'. -epBool :: EP Bool (Unit :+: Unit) +epBool :: EP Bool BoolS epBool = EP fromBool toBool + where + fromBool False = L Unit + fromBool True = R Unit + toBool (L Unit) = False + toBool (R Unit) = True +instance HasEP Bool BoolS where + epOf _ = epBool + ----------------------------------------------------------------------------- -- Representation values ----------------------------------------------------------------------------- -- | Constructor description for 'False'. conFalse :: ConDescr -conFalse = ConDescr "False" 0 [] Nonfix +conFalse = ConDescr "False" 0 False Prefix -- | Constructor description for 'True'. conTrue :: ConDescr -conTrue = ConDescr "True" 0 [] Nonfix +conTrue = ConDescr "True" 0 False Prefix -- | Representation of 'Bool' for 'rep'. repBool :: (Generic g) => g Bool @@ -108,14 +108,12 @@ instance (Generic g) => Rep g Bool where rep = repBool -instance Rep (Collect Bool) Bool where - rep = Collect (:[]) +instance (Alternative f) => Rep (Collect f Bool) Bool where + rep = Collect pure instance Rep (Everywhere Bool) Bool where rep = Everywhere ($) instance Rep (Everywhere' Bool) Bool where rep = Everywhere' ($) - -#endif diff --git a/src/Generics/EMGM/Data/Either.hs b/src/Generics/EMGM/Data/Either.hs --- a/src/Generics/EMGM/Data/Either.hs +++ b/src/Generics/EMGM/Data/Either.hs @@ -1,13 +1,3 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverlappingInstances #-} -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS -fno-warn-orphans #-} -{- OPTIONS -ddump-splices -} - ----------------------------------------------------------------------------- -- | -- Module : Generics.EMGM.Data.Either @@ -21,8 +11,19 @@ -- Summary: Generic representation and instances for 'Either'. ----------------------------------------------------------------------------- +{-# OPTIONS_GHC -Wall #-} + +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverlappingInstances #-} +{-# OPTIONS -fno-warn-orphans #-} +{- OPTIONS -ddump-splices -} + module Generics.EMGM.Data.Either ( - epEither, + EitherS, conLeft, conRight, repEither, @@ -32,43 +33,42 @@ bifrep2Either, ) where -import Generics.EMGM.Derive.Internal - -#ifndef __HADDOCK__ - -$(derive ''Either) +import Control.Applicative (Alternative, pure) -#else --- The following code is used by Haddock to generate documentation. It may be --- useful to keep around for debugging TH, so don't remove it. +import Generics.EMGM.Base +import Generics.EMGM.Functions.Collect +import Generics.EMGM.Functions.Everywhere +import Generics.EMGM.Functions.Meta ----------------------------------------------------------------------------- -- 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 +-- Structure representation type for 'Either'. +type EitherS a b = a :+: b --- | Embedding-projection pair for 'Either'. -epEither :: EP (Either a b) (a :+: b) +epEither :: EP (Either a b) (EitherS a b) epEither = EP fromEither toEither + where + fromEither (Left a) = L a + fromEither (Right b) = R b + toEither (L a) = Left a + toEither (R b) = Right b +instance HasEP (Either a b) (EitherS a b) where + epOf _ = epEither + ----------------------------------------------------------------------------- -- Representation values ----------------------------------------------------------------------------- -- | Constructor description for 'Left'. conLeft :: ConDescr -conLeft = ConDescr "Left" 1 [] Nonfix +conLeft = ConDescr "Left" 1 False Prefix -- | Constructor description for 'Right'. conRight :: ConDescr -conRight = ConDescr "Right" 1 [] Nonfix +conRight = ConDescr "Right" 1 False Prefix -- | Representation of 'Either' for 'frep'. frepEither :: (Generic g) => g a -> g b -> g (Either a b) @@ -80,7 +80,9 @@ -- | Representation of 'Either' for 'rep'. repEither :: (Generic g, Rep g a, Rep g b) => g (Either a b) repEither = - frepEither rep rep + rtype + epEither + (rcon conLeft rep `rsum` rcon conRight rep) -- | Representation of 'Either' for 'frep2'. frep2Either :: (Generic2 g) => g a1 a2 -> g b1 b2 -> g (Either a1 b1) (Either a2 b2) @@ -111,8 +113,8 @@ instance (Generic2 g) => BiFRep2 g Either where bifrep2 = bifrep2Either -instance Rep (Collect (Either a b)) (Either a b) where - rep = Collect (:[]) +instance (Alternative f) => Rep (Collect f (Either a b)) (Either a b) where + rep = Collect pure instance (Rep (Everywhere (Either a b)) a, Rep (Everywhere (Either a b)) b) => Rep (Everywhere (Either a b)) (Either a b) where @@ -125,6 +127,4 @@ instance Rep (Everywhere' (Either a b)) (Either a b) where rep = Everywhere' ($) - -#endif diff --git a/src/Generics/EMGM/Data/List.hs b/src/Generics/EMGM/Data/List.hs --- a/src/Generics/EMGM/Data/List.hs +++ b/src/Generics/EMGM/Data/List.hs @@ -1,10 +1,3 @@ -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverlappingInstances #-} -{-# OPTIONS -fno-warn-orphans #-} - ----------------------------------------------------------------------------- -- | -- Module : Generics.EMGM.Data.List @@ -18,8 +11,18 @@ -- Summary: Generic representation and instances for lists. ----------------------------------------------------------------------------- +{-# OPTIONS_GHC -Wall #-} + +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverlappingInstances #-} +{-# OPTIONS -fno-warn-orphans #-} + module Generics.EMGM.Data.List ( - epList, + ListS, conNil, conCons, repList, @@ -29,35 +32,42 @@ bifrep2List, ) where -import Generics.EMGM.Derive.Internal +import Control.Applicative (Alternative, pure) +import Generics.EMGM.Base +import Generics.EMGM.Functions.Collect +import Generics.EMGM.Functions.Everywhere +import Generics.EMGM.Functions.Meta + ----------------------------------------------------------------------------- -- 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 +-- Structure representation type for lists. +type ListS a = Unit :+: a :*: [a] --- | Embedding-projection pair for lists. -epList :: EP [a] (Unit :+: (a :*: [a])) +epList :: EP [a] (ListS a) epList = EP fromList toList + where + fromList [] = L Unit + fromList (a : as) = R (a :*: as) + toList (L Unit) = [] + toList (R (a :*: as)) = a : as +instance HasEP [a] (ListS a) where + epOf _ = epList + ----------------------------------------------------------------------------- -- Representation values ----------------------------------------------------------------------------- -- | Constructor description for ''nil'': @[]@. conNil :: ConDescr -conNil = ConDescr "[]" 0 [] Nonfix +conNil = ConDescr "[]" 0 False Prefix -- | Constructor description for ''cons'': @(:)@. conCons :: ConDescr -conCons = ConDescr ":" 2 [] (Infixr 5) +conCons = ConDescr ":" 2 False (Infix RightAssoc 5) -- | Representation of lists for 'frep'. frepList :: (Generic g) => g a -> g [a] @@ -67,9 +77,11 @@ (rcon conNil runit `rsum` rcon conCons (ra `rprod` frepList ra)) -- | Representation of lists for 'rep'. -repList :: (Generic g, Rep g a) => g [a] +repList :: (Generic g, Rep g a, Rep g [a]) => g [a] repList = - frepList rep + rtype + epList + (rcon conNil runit `rsum` rcon conCons (rep `rprod` rep)) -- | Representation of lists for 'frep2'. frep2List :: (Generic2 g) => g a b -> g [a] [b] @@ -106,8 +118,8 @@ instance (Generic3 g) => FRep3 g [] where frep3 = frep3List -instance Rep (Collect [a]) [a] where - rep = Collect (:[]) +instance (Alternative f) => Rep (Collect f [a]) [a] where + rep = Collect pure instance (Rep (Everywhere [a]) a) => Rep (Everywhere [a]) [a] where rep = Everywhere app diff --git a/src/Generics/EMGM/Data/Maybe.hs b/src/Generics/EMGM/Data/Maybe.hs --- a/src/Generics/EMGM/Data/Maybe.hs +++ b/src/Generics/EMGM/Data/Maybe.hs @@ -1,13 +1,3 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverlappingInstances #-} -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS -fno-warn-orphans #-} -{- OPTIONS -ddump-splices -} - ----------------------------------------------------------------------------- -- | -- Module : Generics.EMGM.Data.Maybe @@ -21,8 +11,19 @@ -- Summary: Generic representation and instances for 'Maybe'. ----------------------------------------------------------------------------- +{-# OPTIONS_GHC -Wall #-} + +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverlappingInstances #-} +{-# OPTIONS -fno-warn-orphans #-} +{- OPTIONS -ddump-splices -} + module Generics.EMGM.Data.Maybe ( - epMaybe, + MaybeS, conNothing, conJust, repMaybe, @@ -32,43 +33,42 @@ bifrep2Maybe, ) where -import Generics.EMGM.Derive.Internal - -#ifndef __HADDOCK__ - -$(derive ''Maybe) +import Control.Applicative (Alternative, pure) -#else --- The following code is used by Haddock to generate documentation. It may be --- useful to keep around for debugging TH, so don't remove it. +import Generics.EMGM.Base +import Generics.EMGM.Functions.Collect +import Generics.EMGM.Functions.Everywhere +import Generics.EMGM.Functions.Meta ----------------------------------------------------------------------------- -- 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 +-- Structure representation type for 'Maybe'. +type MaybeS a = Unit :+: a --- | Embedding-projection pair for 'Maybe'. -epMaybe :: EP (Maybe a) (Unit :+: a) +epMaybe :: EP (Maybe a) (MaybeS a) epMaybe = EP fromMaybe toMaybe + where + fromMaybe Nothing = L Unit + fromMaybe (Just a) = R a + toMaybe (L Unit) = Nothing + toMaybe (R a) = Just a +instance HasEP (Maybe a) (MaybeS a) where + epOf _ = epMaybe + ----------------------------------------------------------------------------- -- Representation values ----------------------------------------------------------------------------- -- | Constructor description for 'Nothing'. conNothing :: ConDescr -conNothing = ConDescr "Nothing" 0 [] Nonfix +conNothing = ConDescr "Nothing" 0 False Prefix -- | Constructor description for 'Just'. conJust :: ConDescr -conJust = ConDescr "Just" 1 [] Nonfix +conJust = ConDescr "Just" 1 False Prefix -- | Representation of 'Maybe' for 'frep'. frepMaybe :: (Generic g) => g a -> g (Maybe a) @@ -80,7 +80,9 @@ -- | Representation of 'Maybe' for 'rep'. repMaybe :: (Generic g, Rep g a) => g (Maybe a) repMaybe = - frepMaybe rep + rtype + epMaybe + (rcon conNothing rep `rsum` rcon conJust rep) -- | Representation of 'Maybe' for 'frep2'. frep2Maybe :: (Generic2 g) => g a b -> g (Maybe a) (Maybe b) @@ -117,8 +119,8 @@ instance (Generic3 g) => FRep3 g Maybe where frep3 = frep3Maybe -instance Rep (Collect (Maybe a)) (Maybe a) where - rep = Collect (:[]) +instance (Alternative f) => Rep (Collect f (Maybe a)) (Maybe a) where + rep = Collect pure instance (Rep (Everywhere (Maybe a)) a) => Rep (Everywhere (Maybe a)) (Maybe a) where rep = Everywhere app @@ -130,6 +132,4 @@ instance Rep (Everywhere' (Maybe a)) (Maybe a) where rep = Everywhere' ($) - -#endif diff --git a/src/Generics/EMGM/Data/Ratio.hs b/src/Generics/EMGM/Data/Ratio.hs new file mode 100644 --- /dev/null +++ b/src/Generics/EMGM/Data/Ratio.hs @@ -0,0 +1,109 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Generics.EMGM.Data.Ratio +-- Copyright : (c) 2010 Antoine Latter, Universiteit Utrecht +-- License : BSD3 +-- +-- Maintainer : generics@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- Summary: Generic representation and instances for 'Ratio'. +----------------------------------------------------------------------------- + +{-# OPTIONS_GHC -Wall #-} + +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverlappingInstances #-} +{-# OPTIONS -fno-warn-orphans #-} + +module Generics.EMGM.Data.Ratio ( + RatioS, + conRatio, + repRatio, + frepRatio, + frep2Ratio, + frep3Ratio, + bifrep2Ratio, +) where + +import Data.Ratio (Ratio, (%), numerator, denominator) +import Control.Applicative (Alternative, pure) +import Generics.EMGM.Base +import Generics.EMGM.Functions.Collect +import Generics.EMGM.Functions.Everywhere +import Generics.EMGM.Functions.Meta + +----------------------------------------------------------------------------- +-- Embedding-projection pair +----------------------------------------------------------------------------- + +type RatioS a = a :*: a + +epRatio :: (Integral a) => EP (Ratio a) (a :*: a) +epRatio = EP f t + where + f r = numerator r :*: denominator r + t (num :*: det) = num % det + +instance (Integral a) => HasEP (Ratio a) (RatioS a) where + epOf _ = epRatio + +----------------------------------------------------------------------------- +-- Representation values +----------------------------------------------------------------------------- + +-- | Constructor description for '%'. +conRatio :: ConDescr +conRatio = ConDescr "%" 2 False (Infix LeftAssoc 7) + +-- | Representation of 'Ratio' for 'rep'. +repRatio :: (Integral a, Generic g, Rep g a) => g (Ratio a) +repRatio = rtype epRatio (rcon conRatio (rep `rprod` rep)) + +-- | Representation of 'Ratio' for 'frep'. +frepRatio :: (Integral a, Generic g) => g a -> g (Ratio a) +frepRatio a = rtype epRatio (rcon conRatio (a `rprod` a)) + +-- | Representation of 'Ratio' for 'frep2'. +frep2Ratio + :: (Integral a1, Integral a2, Generic2 g) + => g a1 a2 -> g (Ratio a1) (Ratio a2) +frep2Ratio a = rtype2 epRatio epRatio (rcon2 conRatio (a `rprod2` a)) + +-- | Representation of 'Ratio' for 'frep3'. +frep3Ratio + :: (Integral a1, Integral a2, Integral a3, Generic3 g) + => g a1 a2 a3 -> g (Ratio a1) (Ratio a2) (Ratio a3) +frep3Ratio a = rtype3 epRatio epRatio epRatio (rcon3 conRatio (a `rprod3` a)) + +-- | Representation of 'Ratio' for 'bifrep2'. +bifrep2Ratio + :: (Integral a1, Integral a2, Generic2 g) + => g a1 a2 -> g (Ratio a1) (Ratio a2) +bifrep2Ratio a = rtype2 epRatio epRatio (rcon2 conRatio (a `rprod2` a)) + +----------------------------------------------------------------------------- +-- Instance declarations +----------------------------------------------------------------------------- + +instance (Integral a, Generic g, Rep g a) => Rep g (Ratio a) where + rep = repRatio + +instance (Alternative f) => Rep (Collect f (Ratio a)) (Ratio a) where + rep = Collect pure + +instance (Integral a, Rep (Everywhere (Ratio a)) a) + => Rep (Everywhere (Ratio a)) (Ratio a) where + rep = Everywhere app + where + app f r = f $ + selEverywhere rep f (numerator r) % selEverywhere rep f (denominator r) + +instance Rep (Everywhere' (Ratio a)) (Ratio a) where + rep = Everywhere' ($) + diff --git a/src/Generics/EMGM/Data/TH.hs b/src/Generics/EMGM/Data/TH.hs deleted file mode 100644 --- a/src/Generics/EMGM/Data/TH.hs +++ /dev/null @@ -1,71 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverlappingInstances #-} -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS -fno-warn-orphans #-} -{- OPTIONS -ddump-splices -} - ------------------------------------------------------------------------------ --- | --- Module : Generics.EMGM.Data.TH --- Copyright : (c) 2008, 2009 Universiteit Utrecht --- License : BSD3 --- --- Maintainer : generics@haskell.org --- Stability : experimental --- Portability : non-portable --- --- Summary: Generic representation and instances for Template Haskell types. --- --- The main purpose of this module is to export the instances for the --- representation dispatcher 'Rep'. For the rare cases in which it is needed, --- this module also exports the embedding-projection pair and constructor --- description. --- --- /NOTE/: The exported values are not explicitly documented, because there is a --- large number and they are all generated with Template Haskell expressions. --- For a detailed look, use the @:browse@ command in GHCi. ------------------------------------------------------------------------------ - -module Generics.EMGM.Data.TH where - -import Generics.EMGM.Derive.Internal hiding (conName, conFixity, Fixity) -import Language.Haskell.TH - -#ifndef __HADDOCK__ - -$(deriveMono ''Name) -$(deriveMono ''Dec) -$(deriveMono ''Exp) -$(deriveMono ''Con) -$(deriveMono ''Type) -$(deriveMono ''Match) -$(deriveMono ''Clause) -$(deriveMono ''Body) -$(deriveMono ''Guard) -$(deriveMono ''Stmt) -$(deriveMono ''Range) -$(deriveMono ''Lit) -$(deriveMono ''Pat) -$(deriveMono ''Strict) -$(deriveMono ''Foreign) -$(deriveMono ''Callconv) -$(deriveMono ''Safety) -$(deriveMono ''FunDep) -$(deriveMono ''Info) - -#ifdef TH_LOC_DERIVEREP --- This type is only provided in template-haskell-2.3 (included with GHC 6.10) --- and up. -$(deriveMono ''Loc) -#endif - -$(deriveMono ''Fixity) -$(deriveMono ''FixityDirection) - -#endif - diff --git a/src/Generics/EMGM/Data/Tuple.hs b/src/Generics/EMGM/Data/Tuple.hs --- a/src/Generics/EMGM/Data/Tuple.hs +++ b/src/Generics/EMGM/Data/Tuple.hs @@ -1,10 +1,3 @@ -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverlappingInstances #-} -{-# OPTIONS -fno-warn-orphans #-} - ----------------------------------------------------------------------------- -- | -- Module : Generics.EMGM.Data.Tuple @@ -19,10 +12,20 @@ -- (''unit'') and 2 to 7. ----------------------------------------------------------------------------- +{-# OPTIONS_GHC -Wall #-} + +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverlappingInstances #-} +{-# OPTIONS -fno-warn-orphans #-} + module Generics.EMGM.Data.Tuple ( -- * Unit: @()@ - epTuple0, + Tuple0S, conTuple0, repTuple0, frepTuple0, @@ -31,7 +34,7 @@ bifrep2Tuple0, -- * Pair: @(a,b)@ - epTuple2, + Tuple2S, conTuple2, repTuple2, frepTuple2, @@ -40,7 +43,7 @@ bifrep2Tuple2, -- * Triple: @(a,b,c)@ - epTuple3, + Tuple3S, conTuple3, repTuple3, frepTuple3, @@ -49,7 +52,7 @@ bifrep2Tuple3, -- * Quadruple: @(a,b,c,d)@ - epTuple4, + Tuple4S, conTuple4, repTuple4, frepTuple4, @@ -58,7 +61,7 @@ bifrep2Tuple4, -- * Quintuple: @(a,b,c,d,e)@ - epTuple5, + Tuple5S, conTuple5, repTuple5, frepTuple5, @@ -67,7 +70,7 @@ bifrep2Tuple5, -- * Sextuple: @(a,b,c,d,e,f)@ - epTuple6, + Tuple6S, conTuple6, repTuple6, frepTuple6, @@ -76,7 +79,7 @@ bifrep2Tuple6, -- * Septuple: @(a,b,c,d,e,f,h)@ - epTuple7, + Tuple7S, conTuple7, repTuple7, frepTuple7, @@ -86,20 +89,29 @@ ) where -import Generics.EMGM.Derive.Internal +import Control.Applicative (Alternative, pure) +import Generics.EMGM.Base +import Generics.EMGM.Functions.Collect +import Generics.EMGM.Functions.Everywhere +import Generics.EMGM.Functions.Meta + ----------------------------------------------------------------------------- -- 0: () ----------------------------------------------------------------------------- --- | Embedding-projection pair for @()@. -epTuple0 :: EP () Unit +type Tuple0S = Unit + +epTuple0 :: EP () Tuple0S epTuple0 = EP (\() -> Unit) (\Unit -> ()) +instance HasEP () Tuple0S where + epOf _ = epTuple0 + -- | Constructor description for @()@. conTuple0 :: ConDescr -conTuple0 = ConDescr "()" 0 [] Nonfix +conTuple0 = ConDescr "()" 0 False Prefix -- | Representation of @()@ for 'rep'. repTuple0 :: (Generic g) => g () @@ -136,14 +148,18 @@ -- 2: (a,b) ----------------------------------------------------------------------------- --- | Embedding-projection pair for @(,)@. -epTuple2 :: EP (a,b) (a :*: b) +type Tuple2S a b = a :*: b + +epTuple2 :: EP (a,b) (Tuple2S a b) epTuple2 = EP (\(a,b) -> a :*: b) (\(a :*: b) -> (a,b)) +instance HasEP (a,b) (Tuple2S a b) where + epOf _ = epTuple2 + -- | Constructor description for @(,)@. conTuple2 :: ConDescr -conTuple2 = ConDescr "(,)" 2 [] Nonfix +conTuple2 = ConDescr "(,)" 2 False Prefix -- | Representation of @(,)@ for 'frep'. frepTuple2 :: (Generic g) => g a -> g b -> g (a,b) @@ -180,14 +196,18 @@ -- 3: (a,b,c) ----------------------------------------------------------------------------- --- | Embedding-projection pair for @(,,)@. -epTuple3 :: EP (a,b,c) (a :*: b :*: c) +type Tuple3S a b c = a :*: b :*: c + +epTuple3 :: EP (a,b,c) (Tuple3S a b c) epTuple3 = EP (\(a,b,c) -> a :*: b :*: c) (\(a :*: b :*: c) -> (a,b,c)) +instance HasEP (a,b,c) (Tuple3S a b c) where + epOf _ = epTuple3 + -- | Constructor description for @(,,)@. conTuple3 :: ConDescr -conTuple3 = ConDescr "(,,)" 3 [] Nonfix +conTuple3 = ConDescr "(,,)" 3 False Prefix -- | Representation of @(,,)@ for 'frep'. frepTuple3 :: (Generic g) => g a -> g b -> g c -> g (a,b,c) @@ -199,7 +219,9 @@ -- | Representation of @(,,)@ for 'rep'. repTuple3 :: (Generic g, Rep g a, Rep g b, Rep g c) => g (a,b,c) repTuple3 = - frepTuple3 rep rep rep + rtype + epTuple3 + (rcon conTuple3 (rep `rprod` rep `rprod` rep)) -- | Representation of @(,,)@ for 'frep2'. frep2Tuple3 :: (Generic2 g) => g a1 a2 -> g b1 b2 -> g c1 c2 -> g (a1,b1,c1) (a2,b2,c2) @@ -224,14 +246,18 @@ -- 4: (a,b,c,d) ----------------------------------------------------------------------------- --- | Embedding-projection pair for @(,,,)@. -epTuple4 :: EP (a,b,c,d) (a :*: b :*: c :*: d) +type Tuple4S a b c d = a :*: b :*: c :*: d + +epTuple4 :: EP (a,b,c,d) (Tuple4S a b c d) epTuple4 = EP (\(a,b,c,d) -> a :*: b :*: c :*: d) (\(a :*: b :*: c :*: d) -> (a,b,c,d)) +instance HasEP (a,b,c,d) (Tuple4S a b c d) where + epOf _ = epTuple4 + -- | Constructor description for @(,,,)@. conTuple4 :: ConDescr -conTuple4 = ConDescr "(,,,)" 4 [] Nonfix +conTuple4 = ConDescr "(,,,)" 4 False Prefix -- | Representation of @(,,,)@ for 'frep'. frepTuple4 :: (Generic g) => g a -> g b -> g c -> g d -> g (a,b,c,d) @@ -243,7 +269,9 @@ -- | Representation of @(,,,)@ for 'rep'. repTuple4 :: (Generic g, Rep g a, Rep g b, Rep g c, Rep g d) => g (a,b,c,d) repTuple4 = - frepTuple4 rep rep rep rep + rtype + epTuple4 + (rcon conTuple4 (rep `rprod` rep `rprod` rep `rprod` rep)) -- | Representation of @(,,,)@ for 'frep2'. frep2Tuple4 :: (Generic2 g) => g a1 a2 -> g b1 b2 -> g c1 c2 -> g d1 d2 -> g (a1,b1,c1,d1) (a2,b2,c2,d2) @@ -268,14 +296,18 @@ -- 5: (a,b,c,d,e) ----------------------------------------------------------------------------- --- | Embedding-projection pair for @(,,,,)@. -epTuple5 :: EP (a,b,c,d,e) (a :*: b :*: c :*: d :*: e) +type Tuple5S a b c d e = a :*: b :*: c :*: d :*: e + +epTuple5 :: EP (a,b,c,d,e) (Tuple5S 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)) +instance HasEP (a,b,c,d,e) (Tuple5S a b c d e) where + epOf _ = epTuple5 + -- | Constructor description for @(,,,,)@. conTuple5 :: ConDescr -conTuple5 = ConDescr "(,,,,)" 5 [] Nonfix +conTuple5 = ConDescr "(,,,,)" 5 False Prefix -- | Representation of @(,,,,)@ for 'frep'. frepTuple5 :: (Generic g) => g a -> g b -> g c -> g d -> g e -> g (a,b,c,d,e) @@ -287,7 +319,9 @@ -- | Representation of @(,,,,)@ for 'rep'. repTuple5 :: (Generic g, Rep g a, Rep g b, Rep g c, Rep g d, Rep g e) => g (a,b,c,d,e) repTuple5 = - frepTuple5 rep rep rep rep rep + rtype + epTuple5 + (rcon conTuple5 (rep `rprod` rep `rprod` rep `rprod` rep `rprod` rep)) -- | Representation of @(,,,,)@ for 'frep2'. frep2Tuple5 :: (Generic2 g) => g a1 a2 -> g b1 b2 -> g c1 c2 -> g d1 d2 -> g e1 e2 -> g (a1,b1,c1,d1,e1) (a2,b2,c2,d2,e2) @@ -312,14 +346,18 @@ -- 6: (a,b,c,d,e,f) ----------------------------------------------------------------------------- --- | Embedding-projection pair for @(,,,,,)@. -epTuple6 :: EP (a,b,c,d,e,f) (a :*: b :*: c :*: d :*: e :*: f) +type Tuple6S a b c d e f = a :*: b :*: c :*: d :*: e :*: f + +epTuple6 :: EP (a,b,c,d,e,f) (Tuple6S 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)) +instance HasEP (a,b,c,d,e,f) (Tuple6S a b c d e f) where + epOf _ = epTuple6 + -- | Constructor description for @(,,,,,)@. conTuple6 :: ConDescr -conTuple6 = ConDescr "(,,,,,)" 6 [] Nonfix +conTuple6 = ConDescr "(,,,,,)" 6 False Prefix -- | Representation of @(,,,,,)@ for 'frep'. frepTuple6 :: (Generic g) => g a -> g b -> g c -> g d -> g e -> g f -> g (a,b,c,d,e,f) @@ -331,7 +369,9 @@ -- | Representation of @(,,,,,)@ for 'rep'. repTuple6 :: (Generic g, Rep g a, Rep g b, Rep g c, Rep g d, Rep g e, Rep g f) => g (a,b,c,d,e,f) repTuple6 = - frepTuple6 rep rep rep rep rep rep + rtype + epTuple6 + (rcon conTuple6 (rep `rprod` rep `rprod` rep `rprod` rep `rprod` rep `rprod` rep)) -- | Representation of @(,,,,,)@ for 'frep2'. frep2Tuple6 :: (Generic2 g) => g a1 a2 -> g b1 b2 -> g c1 c2 -> g d1 d2 -> g e1 e2 -> g f1 f2 -> g (a1,b1,c1,d1,e1,f1) (a2,b2,c2,d2,e2,f2) @@ -357,14 +397,18 @@ -- 7: (a,b,c,d,e,f,h) ----------------------------------------------------------------------------- --- | Embedding-projection pair for @(,,,,,,)@. -epTuple7 :: EP (a,b,c,d,e,f,h) (a :*: b :*: c :*: d :*: e :*: f :*: h) +type Tuple7S a b c d e f h = a :*: b :*: c :*: d :*: e :*: f :*: h + +epTuple7 :: EP (a,b,c,d,e,f,h) (Tuple7S 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)) +instance HasEP (a,b,c,d,e,f,h) (Tuple7S a b c d e f h) where + epOf _ = epTuple7 + -- | Constructor description for @(,,,,,,)@. conTuple7 :: ConDescr -conTuple7 = ConDescr "(,,,,,)" 7 [] Nonfix +conTuple7 = ConDescr "(,,,,,)" 7 False Prefix -- | Representation of @(,,,,,,)@ for 'frep'. frepTuple7 :: (Generic g) => g a -> g b -> g c -> g d -> g e -> g f -> g h -> g (a,b,c,d,e,f,h) @@ -376,7 +420,9 @@ -- | Representation of @(,,,,,,)@ for 'rep'. repTuple7 :: (Generic g, Rep g a, Rep g b, Rep g c, Rep g d, Rep g e, Rep g f, Rep g h) => g (a,b,c,d,e,f,h) repTuple7 = - frepTuple7 rep rep rep rep rep rep rep + rtype + epTuple7 + (rcon conTuple7 (rep `rprod` rep `rprod` rep `rprod` rep `rprod` rep `rprod` rep `rprod` rep)) -- | Representation of @(,,,,,,)@ for 'frep2'. frep2Tuple7 :: (Generic2 g) => g a1 a2 -> g b1 b2 -> g c1 c2 -> g d1 d2 -> g e1 e2 -> g f1 f2 -> g h1 h2 -> g (a1,b1,c1,d1,e1,f1,h1) (a2,b2,c2,d2,e2,f2,h2) @@ -425,26 +471,26 @@ instance (Generic2 g) => BiFRep2 g (,) where bifrep2 = frep2Tuple2 -instance Rep (Collect ()) () where - rep = Collect (:[]) +instance (Alternative f) => Rep (Collect f ()) () where + rep = Collect pure -instance Rep (Collect (a,b)) (a,b) where - rep = Collect (:[]) +instance (Alternative f) => Rep (Collect f (a,b)) (a,b) where + rep = Collect pure -instance Rep (Collect (a,b,c)) (a,b,c) where - rep = Collect (:[]) +instance (Alternative f) => Rep (Collect f (a,b,c)) (a,b,c) where + rep = Collect pure -instance Rep (Collect (a,b,c,d)) (a,b,c,d) where - rep = Collect (:[]) +instance (Alternative f) => Rep (Collect f (a,b,c,d)) (a,b,c,d) where + rep = Collect pure -instance Rep (Collect (a,b,c,d,e)) (a,b,c,d,e) where - rep = Collect (:[]) +instance (Alternative f) => Rep (Collect f (a,b,c,d,e)) (a,b,c,d,e) where + rep = Collect pure -instance Rep (Collect (a,b,c,d,e,f)) (a,b,c,d,e,f) where - rep = Collect (:[]) +instance (Alternative f) => Rep (Collect f (a,b,c,d,e,h)) (a,b,c,d,e,h) where + rep = Collect pure -instance Rep (Collect (a,b,c,d,e,f,h)) (a,b,c,d,e,f,h) where - rep = Collect (:[]) +instance (Alternative f) => Rep (Collect f (a,b,c,d,e,h,i)) (a,b,c,d,e,h,i) where + rep = Collect pure instance Rep (Everywhere' ()) () where rep = Everywhere' ($) diff --git a/src/Generics/EMGM/Derive.hs b/src/Generics/EMGM/Derive.hs deleted file mode 100644 --- a/src/Generics/EMGM/Derive.hs +++ /dev/null @@ -1,314 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskell #-} - ------------------------------------------------------------------------------ --- | --- Module : Generics.EMGM.Derive --- Copyright : (c) 2008, 2009 Universiteit Utrecht --- License : BSD3 --- --- Maintainer : generics@haskell.org --- Stability : experimental --- Portability : non-portable --- --- Summary: Functions for generating the representation for using a datatype --- with EMGM. --- --- The simplest way to get a representation for a datatype is using 'derive' in --- a Template Haskell declaration, e.g. @$('derive' ''MyType)@. This generates --- all of the appropriate instances, e.g. 'Rep', 'FRep', etc., for the type --- @MyType@. --- --- Generating datatype support can be done in a fully automatic way using --- 'derive' or 'deriveWith', or it can be done piecemeal using a number of other --- functions. For most needs, the automatic approach is fine. But if you find --- you need more control, use the manual deriving approach. --- --- Naming conventions: --- --- * @derive@ - Template Haskell function that generates instance declarations --- (and possibly also value declarations). --- --- * @declare@ - Template Haskell function that generates only value --- declarations. --- --- * @ep@ - Embedding-project pair. --- --- * @con@ - Constructor description. --- --- * @rep@ - Value representation meant for 'rep'. --- --- * @frep@ - Value representation meant for 'frep'. --- --- * @frep2@ - Value representation meant for 'frep2'. --- --- * @frep3@ - Value representation meant for 'frep3'. --- --- * @bifrep2@ - Value representation meant for 'bifrep2'. ------------------------------------------------------------------------------ - -module Generics.EMGM.Derive ( - - -- * Automatic Instance Deriving - -- - -- | The functions 'derive' and 'deriveWith' determine which representations - -- can be supported by your datatype. The indications are as follows for each - -- class: - -- - -- ['Rep'] This instance will be generated for every type. - -- - -- ['FRep', 'FRep2', 'FRep3'] These instances will only be generated for - -- functor types (kind @* -> *@). - -- - -- ['BiFRep2'] This instance will only be generated for bifunctor types (kind - -- @* -> * -> *@). - - derive, - deriveWith, - Modifier(..), - Modifiers, - - deriveMany, - deriveManyWith, - - deriveMono, - deriveMonoWith, - - -- * Manual Instance Deriving - -- - -- | Use the functions in this section for more control over the declarations - -- and instances that are generated. - -- - -- Since each function here generates one component needed for the entire - -- datatype representation, you will most likely need to use multiple TH - -- declarations. To get the equivalent of the resulting code described in - -- 'derive', you will need the following: - -- - -- > {-# LANGUAGE TemplateHaskell #-} - -- > {-# LANGUAGE MultiParamTypeClasses #-} - -- > {-# LANGUAGE FlexibleContexts #-} - -- > {-# LANGUAGE FlexibleInstances #-} - -- > {-# LANGUAGE OverlappingInstances #-} - -- > {-# LANGUAGE UndecidableInstances #-} - -- - -- @ - -- module Example where - -- import Generics.EMGM.Derive - -- data T a = C a Int - -- @ - -- - -- @ - -- $(declareConDescrs ''T) - -- $(declareEP ''T) - -- $(declareRepValues ''T) - -- $(deriveRep ''T) - -- $(deriveFRep ''T) - -- $(deriveCollect ''T) - -- $(deriveEverywhere ''T) - -- $(deriveEverywhere' ''T) - -- @ - - -- ** Constructor Description Declaration - -- - -- | Use the following to generate only the 'ConDescr' declarations. - - declareConDescrs, - declareConDescrsWith, - - -- ** Embedding-Project Pair Declaration - -- - -- | Use the following to generate only the 'EP' declarations. - - declareEP, - declareEPWith, - - -- ** Representation Value Declaration - -- - -- | Use the following to generate only the representation values that are - -- used in the instances for 'rep', 'frep', etc. - - declareRepValues, - declareRepValuesWith, - - declareMonoRep, - declareMonoRepWith, - - -- ** Rep Instance Deriving - -- - -- | Use the following to generate only the 'Rep' instances. - - deriveRep, - deriveRepWith, - - -- ** FRep Instance Deriving - -- - -- | Use the following to generate only the 'FRep', 'FRep2', and 'FRep3' - -- instances. - - deriveFRep, - deriveFRepWith, - - -- ** BiFRep Instance Deriving - -- - -- | Use the following to generate only the 'BiFRep2' instances. - - deriveBiFRep, - deriveBiFRepWith, - - -- ** Function-Specific Instance Deriving - -- - -- | Use the following to generate instances specific to certain functions. - - deriveCollect, - deriveEverywhere, - deriveEverywhere', - - -- * Datatype Representations - -- - -- | This is the collection of representation values for datatypes included - -- with EMGM. - - -- ** 'Bool' - - epBool, - conFalse, - conTrue, - repBool, - frepBool, - frep2Bool, - frep3Bool, - bifrep2Bool, - - -- ** 'Either' - - epEither, - conLeft, - conRight, - repEither, - frepEither, - frep2Either, - frep3Either, - bifrep2Either, - - -- ** List - - epList, - conNil, - conCons, - repList, - frepList, - frep2List, - frep3List, - bifrep2List, - - -- ** 'Maybe' - - epMaybe, - conNothing, - conJust, - repMaybe, - frepMaybe, - frep2Maybe, - frep3Maybe, - bifrep2Maybe, - - -- ** Tuples - - -- *** Unit: @()@ - epTuple0, - conTuple0, - repTuple0, - frepTuple0, - frep2Tuple0, - frep3Tuple0, - bifrep2Tuple0, - - -- *** Pair: @(a,b)@ - epTuple2, - conTuple2, - repTuple2, - frepTuple2, - frep2Tuple2, - frep3Tuple2, - bifrep2Tuple2, - - -- *** Triple: @(a,b,c)@ - epTuple3, - conTuple3, - repTuple3, - frepTuple3, - frep2Tuple3, - frep3Tuple3, - bifrep2Tuple3, - - -- *** Quadruple: @(a,b,c,d)@ - epTuple4, - conTuple4, - repTuple4, - frepTuple4, - frep2Tuple4, - frep3Tuple4, - bifrep2Tuple4, - - -- *** Quintuple: @(a,b,c,d,e)@ - epTuple5, - conTuple5, - repTuple5, - frepTuple5, - frep2Tuple5, - frep3Tuple5, - bifrep2Tuple5, - - -- *** Sextuple: @(a,b,c,d,e,f)@ - epTuple6, - conTuple6, - repTuple6, - frepTuple6, - frep2Tuple6, - frep3Tuple6, - bifrep2Tuple6, - - -- *** Septuple: @(a,b,c,d,e,f,h)@ - epTuple7, - conTuple7, - repTuple7, - frepTuple7, - frep2Tuple7, - frep3Tuple7, - bifrep2Tuple7, - - -- ** Template Haskell - -- - -- | For using the representation of Template Haskell, import - -- "Generics.EMGM.Data.TH". We don't export it here, because it exports - -- names that conflict with EMGM names. - - -- ** Derived Generic Functions - -- - -- | These @newtype@s are exported for generating their 'Rep' instances. - - Collect(..), - Everywhere(..), - Everywhere'(..), - - -- * Exported Modules - -- - -- | Re-export these modules for generated code. - - module Generics.EMGM.Common, - -) where - ------------------------------------------------------------------------------ --- Imports ------------------------------------------------------------------------------ - -import Generics.EMGM.Common -import Generics.EMGM.Derive.Internal - -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/Derive/Common.hs b/src/Generics/EMGM/Derive/Common.hs deleted file mode 100644 --- a/src/Generics/EMGM/Derive/Common.hs +++ /dev/null @@ -1,342 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskell #-} - ------------------------------------------------------------------------------ --- | --- Module : Generics.EMGM.Derive --- Copyright : (c) 2008, 2009 Universiteit Utrecht --- License : BSD3 --- --- Maintainer : generics@haskell.org --- Stability : experimental --- Portability : non-portable --- --- Summary: Common types and functions used in the deriving code. ------------------------------------------------------------------------------ - -module Generics.EMGM.Derive.Common where - ------------------------------------------------------------------------------ --- Imports ------------------------------------------------------------------------------ - -import Data.List (nub) - -import Language.Haskell.TH -import Data.Maybe (fromMaybe) - -import Generics.EMGM.Common.Representation -import Generics.EMGM.Common.Base -import Generics.EMGM.Common.Base2 -import Generics.EMGM.Common.Base3 - ------------------------------------------------------------------------------ --- Types ------------------------------------------------------------------------------ - --- | Normalized form of a datatype declaration (@data@ and @newtype@) -data DT - = DT - { tname :: Name -- Type name - , tvars :: [Name] -- Type variables - , dcons :: [Con] -- Data constructors - , ncons :: [NCon] -- Normalized data constructors - } deriving Show - --- | Normalized form of a constructor -data NCon - = NCon - { cname :: Name -- Constructor name - , cdescr :: Name -- 'ConDescr' declaration name - , cargtypes :: [Type] -- Constructor argument types - , cvars :: [Name] -- Generated constructor variable names - } deriving Show - --------------------------------------------------------------------------------- - --- | Modify the action taken for a given name. -data Modifier - = ChangeTo String -- ^ Change the syntactic name (of a type or - -- constructor) to the argument in the generated 'EP' - -- or 'ConDescr' value. This results in a value named - -- @epX@ or @conX@ if the argument is @\"X\"@. - | DefinedAs String -- ^ Use this for the name of a user-defined constructor - -- description instead of a generated one. The - -- generated code assumes the existance of @conX :: - -- 'ConDescr'@ (in scope) if the argument is @\"X\"@. - deriving Eq - -instance Show Modifier where - show (DefinedAs s) = s - show (ChangeTo s) = s - --- | List of pairs mapping a (type or constructor) name to a modifier action. -type Modifiers = [(String, Modifier)] - --------------------------------------------------------------------------------- - -data RepOpt = OptRep | OptFRep | OptFRep2 | OptFRep3 | OptBiFRep2 - deriving (Eq, Show) - -data RepNames - = RepNames - { genericCN' :: Name -- ^ One of the 'Generic' classes - , rintN' :: Name -- ^ Method from 'Generic' - , rintegerN' :: Name -- ^ Method from 'Generic' - , rfloatN' :: Name -- ^ Method from 'Generic' - , rdoubleN' :: Name -- ^ Method from 'Generic' - , rcharN' :: Name -- ^ Method from 'Generic' - , runitN' :: Name -- ^ Method from 'Generic' - , rsumN' :: Name -- ^ Method from 'Generic' - , rprodN' :: Name -- ^ Method from 'Generic' - , rconN' :: Name -- ^ Method from 'Generic' - , rtypeN' :: Name -- ^ Method from 'Generic' - , repCN' :: Name -- ^ One of the 'Rep' classes - , repN' :: Name -- ^ Method from 'Rep' - } - -data RepFunNames - = RepFunNames - { repFunN :: Name - , frepFunN :: Name - , frep2FunN :: Name - , frep3FunN :: Name - , bifrep2FunN :: Name - } - ------------------------------------------------------------------------------ --- General functions ------------------------------------------------------------------------------ - -toMaybeString :: Maybe Modifier -> Maybe String -toMaybeString mm = mm >>= return . show - --- | Select the i-th field in an n-tuple -sel :: Int -> Int -> Q Exp -sel i _ | i < 0 = reportError $ "sel: Error! i (= " ++ show i ++ ") is not >= 0." -sel i n | i >= n = reportError $ "sel: Error! i (= " ++ show i ++ ") is not < n (= " ++ show n ++ ")." -sel i n = - do x <- newName "x" - let firsts = replicate i wildP - lasts = replicate (n - i - 1) wildP - vars = firsts ++ varP x : lasts - pats = [tupP vars] - body = varE x - lamE pats body - --------------------------------------------------------------------------------- - --- | i: initial type, f: final type, s: sum element, p: product element -mkSop - :: (i -> [s]) - -> (s -> [p]) - -> (p -> f) - -> f - -> (f -> f -> f) - -> (f -> f -> f) - -> (s -> f -> f) - -> i - -> f -mkSop toSumList toProdList inject unit mkSum mkProd wrapProd = - listCase3 (error "zero") id more . map toProd . toSumList - where - more = foldNested mkSum - toProd x = wrapProd x . productize unit inject mkProd $ toProdList x - -mkSopDT - :: (Type -> f) - -> f - -> (f -> f -> f) - -> (f -> f -> f) - -> (NCon -> f -> f) - -> DT - -> f -mkSopDT = mkSop ncons cargtypes - -foldNested :: (a -> a -> a) -> a -> [a] -> a -foldNested f = go - where - go b [] = b - go b (x:xs) = f b (go x xs) - --- | Apply a function to each of 3 cases of a list: 0, 1, or > 1 elements -listCase3 :: b -> (a -> b) -> (a -> [a] -> b) -> [a] -> b -listCase3 zero one more ls = - case ls of - [] -> zero -- 0 elements - [x] -> one x -- 1 element - x:xs -> more x xs -- > 1 element - --- | Given a unit value, an injection function, and a product operator, create a --- product form out of a list. -productize :: b -> (a -> b) -> (b -> b -> b) -> [a] -> b -productize unit inj prod = go - where - go = listCase3 unit inj more - more x xs = prod (inj x) (go xs) - --------------------------------------------------------------------------------- - --- | Given a prefix string, a possible string for the type name, a name, and a --- suffix string, create a function that appends either the type string name (if --- it exists) or the base of the type name to the prefix. -mkFunName :: String -> Maybe String -> Name -> String -> Name -mkFunName prefix maybeMiddle name suffix = result - where - middle = fromMaybe (nameBase name) maybeMiddle - result = mkName $ showString prefix . showString middle $ suffix - --- | Report an error message and fail -reportError :: String -> Q a -reportError msg = report True msg >> fail "" - --------------------------------------------------------------------------------- - --- | Case the representation on the kind of the type. -caseKind :: RepOpt -> a -> a -> a -> a -caseKind opt k0 k1 k2 = - case opt of - OptRep -> k0 - OptFRep -> k1 - OptFRep2 -> k1 - OptFRep3 -> k1 - OptBiFRep2 -> k2 - --- | Case the representation on the 'Generic' class it relies on. -caseGen :: RepOpt -> a -> a -> a -> a -caseGen opt g g2 g3 = - case opt of - OptRep -> g - OptFRep -> g - OptFRep2 -> g2 - OptFRep3 -> g3 - OptBiFRep2 -> g2 - --- | Case the 'Rep' option or the others. -caseRep :: RepOpt -> a -> a -> a -caseRep opt r o = - case opt of - OptRep -> r - _ -> o - --- | Get the collection of names for a certain option. This allows the code to --- be generic across different instance definitions. For example, we use the --- same code to write the instances of 'Rep' as we do for 'BiFRep2'. Some of the --- differences are these names. -repNames :: RepOpt -> RepNames -repNames OptRep = RepNames ''Generic 'rep 'rep 'rep 'rep 'rep 'runit 'rsum 'rprod 'rcon 'rtype ''Rep 'rep -repNames OptFRep = RepNames ''Generic 'rint 'rinteger 'rfloat 'rdouble 'rchar 'runit 'rsum 'rprod 'rcon 'rtype ''FRep 'frep -repNames OptFRep2 = RepNames ''Generic2 'rint2 'rinteger2 'rfloat2 'rdouble2 'rchar2 'runit2 'rsum2 'rprod2 'rcon2 'rtype2 ''FRep2 'frep2 -repNames OptFRep3 = RepNames ''Generic3 'rint3 'rinteger3 'rfloat3 'rdouble3 'rchar3 'runit3 'rsum3 'rprod3 'rcon3 'rtype3 ''FRep3 'frep3 -repNames OptBiFRep2 = RepNames ''Generic2 'rint2 'rinteger2 'rfloat2 'rdouble2 'rchar2 'runit2 'rsum2 'rprod2 'rcon2 'rtype2 ''BiFRep2 'bifrep2 - -funName :: RepOpt -> RepFunNames -> Name -funName OptRep = repFunN -funName OptFRep = frepFunN -funName OptFRep2 = frep2FunN -funName OptFRep3 = frep3FunN -funName OptBiFRep2 = bifrep2FunN - --- | Get the actual name that is analogous to each of these function names. This --- allows the code to be generic across different instance definitions. -genericCN, rintN, rintegerN, rfloatN, rdoubleN, rcharN, runitN, rsumN, rprodN, rconN, rtypeN, repCN, repN :: RepOpt -> Name -genericCN = genericCN' . repNames -rintN = rintN' . repNames -rintegerN = rintegerN' . repNames -rfloatN = rfloatN' . repNames -rdoubleN = rdoubleN' . repNames -rcharN = rcharN' . repNames -runitN = runitN' . repNames -rsumN = rsumN' . repNames -rprodN = rprodN' . repNames -rconN = rconN' . repNames -rtypeN = rtypeN' . repNames -repCN = repCN' . repNames -repN = repN' . repNames - --------------------------------------------------------------------------------- - --- | Make a type as applied to its type variables from the type name and list of --- parameters. -mkAppliedType' :: Name -> [Name] -> Q Type -mkAppliedType' typ vars = - foldl appT (conT typ) (map varT vars) - --- | Make a type as applied to its type variables (if any) from a DT -mkAppliedType :: RepOpt -> DT -> Q Type -mkAppliedType opt dt = - appTypeCon varTypes - where - varTypes = map varT (tvars dt) - appTypeCon = foldl appT (conT (tname dt)) . dropLast arity - len = length varTypes - dropLast n xs = if len > n then take (len - n) xs else [] - arity = caseKind opt 0 1 2 - -mkAppliedFun :: Name -> [Name] -> Q Exp -mkAppliedFun fun vars = - foldl appE (varE fun) (map varE vars) - --------------------------------------------------------------------------------- - -mkRepT :: RepOpt -> Q Type -> Q Type -> Q Type -mkRepT opt funType = appT (appT (conT (repCN opt)) funType) - -mkGenericT :: RepOpt -> Q Type -> Q Type -mkGenericT opt = appT (conT (genericCN opt)) - --- | Make the rep instance context -mkRepInstCxt :: RepOpt -> Q Type -> DT -> Q Cxt -mkRepInstCxt opt funType dt = do - - -- Build a list of the 'Rep' class constraints - repConstraints <- - case opt of - OptRep -> do - -- List of types from all the fields of the all the constructors - let fieldTypes = concatMap cargtypes (ncons dt) - fieldConstraints <- mapM (mkRepT opt funType . return) fieldTypes - -- List of type variables - varConstraints <- mapM (mkRepT opt funType . varT) (tvars dt) - -- Final list of 'Rep' constraints with duplicates removed - return $ nub (varConstraints ++ fieldConstraints) - _ -> - return [] - - -- Build the 'Generic' class constraint - genConstraint <- mkGenericT opt funType - - -- Combine the 'Generic' and 'Rep' constraints - return (genConstraint : repConstraints) - --- | Make the rep instance type -mkRepInstT :: RepOpt -> DT -> Q Type -> Q Type -mkRepInstT opt dt funType = mkRepT opt funType (mkAppliedType opt dt) - --------------------------------------------------------------------------------- - -unitE :: Exp -unitE = ConE 'Unit - -prodE :: Exp -> Exp -> Exp -prodE a b = (InfixE (Just a) (ConE '(:*:)) (Just b)) - -sumE :: Name -> Exp -> Exp -sumE name x = AppE (ConE name) x - -unitP :: Pat -unitP = ConP 'Unit [] - -prodP :: Pat -> Pat -> Pat -prodP a b = (InfixP a '(:*:) b) - -sumP :: Name -> Pat -> Pat -sumP name x = ConP name [x] - -dataE :: (Exp -> Exp) -> NCon -> Exp -dataE f (NCon name _ _ vars) = - foldl (\e -> AppE e . f . VarE) (ConE name) vars - -dataP :: NCon -> Pat -dataP (NCon name _ _ vars) = ConP name (map VarP vars) - diff --git a/src/Generics/EMGM/Derive/ConDescr.hs b/src/Generics/EMGM/Derive/ConDescr.hs deleted file mode 100644 --- a/src/Generics/EMGM/Derive/ConDescr.hs +++ /dev/null @@ -1,113 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskell #-} - ------------------------------------------------------------------------------ --- | --- Module : Generics.EMGM.Derive.ConDescr --- Copyright : (c) 2008, 2009 Universiteit Utrecht --- License : BSD3 --- --- Maintainer : generics@haskell.org --- Stability : experimental --- Portability : non-portable --- --- Summary: Code for generating a value of 'ConDescr' in TH. ------------------------------------------------------------------------------ - -module Generics.EMGM.Derive.ConDescr ( -#ifndef __HADDOCK__ - mkConDescr, -#endif -) where - -#ifndef __HADDOCK__ - ------------------------------------------------------------------------------ --- Imports ------------------------------------------------------------------------------ - -import Language.Haskell.TH - -import qualified Generics.EMGM.Common.Representation as ER -- EMGM Rep -import Generics.EMGM.Derive.Common - ------------------------------------------------------------------------------ --- General functions ------------------------------------------------------------------------------ - -conFixity :: Name -> Q Fixity -conFixity name = - do info <- reify name - case info of - DataConI _ _ _ fixity -> - return fixity - _ -> - reportError $ showString "Unexpected name \"" - . showString (nameBase name) - $ "\" when looking for an infix data constructor." - - --- | Build an expression for a value of EMGM's Fixity type -fixityE :: Maybe Fixity -> Exp -fixityE Nothing = ConE 'ER.Nonfix -fixityE (Just (Fixity p d)) = - case d of - InfixL -> mkE 'ER.Infixl - InfixR -> mkE 'ER.Infixr - InfixN -> mkE 'ER.Infix - where - mkE :: Name -> Exp - mkE name = AppE (ConE name) (LitE (IntegerL $ fromIntegral p)) - --- | Build a 'ConDescr' expression -mkConDescrE :: String -> Int -> [String] -> Maybe Fixity -> Exp -mkConDescrE name arity labels fixity = - foldl AppE (ConE 'ER.ConDescr) - [ LitE (StringL name) - , LitE (IntegerL $ fromIntegral arity) - , ListE $ map (LitE . StringL) labels - , fixityE fixity ] - --- | Make a 'ConDescr' expression and return a pair of the stringified --- constructor name and AST expression value. -conDescrE :: Con -> Q (String,Exp) -conDescrE c = - case c of - NormalC name args -> - do let nb = nameBase name - return (nb, mkConDescrE nb (length args) [] Nothing) - RecC name args -> - do let nb = nameBase name - labels = map (nameBase . $(sel 0 3)) args - return (nb, mkConDescrE nb (length args) labels Nothing) - InfixC _ name _ -> - do let nb = nameBase name - fixity <- conFixity name - return (nb, mkConDescrE nb 2 [] (Just fixity)) - other -> - -- Should never reach - reportError $ "conDescrE: Unsupported constructor: '" ++ show other ++ "'" - -cdDecs :: Name -> Exp -> [Dec] -cdDecs n e = [SigD n (ConT ''ER.ConDescr), ValD (VarP n) (NormalB e) []] - --- | Make a 'ConDescr' declaration and return a pair of the declaration name --- and AST value. -mkConDescr :: Maybe Modifier -> Con -> Q (Name, Maybe [Dec]) -mkConDescr maybeCdName c = - do (cstr, e) <- conDescrE c - let mkPair s isDeclared = - let name = mkName ("con" ++ s) - dec = if isDeclared then Just (cdDecs name e) else Nothing - in (name, dec) - let pair = - case maybeCdName of - Nothing -> mkPair cstr True - Just m -> - case m of - DefinedAs s -> mkPair s False - ChangeTo s -> mkPair s True - return pair - -#endif - diff --git a/src/Generics/EMGM/Derive/EP.hs b/src/Generics/EMGM/Derive/EP.hs deleted file mode 100644 --- a/src/Generics/EMGM/Derive/EP.hs +++ /dev/null @@ -1,125 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskell #-} - ------------------------------------------------------------------------------ --- | --- Module : Generics.EMGM.Derive.EP --- Copyright : (c) 2008, 2009 Universiteit Utrecht --- License : BSD3 --- --- Maintainer : generics@haskell.org --- Stability : experimental --- Portability : non-portable --- --- Summary: Code for generating the 'EP' value in TH. ------------------------------------------------------------------------------ - -module Generics.EMGM.Derive.EP ( -#ifndef __HADDOCK__ - mkEP, -#endif -) where - -#ifndef __HADDOCK__ - ------------------------------------------------------------------------------ --- Imports ------------------------------------------------------------------------------ - -import Language.Haskell.TH - --- TODO: List imports - -import Generics.EMGM.Common.Representation -import Generics.EMGM.Derive.Common - ------------------------------------------------------------------------------ --- General functions ------------------------------------------------------------------------------ - --- | Apply an inductive function @fn@ recursively @n@ times. Then, apply a base --- function @fz@. Restriction: @n >= 0@. -appN :: (a -> b) -> (b -> b) -> Int -> a -> b -appN fz _ 0 x = fz x -appN fz fn n x = fn (appN fz fn (n - 1) x) - --------------------------------------------------------------------------------- - --- | Create a product representation from a single constructor -conProd :: a -> (a -> a -> a) -> (Name -> a) -> NCon -> a -conProd unit prod var = namesRep . cvars - where - namesRep = productize unit id prod . map var - --- | Change a list of product representations to a list of sums of products. --- For example, the list of reps A, B, and C becomes L A, R (L B), and R (R C). -repsSums :: (Name -> a -> a) -> [a] -> [a] -repsSums mkSum = listCase3 [] (:[]) more - where - inL = mkSum 'L - inR = mkSum 'R - - -- Apply inR and inL the appropriate number of times to inject the product - -- rep into the correct sum rep value. - more x xs = inL x : appLR 1 xs - - appLR n (y:[]) = [appN inR inR (n - 1) y] - appLR n (y:ys) = appN inL inR n y : appLR (n + 1) ys - appLR _ _ = error "repsSums: Should not be here!" - --- | Translate constructors to syntax elements for sum-of-product representation -consReps :: a -> (a -> a -> a) -> (Name -> a) -> (Name -> a -> a) -> [NCon] -> [a] -consReps unit prod var sum_ = repsSums sum_ . prods - where - prods = map (conProd unit prod var) - --------------------------------------------------------------------------------- - --- | Create a list of clauses from a list of constructors -consClauses :: (a -> [Pat]) -> (a -> [Exp]) -> a -> [Clause] -consClauses mkPats mkExps cons = zipWith mkClause (mkPats cons) (mkExps cons) - where - mkClause p e = Clause [p] (NormalB e) [] - --- | Given the constructors of a datatype, create a pair of the direction and --- the clause for each component of the embedding-projection pair. -fromClauses, toClauses :: [NCon] -> [Clause] -fromClauses = consClauses (map dataP) (consReps unitE prodE VarE sumE) -toClauses = consClauses (consReps unitP prodP VarP sumP) (map (dataE id)) - --- | Given a function that translates constructors to clause (plus direction), a --- possible type string name, and a type name, make a function declaration. -mkFunD :: ([NCon] -> [Clause]) -> DT -> Name -> Dec -mkFunD mkClauses dt funNm = FunD funNm (mkClauses (ncons dt)) - --------------------------------------------------------------------------------- - -mkEpSig :: DT -> Name -> Dec -mkEpSig dt ep = SigD ep typ - where - vars = tvars dt - typ = ForallT vars [] (AppT (AppT (ConT ''EP) rtyp) styp) - rtyp = foldl AppT (ConT (tname dt)) . map VarT $ vars - mkSum = AppT . AppT (ConT ''(:+:)) - mkProd = AppT . AppT (ConT ''(:*:)) - unit = ConT ''Unit - styp = mkSopDT id unit mkSum mkProd (flip const) dt - --------------------------------------------------------------------------------- - --- | Given a possible type string name and a type name, declare the --- embedding-projection pair for a datatype. -mkEP :: Modifiers -> DT -> Name -> Name -> (Name, [Dec]) -mkEP mods dt fromName toName = (epName, [epSig, epDec]) - where - typeName = tname dt - maybeTypeStr = toMaybeString $ lookup (nameBase typeName) mods - epName = mkFunName "ep" maybeTypeStr typeName "" - fromDec = mkFunD fromClauses dt fromName - toDec = mkFunD toClauses dt toName - body = AppE (AppE (ConE 'EP) (VarE fromName)) (VarE toName) - epSig = mkEpSig dt epName - epDec = ValD (VarP epName) (NormalB body) [fromDec, toDec] - -#endif - diff --git a/src/Generics/EMGM/Derive/Functions.hs b/src/Generics/EMGM/Derive/Functions.hs deleted file mode 100644 --- a/src/Generics/EMGM/Derive/Functions.hs +++ /dev/null @@ -1,92 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskell #-} - ------------------------------------------------------------------------------ --- | --- Module : Generics.EMGM.Derive.Functions --- Copyright : (c) 2008, 2009 Universiteit Utrecht --- License : BSD3 --- --- Maintainer : generics@haskell.org --- Stability : experimental --- Portability : non-portable --- --- Summary: Code for generating function-specific instances in TH. ------------------------------------------------------------------------------ - -module Generics.EMGM.Derive.Functions ( -#ifndef __HADDOCK__ - mkRepCollectInst, - mkRepEverywhereInst, - mkRepEverywhereInst', -#endif -) where - -#ifndef __HADDOCK__ - ------------------------------------------------------------------------------ --- Imports ------------------------------------------------------------------------------ - -import Language.Haskell.TH - -import Generics.EMGM.Common.Base -import Generics.EMGM.Derive.Common - -import Generics.EMGM.Functions.Collect -import Generics.EMGM.Functions.Everywhere - --------------------------------------------------------------------------------- - --- | Make the instance for a function-specific Rep instance -mkRepFunctionInst :: DT -> Name -> Q Cxt -> Q Exp -> Q Dec -mkRepFunctionInst dt newtypeName ctx bodyExp = do - let t = mkAppliedType OptRep dt - let typ = mkRepInstT OptRep dt (appT (conT newtypeName) t) - let dec = valD (varP 'rep) (normalB bodyExp) [] - instanceD ctx typ [dec] - --------------------------------------------------------------------------------- - --- | Make the instance for a Rep Collect T (where T is the type) -mkRepCollectInst :: DT -> Q Dec -mkRepCollectInst dt = do - mkRepFunctionInst dt ''Collect (return []) [|Collect (\x -> [x])|] - --------------------------------------------------------------------------------- - -mkEverywhereFunE :: DT -> Q Exp -mkEverywhereFunE dt = lamE [fpat, xpat] caseExp - where - f = mkName "f" - x = mkName "x" - xpat = varP x - fpat = varP f - appSel = AppE (AppE (AppE (VarE 'selEverywhere) (VarE 'rep)) (VarE f)) - appF = appE (varE f) - caseExp = caseE (varE x) matches - matches = zipWith mkMatch pats exps - mkMatch p e = match (return p) (normalB (appF (return e))) [] - ncs = ncons dt - pats = map dataP ncs - exps = map (dataE appSel) ncs - --- | Make the instance for a Rep Everywhere T (where T is the type) -mkRepEverywhereInst :: DT -> Q Dec -mkRepEverywhereInst dt = do - let dtyp = mkAppliedType OptRep dt - let typ = appT (conT ''Everywhere) dtyp - let bodyExp = appE (conE 'Everywhere) (mkEverywhereFunE dt) - repCtx <- mkRepInstCxt OptRep typ dt - let ctx = return (tail repCtx) - mkRepFunctionInst dt ''Everywhere ctx bodyExp - --------------------------------------------------------------------------------- - --- | Make the instance for a Rep Everywhere' T (where T is the type) -mkRepEverywhereInst' :: DT -> Q Dec -mkRepEverywhereInst' dt = - mkRepFunctionInst dt ''Everywhere' (return []) [|Everywhere' (\f x -> f x)|] - -#endif - diff --git a/src/Generics/EMGM/Derive/Instance.hs b/src/Generics/EMGM/Derive/Instance.hs deleted file mode 100644 --- a/src/Generics/EMGM/Derive/Instance.hs +++ /dev/null @@ -1,266 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} - ------------------------------------------------------------------------------ --- | --- Module : Generics.EMGM.Derive --- Copyright : (c) 2008, 2009 Universiteit Utrecht --- License : BSD3 --- --- Maintainer : generics@haskell.org --- Stability : experimental --- Portability : non-portable --- --- Summary: Code for generating the representation dispatcher class instances in --- TH. ------------------------------------------------------------------------------ - -module Generics.EMGM.Derive.Instance ( -#ifndef __HADDOCK__ - RepOpt(..), - RepFunNames(..), - mkRepFun, - mkRepInst, -#endif -) where - -#ifndef __HADDOCK__ - ------------------------------------------------------------------------------ --- Imports ------------------------------------------------------------------------------ - -import Data.List (transpose) - -import Language.Haskell.TH - -import Generics.EMGM.Derive.Common - ------------------------------------------------------------------------------ --- Types ------------------------------------------------------------------------------ - ------------------------------------------------------------------------------ --- General functions ------------------------------------------------------------------------------ - -repStr :: RepOpt -> String -repStr OptRep = "rep" -repStr OptFRep = "frep" -repStr OptFRep2 = "frep2" -repStr OptFRep3 = "frep3" -repStr OptBiFRep2 = "bifrep2" - --- | Handle the renaming of the functions for the built-in symbol types. -symbolMods :: Modifiers -symbolMods = - [ ("[]",ChangeTo "List") - , ("()",ChangeTo "Tuple0") - , ("(,)",ChangeTo "Tuple2") - , ("(,,)",ChangeTo "Tuple3") - , ("(,,,)",ChangeTo "Tuple4") - , ("(,,,,)",ChangeTo "Tuple5") - , ("(,,,,,)",ChangeTo "Tuple6") - , ("(,,,,,,)",ChangeTo "Tuple7") - ] - -toFunName :: Modifiers -> RepOpt -> Name -> Name -toFunName mods opt nm = - mkName (repStr opt ++ result) - where - str = nameBase nm - result = - case toMaybeString (lookup str (mods ++ symbolMods)) of - Nothing -> str - Just newStr -> newStr - -primRepName :: Name -> RepOpt -> Maybe Name -primRepName typ opt = - case nameBase typ of - "Int" -> Just (rintN opt) - "Integer" -> Just (rintegerN opt) - "Float" -> Just (rfloatN opt) - "Double" -> Just (rdoubleN opt) - "Char" -> Just (rcharN opt) - _ -> Nothing - -typSyn :: Name -> Q (Maybe Type) -typSyn typ = do - info <- reify typ - case info of - TyConI dec -> - case dec of - TySynD _ _ unSynTyp -> - return (Just unSynTyp) - _ -> - return Nothing - _ -> - return Nothing - -typeUnknownError :: Int -> RepOpt -> Type -> Q a -typeUnknownError i opt t = do - error $ "Error #" ++ show i ++ ": Unsupported type for " ++ show opt ++ ": " ++ show t - --- | Produce the variable expression for the appropriate 'rep', 'frep', etc. -varRepExp :: Modifiers -> RepOpt -> DT -> Type -> Q Exp -varRepExp mods opt dt = - caseRep opt (varE (repN opt)) . go - where - typE nm = varE (toFunName mods opt nm) - - appFun t = foldl appE (typE t) . map go - - go t = - case t of - - VarT v -> - if v `elem` tvars dt then varE v else typeUnknownError 34 opt t - - ConT typ -> - case primRepName typ opt of - Just nm -> - varE nm - Nothing -> do - mts <- typSyn typ - case mts of - Just ts -> go ts - Nothing -> varE (toFunName mods opt typ) - - AppT (ConT typ) a -> - appFun typ [a] - - AppT (AppT (ConT typ) a1) a2 -> - appFun typ [a1,a2] - - AppT (AppT (AppT (ConT typ) a1) a2) a3 -> - appFun typ [a1,a2,a3] - - AppT (AppT (AppT (AppT (ConT typ) a1) a2) a3) a4 -> - appFun typ [a1,a2,a3,a4] - - AppT (AppT (AppT (AppT (AppT (ConT typ) a1) a2) a3) a4) a5 -> - appFun typ [a1,a2,a3,a4,a5] - - AppT (AppT (AppT (AppT (AppT (AppT (ConT typ) a1) a2) a3) a4) a5) a6 -> - appFun typ [a1,a2,a3,a4,a5,a6] - - AppT (AppT (AppT (AppT (AppT (AppT (AppT (ConT typ) a1) a2) a3) a4) a5) a6) a7 -> - appFun typ [a1,a2,a3,a4,a5,a6,a7] - - _ -> - typeUnknownError 50 opt t - --- | Construct the expression for the appropriate 'rtype', 'rtype2', etc. -rtypeE :: RepOpt -> Name -> Q Exp -> Q Exp -rtypeE opt epName sopE = - caseGen opt (appToSop ep1) (appToSop ep2) (appToSop ep3) - where - appToEp e = appE e (varE epName) - appToSop eps = appE eps sopE - ep1 = appToEp (varE (rtypeN opt)) - ep2 = appToEp ep1 - ep3 = appToEp ep2 - --------------------------------------------------------------------------------- - --- | Construct the sum-of-product expression for the appropriate 'rep', 'frep', --- 'frep2', etc. -repSopE :: Modifiers -> RepOpt -> DT -> Q Exp -repSopE mods opt dt = - mkSopDT inject unit mkSum mkProd wrapProd dt - where - inject = varRepExp mods opt dt - mkSum = appE . appE (varE (rsumN opt)) - mkProd = appE . appE (varE (rprodN opt)) - unit = varE (runitN opt) - wrapProd ncon = appE (appE (varE (rconN opt)) (varE (cdescr ncon))) - --- | The number of generic type variables in the representation. -genTypeVars :: RepOpt -> Int -genTypeVars opt = caseGen opt 1 2 3 - --- | Make the signature return type given a @g@ type variable, a type name, and --- a list of list of parameters. The list of parameters is arranged in the order --- for the function arguments, so it must be transposed. -mkSigReturnT :: RepOpt -> Q Type -> Name -> [[Name]] -> Q Type -mkSigReturnT opt gvar typ = - foldl appT gvar . map (mkAppliedType' typ) . fillNil . transpose - where - fillNil [] = replicate (genTypeVars opt) [] - fillNil xs = xs - --- | Make the representation function signature. -mkRepFunSigT :: RepOpt -> DT -> Q Type -mkRepFunSigT opt dt = do - -- The Generic class parameter - let gname = mkName "g" - let gvar = varT gname - - -- Build a list of lists of type variable names. Each sublist is the set of - -- parameters to each 'g' type in the function arguments. For 'rep', we keep - -- the original type variable list, because it's also used in the context. - let mkVarNameList _ c = map (\i -> mkName (c:show i)) [1..genTypeVars opt] - let varNameLists = - caseRep opt - (map (:[]) (tvars dt)) - (zipWith mkVarNameList (tvars dt) ['a'..]) - - -- Type variables for this function signature - let vars = gname : concat varNameLists - - -- Build a list of argument types using the variable name list of lists from - -- above. - let mkArrArgs as = appT arrowT (foldl appT gvar (map varT as)) - let args = caseRep opt [] (map mkArrArgs varNameLists) - - -- The return type - let retTyp = mkSigReturnT opt gvar (tname dt) varNameLists - - -- Combine the return type with the argument types to get the final signature. - let typ = foldr appT retTyp args - - -- Context with class constraints - let ctx = mkRepInstCxt opt gvar dt - - -- Done! - forallT vars ctx typ - --- | Make the representation functions, e.g. 'repMaybe', 'frepMaybe', --- 'frep2Maybe', 'frep3Maybe', and 'bifrep2Maybe' -mkRepFun :: Modifiers -> RepOpt -> DT -> Name -> Q (Name, [Dec]) -mkRepFun mods opt dt ep = do - - -- Name of function - let nm = toFunName mods opt (tname dt) - - -- Signature of function - sig <- sigD nm (mkRepFunSigT opt dt) - - -- Value of function - let bodyExp = rtypeE opt ep (repSopE mods opt dt) - let args = caseRep opt [] (map varP (tvars dt)) - fun <- funD nm [clause args (normalB bodyExp) []] - - return (nm, [sig, fun]) - --return (nm, []) - ------------------------------------------------------------------------------ --- Exported Functions ------------------------------------------------------------------------------ - --- | Make the instance for a representation type class -mkRepInst :: RepOpt -> RepFunNames -> Name -> DT -> Q [Dec] -mkRepInst opt funs g dt = do - let body = varE (funName opt funs) - let dec = valD (varP (repN opt)) (normalB body) [] - let gvar = varT g - let ctx = mkRepInstCxt opt gvar dt - let typ = mkRepInstT opt dt gvar - inst <- instanceD ctx typ [dec] - return [inst] - -#endif - diff --git a/src/Generics/EMGM/Derive/Internal.hs b/src/Generics/EMGM/Derive/Internal.hs deleted file mode 100644 --- a/src/Generics/EMGM/Derive/Internal.hs +++ /dev/null @@ -1,692 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskell #-} - ------------------------------------------------------------------------------ --- | --- Module : Generics.EMGM.Derive.Internal --- Copyright : (c) 2008, 2009 Universiteit Utrecht --- License : BSD3 --- --- Maintainer : generics@haskell.org --- Stability : experimental --- Portability : non-portable --- --- Summary: Internal module with implementation of deriving code. Other EMGM --- modules should import this instead of the higher-level Derive modules. ------------------------------------------------------------------------------ - -module Generics.EMGM.Derive.Internal ( - - derive, - deriveWith, - Modifier(..), - Modifiers, - - deriveMany, - deriveManyWith, - - deriveMono, - deriveMonoWith, - - declareConDescrs, - declareConDescrsWith, - - declareEP, - declareEPWith, - - declareRepValues, - declareRepValuesWith, - - declareMonoRep, - declareMonoRepWith, - - deriveRep, - deriveRepWith, - - deriveFRep, - deriveFRepWith, - - deriveBiFRep, - deriveBiFRepWith, - - deriveCollect, - deriveEverywhere, - deriveEverywhere', - - module Generics.EMGM.Common, - module Generics.EMGM.Functions.Collect, - module Generics.EMGM.Functions.Everywhere, - -) where - ------------------------------------------------------------------------------ --- Imports ------------------------------------------------------------------------------ - -import Prelude - -import Language.Haskell.TH -import Data.Maybe (catMaybes) - -import Generics.EMGM.Derive.Common -import Generics.EMGM.Derive.Functions - --- We ignore these imports for Haddock, because Haddock does not like Template --- Haskell expressions in many places. --- --- See http://code.google.com/p/emgm/issues/detail?id=21 --- -#ifndef __HADDOCK__ -import Generics.EMGM.Derive.ConDescr (mkConDescr) -import Generics.EMGM.Derive.EP (mkEP) -import Generics.EMGM.Derive.Instance -#endif - -import Generics.EMGM.Common - -import Generics.EMGM.Functions.Collect -import Generics.EMGM.Functions.Everywhere - ------------------------------------------------------------------------------ --- General functions ------------------------------------------------------------------------------ - -#ifndef __HADDOCK__ - --- | Make the DT and constructor descriptions -declareConDescrsBase :: Modifiers -> Name -> Q (DT, [Dec]) -declareConDescrsBase mods typeName = do - info <- reify typeName - case info of - TyConI d -> - case d of - DataD _ name vars cons _ -> mkDT name vars cons - NewtypeD _ name vars con _ -> mkDT name vars [con] - _ -> err - _ -> err - where - mkDT name vars cons = - do pairs <- mapM (normalizeCon mods) cons - let (ncons', cdDecs) = unzip pairs - return (DT name vars cons ncons', concat . catMaybes $ cdDecs) - err = reportError $ showString "Unsupported name \"" - . shows typeName - $ "\". Must be data or newtype." - --- | Normalize constructor variants -normalizeCon :: Modifiers -> Con -> Q (NCon, Maybe [Dec]) -normalizeCon mods c = - case c of - NormalC name args -> mkNCon name (map snd args) - RecC name args -> mkNCon name (map $(sel 2 3) args) - InfixC argL name argR -> mkNCon name [snd argL, snd argR] - ForallC _ _ con -> - -- It appears that this ForallC may never be reached, because non-Haskell-98 - -- constructors can't be reified according to an error received when trying. - do (NCon name _ _ _, _) <- normalizeCon mods con - reportError $ showString "Existential data constructors such as \"" - . showString (nameBase name) - $ "\" are not supported." - where - mkNCon name args = - do let maybeCdMod = lookup (nameBase name) mods - (cdName, cdDecs) <- mkConDescr maybeCdMod c - let names = newVarNames args - return (NCon name cdName args names, cdDecs) - --- | For each element in a list, make a new variable name using the character --- 'v' (arbitrary) and a number. -newVarNames :: [a] -> [Name] -newVarNames = map newVarName . zipWith const [1..] - where - newVarName :: Int -> Name - newVarName = mkName . (:) 'v' . show - --------------------------------------------------------------------------------- - -declareEPBase :: Modifiers -> DT -> Q (Name, [Dec]) -declareEPBase mods dt = do - fromName <- newName "from" - toName <- newName "to" - return (mkEP mods dt fromName toName) - -declareRepFunsBase :: Modifiers -> DT -> Name -> Q (RepFunNames, [Dec]) -declareRepFunsBase mods dt ep = do - (repFunName, repFunDecs) <- mkRepFun mods OptRep dt ep - (frepFunName, frepFunDecs) <- mkRepFun mods OptFRep dt ep - (frep2FunName, frep2FunDecs) <- mkRepFun mods OptFRep2 dt ep - (frep3FunName, frep3FunDecs) <- mkRepFun mods OptFRep3 dt ep - (bifrep2FunName, bifrep2FunDecs) <- mkRepFun mods OptBiFRep2 dt ep - return - ( RepFunNames repFunName frepFunName frep2FunName frep3FunName bifrep2FunName - , repFunDecs ++ frepFunDecs ++ frep2FunDecs ++ frep3FunDecs ++ bifrep2FunDecs - ) - -deriveRepBase :: DT -> RepFunNames -> Name -> Q [Dec] -deriveRepBase dt funs g = - mkRepInst OptRep funs g dt - -deriveFRepBase :: DT -> RepFunNames -> Name -> Q [Dec] -deriveFRepBase dt funs g = do - frepInstDec <- mkRepInst OptFRep funs g dt - frep2InstDec <- mkRepInst OptFRep2 funs g dt - frep3InstDec <- mkRepInst OptFRep3 funs g dt - return (frepInstDec ++ frep2InstDec ++ frep3InstDec) - -deriveBiFRepBase :: DT -> RepFunNames -> Name -> Q [Dec] -deriveBiFRepBase dt funs g = - mkRepInst OptBiFRep2 funs g dt - -#endif - ------------------------------------------------------------------------------ --- Exported functions ------------------------------------------------------------------------------ - --- | Same as 'derive' except that you can pass a list of name modifications to --- the deriving mechanism. --- --- Use @deriveWith@ if: --- --- (1) You want to use the generated constructor descriptions or --- embedding-projection pairs /and/ one of your constructors or types is an --- infix symbol. In other words, if you have a constructor @:*@, you cannot --- refer to the (invalid) generated name for its description, @con:*@. It --- appears that GHC has no problem with that name internally, so this is only --- if you want access to it. --- --- (2) You want to define your own constructor description. This allows you to --- give a precise implementation different from the one generated for you. --- --- For option 1, use 'ChangeTo' as in this example: --- --- @ --- data U = Int :* Char --- $(deriveWith [(\":*\", ChangeTo \"Star\")] ''U) --- x = ... conStar ... --- @ --- --- For option 2, use 'DefinedAs' as in this example: --- --- @ --- data V = (:=) { i :: Int, j :: Char } --- $(deriveWith [(\":=\", DefinedAs \"Equals\")] ''V) --- conEquals = 'ConDescr' \":=\" 2 [] ('Infix' 4) --- @ --- --- Using the example for option 2 with "Generics.EMGM.Functions.Show" will print --- values of @V@ as infix instead of the default record syntax. --- --- Note that only the first pair with its first field matching the type or --- constructor name in the 'Modifiers' list will be used. Any other matches will --- be ignored. -deriveWith :: Modifiers -> Name -> Q [Dec] - -#ifndef __HADDOCK__ - -deriveWith mods typeName = do - (dt, conDescrDecs) <- declareConDescrsBase mods typeName - (epName, epDecs) <- declareEPBase mods dt - (funNames, funDecs) <- declareRepFunsBase mods dt epName - - g <- newName "g" - repInstDecs <- deriveRepBase dt funNames g - - higherOrderRepInstDecs <- - case length (tvars dt) of - 1 -> deriveFRepBase dt funNames g - 2 -> deriveBiFRepBase dt funNames g - _ -> return [] - - collectInstDec <- mkRepCollectInst dt - everywhereInstDec <- mkRepEverywhereInst dt - everywhereInstDec' <- mkRepEverywhereInst' dt - - return $ - conDescrDecs ++ - epDecs ++ - funDecs ++ - repInstDecs ++ - higherOrderRepInstDecs ++ - [collectInstDec - ,everywhereInstDec - ,everywhereInstDec' - ] - -#else - -deriveWith = undefined - -#endif - --- | Derive all appropriate instances for using EMGM with a datatype. --- --- Here is an example module that shows how to use @derive@: --- --- > {-# LANGUAGE TemplateHaskell #-} --- > {-# LANGUAGE MultiParamTypeClasses #-} --- > {-# LANGUAGE FlexibleContexts #-} --- > {-# LANGUAGE FlexibleInstances #-} --- > {-# LANGUAGE OverlappingInstances #-} --- > {-# LANGUAGE UndecidableInstances #-} --- --- @ --- module Example where --- import "Generics.EMGM.Derive" --- data T a = C a 'Int' --- @ --- --- @ --- $(derive ''T) --- @ --- --- The Template Haskell @derive@ declaration in the above example generates the --- following (annotated) code: --- --- @ --- -- (1) Constructor description declarations --- @ --- --- @ --- conC :: 'ConDescr' --- conC = 'ConDescr' \"C\" 2 [] 'Nonfix' --- @ --- --- @ --- -- (2) Embedding-projection pair declaration --- @ --- --- @ --- epT :: 'EP' (T a) (a :*: 'Int') --- epT = 'EP' fromT toT --- where fromT (C v1 v2) = v1 :*: v2 --- toT (v1 :*: v2) = C v1 v2 --- @ --- --- @ --- -- (3) Representation values --- @ --- --- @ --- repT :: ('Generic' g, 'Rep' g a, 'Rep' g 'Int') => g (T a) --- repT = 'rtype' epT ('rcon' conC ('rprod' 'rep' 'rep')) --- @ --- --- @ --- frepT :: ('Generic' g) => g a1 -> g (T a1) --- frepT a = 'rtype' epT ('rcon' conC ('rprod' a 'rint')) --- @ --- --- @ --- frep2T :: ('Generic2' g) => g a1 a2 -> g (T a1) (T a2) --- frep2T a = 'rtype2' epT epT ('rcon2' conC ('rprod2' a 'rint2')) --- @ --- --- @ --- frep3T :: ('Generic3' g) => g a1 a2 a3 -> g (T a1) (T a2) (T a3) --- frep3T a = 'rtype3' epT epT epT ('rcon3' conC ('rprod3' a 'rint3')) --- @ --- --- @ --- bifrep2T :: ('Generic2' g) => g a1 a2 -> g (T a1) (T a2) --- bifrep2T a = 'rtype2' epT epT ('rcon2' conC ('rprod2' a 'rint2')) --- @ --- --- @ --- -- (4) Representation instances --- @ --- --- @ --- instance ('Generic' g, 'Rep' g a, 'Rep' g 'Int') => 'Rep' g (T a) where --- 'rep' = repT --- @ --- --- @ --- instance ('Generic' g) => 'FRep' g T where --- 'frep' = frepT --- @ --- --- @ --- instance ('Generic2' g) => 'FRep2' g T where --- 'frep2' = frep2T --- @ --- --- @ --- instance ('Generic3' g) => 'FRep3' g T where --- 'frep3' = frep3T --- @ --- --- @ --- -- In this case, no instances for 'BiFRep2' is generated, because T is not --- -- a bifunctor type; however, the bifrep2T value is always generated in --- -- case T is used in a bifunctor type. --- @ --- --- @ --- -- (5) Generic function-specific instances --- @ --- --- @ --- instance 'Rep' ('Collect' (T a)) (T a) where --- 'rep' = 'Collect' (\\x -> [x]) --- @ --- --- @ --- instance ('Rep' ('Everywhere' (T a)) a, 'Rep' ('Everywhere' (T a)) 'Int') --- => 'Rep' ('Everywhere' (T a)) (T a) where --- 'rep' = 'Everywhere' (\\f x -> --- case x of --- C v1 v2 -> f (C ('selEverywhere' 'rep' f v1) ('selEverywhere' 'rep' f v2)) --- @ --- --- @ --- instance 'Rep' ('Everywhere'' (T a)) (T a) where --- 'rep' = 'Everywhere'' (\\f x -> f x) --- @ --- --- Note that all the values are top-level. This allows them to be shared between --- multiple instances. For example, if you have two mutually recursive functor --- datatypes, you may need to have each other's derived code in scope. - -derive :: Name -> Q [Dec] -derive = deriveWith [] - --------------------------------------------------------------------------------- - --- | Same as 'deriveWith' for a list of type names. It may be necessary to use --- @deriveMany@ for a collection of mutually recursive datatypes. -deriveManyWith :: Modifiers -> [Name] -> Q [Dec] -deriveManyWith mods names = do - decLists <- mapM (deriveWith mods) names - return (concat decLists) - --- | Same as 'derive' for a list of type names. It may be necessary to use --- @deriveMany@ for a collection of mutually recursive datatypes. -deriveMany :: [Name] -> Q [Dec] -deriveMany = deriveManyWith [] - --------------------------------------------------------------------------------- - --- | Same as 'declareConDescrs' except that you can pass a list of name --- modifications to the deriving mechanism. See 'deriveWith' for an example. -declareConDescrsWith :: Modifiers -> Name -> Q [Dec] - -#ifndef __HADDOCK__ - -declareConDescrsWith mods typeName = do - (_, conDescrDecs) <- declareConDescrsBase mods typeName - return conDescrDecs - -#else - -declareConDescrsWith = undefined - -#endif - --- | Generate declarations of 'ConDescr' values for all constructors in a type. --- See 'derive' for an example. -declareConDescrs :: Name -> Q [Dec] -declareConDescrs = declareConDescrsWith [] - --------------------------------------------------------------------------------- - --- | Same as 'declareEP' except that you can pass a list of name modifications --- to the deriving mechanism. See 'deriveWith' for an example. -declareEPWith :: Modifiers -> Name -> Q [Dec] - -#ifndef __HADDOCK__ - -declareEPWith mods typeName = do - (dt, _) <- declareConDescrsBase mods typeName - (_, epDecs) <- declareEPBase mods dt - return epDecs - -#else - -declareEPWith = undefined - -#endif - --- | Generate declarations of 'EP' values for a type. See 'derive' for an --- example. -declareEP :: Name -> Q [Dec] -declareEP = declareEPWith [] - --------------------------------------------------------------------------------- - --- | Same as 'declareMonoRep' except that you can pass a list of name --- modifications to the deriving mechanism. See 'deriveWith' for an example. -declareMonoRepWith :: Modifiers -> Name -> Q [Dec] - -#ifndef __HADDOCK__ - -declareMonoRepWith mods typeName = do - (dt, _) <- declareConDescrsBase mods typeName - (ep, _) <- declareEPBase mods dt - (_, repFunDecs) <- mkRepFun mods OptRep dt ep - return repFunDecs - -#else - -declareMonoRepWith = undefined - -#endif - --- | Generate the declaration of a monomorphic representation value for a type. --- This is the value used for 'rep' in an instance of 'Rep'. The difference with --- 'declareRepValues' is that 'declareRepValues' generates generates all --- representation values (including 'frep', 'frep2', etc.). See 'derive' for an --- example. -declareMonoRep :: Name -> Q [Dec] -declareMonoRep = declareMonoRepWith [] - --------------------------------------------------------------------------------- - --- | Same as 'declareRepValues' except that you can pass a list of name --- modifications to the deriving mechanism. See 'deriveWith' for an example. -declareRepValuesWith :: Modifiers -> Name -> Q [Dec] - -#ifndef __HADDOCK__ - -declareRepValuesWith mods typeName = do - (dt, _) <- declareConDescrsBase mods typeName - (ep, _) <- declareEPBase mods dt - (_, funDecs) <- declareRepFunsBase mods dt ep - return funDecs - -#else - -declareRepValuesWith = undefined - -#endif - --- | Generate declarations of all representation values for a type. These --- functions are used in 'rep', 'frep', ..., 'bifrep2'. -declareRepValues :: Name -> Q [Dec] -declareRepValues = declareRepValuesWith [] - --------------------------------------------------------------------------------- - --- | Same as 'deriveRep' except that you can pass a list of name modifications --- to the deriving mechanism. See 'deriveWith' for an example. -deriveRepWith :: Modifiers -> Name -> Q [Dec] - -#ifndef __HADDOCK__ - -deriveRepWith mods typeName = do - (dt, _) <- declareConDescrsBase mods typeName - (ep, _) <- declareEPBase mods dt - (funNames, _) <- declareRepFunsBase mods dt ep - g <- newName "g" - repInstDecs <- deriveRepBase dt funNames g - return repInstDecs - -#else - -deriveRepWith = undefined - -#endif - --- | Generate 'Rep' instance declarations for a type. See 'derive' for an --- example. -deriveRep :: Name -> Q [Dec] -deriveRep = deriveRepWith [] - --------------------------------------------------------------------------------- - --- | Same as 'deriveMono' except that you can pass a list of name --- modifications to the deriving mechanism. See 'deriveWith' for an example. -deriveMonoWith :: Modifiers -> Name -> Q [Dec] - -#ifndef __HADDOCK__ - -deriveMonoWith mods typeName = do - (dt, conDescrDecs) <- declareConDescrsBase mods typeName - (epName, epDecs) <- declareEPBase mods dt - (repFunName, repFunDecs) <- mkRepFun mods OptRep dt epName - let funNames = RepFunNames repFunName undefined undefined undefined undefined - - g <- newName "g" - repInstDecs <- deriveRepBase dt funNames g - - collectInstDec <- mkRepCollectInst dt - - return $ - conDescrDecs ++ - epDecs ++ - repFunDecs ++ - repInstDecs ++ - [collectInstDec] - -#else - -deriveMonoWith = undefined - -#endif - --- | Same as 'derive' except that only the monomorphic 'Rep' representation --- value and instance are generated. This is a convenience function that can be --- used instead of the following declarations: --- --- @ --- $(declareConDescrs ''T) --- $(declareEP ''T) --- $(declareMonoRep ''T) --- $(deriveRep ''T) --- $(deriveFRep ''T) --- $(deriveCollect ''T) --- @ -deriveMono :: Name -> Q [Dec] -deriveMono = deriveMonoWith [] - --------------------------------------------------------------------------------- - - --- | Same as 'deriveFRep' except that you can pass a list of name modifications --- to the deriving mechanism. See 'deriveWith' for an example. -deriveFRepWith :: Modifiers -> Name -> Q [Dec] - -#ifndef __HADDOCK__ - -deriveFRepWith mods typeName = do - (dt, _) <- declareConDescrsBase mods typeName - (epName, _) <- declareEPBase mods dt - (funNames, _) <- declareRepFunsBase mods dt epName - g <- newName "g" - frepInstDecs <- deriveFRepBase dt funNames g - return frepInstDecs - -#else - -deriveFRepWith = undefined - -#endif - --- | Generate 'FRep', 'FRep2', and 'FRep3' instance declarations for a type. See --- 'derive' for an example. -deriveFRep :: Name -> Q [Dec] -deriveFRep = deriveFRepWith [] - --------------------------------------------------------------------------------- - --- | Same as 'deriveBiFRep' except that you can pass a list of name --- modifications to the deriving mechanism. See 'deriveWith' for an example. -deriveBiFRepWith :: Modifiers -> Name -> Q [Dec] - -#ifndef __HADDOCK__ - -deriveBiFRepWith mods typeName = do - (dt, _) <- declareConDescrsBase mods typeName - (epName, _) <- declareEPBase mods dt - (funNames, _) <- declareRepFunsBase mods dt epName - g <- newName "g" - bifrepInstDecs <- deriveBiFRepBase dt funNames g - return bifrepInstDecs - -#else - -deriveBiFRepWith = undefined - -#endif - --- | Generate 'BiFRep2' instance declarations for a type. See 'derive' for an --- example. -deriveBiFRep :: Name -> Q [Dec] -deriveBiFRep = deriveBiFRepWith [] - --------------------------------------------------------------------------------- - --- | Generate a @'Rep' 'Collect' T@ instance declaration for a type @T@. See --- 'derive' for an example. -deriveCollect :: Name -> Q [Dec] - -#ifndef __HADDOCK__ - -deriveCollect typeName = do - (dt, _) <- declareConDescrsBase [] typeName - collectInstDec <- mkRepCollectInst dt - return [collectInstDec] - -#else - -deriveCollect = undefined - -#endif - --------------------------------------------------------------------------------- - --- | Generate a @'Rep' 'Everywhere' T@ instance declaration for a type @T@. See --- 'derive' for an example. -deriveEverywhere :: Name -> Q [Dec] - -#ifndef __HADDOCK__ - -deriveEverywhere typeName = do - (dt, _) <- declareConDescrsBase [] typeName - everywhereInstDec <- mkRepEverywhereInst dt - return [everywhereInstDec] - -#else - -deriveEverywhere = undefined - -#endif - --- | Generate a @'Rep' 'Everywhere'' T@ instance declaration for a type @T@. See --- 'derive' for an example. -deriveEverywhere' :: Name -> Q [Dec] - -#ifndef __HADDOCK__ - -deriveEverywhere' typeName = do - (dt, _) <- declareConDescrsBase [] typeName - everywhereInstDec' <- mkRepEverywhereInst' dt - return [everywhereInstDec'] - -#else - -deriveEverywhere' = undefined - -#endif - - diff --git a/src/Generics/EMGM/Functions.hs b/src/Generics/EMGM/Functions.hs deleted file mode 100644 --- a/src/Generics/EMGM/Functions.hs +++ /dev/null @@ -1,38 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Generics.EMGM.Functions --- Copyright : (c) 2008, 2009 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.Everywhere, - 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.Everywhere -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 --- a/src/Generics/EMGM/Functions/Collect.hs +++ b/src/Generics/EMGM/Functions/Collect.hs @@ -1,9 +1,3 @@ -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverlappingInstances #-} - ----------------------------------------------------------------------------- -- | -- Module : Generics.EMGM.Functions.Collect @@ -14,25 +8,34 @@ -- Stability : experimental -- Portability : non-portable -- --- Summary: Generic function that collects all values of a specified type from a +-- Summary: Generic function that collects values of a specified type from a -- generic value. -- ----------------------------------------------------------------------------- +{-# OPTIONS_GHC -Wall #-} + +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverlappingInstances #-} + module Generics.EMGM.Functions.Collect ( Collect(..), collect, ) where -import Generics.EMGM.Common.Base -import Generics.EMGM.Common.Representation +import Control.Applicative (Alternative, empty, pure, (<|>)) +import Generics.EMGM.Base + ----------------------------------------------------------------------------- -- Types ----------------------------------------------------------------------------- -- | The type of a generic function that takes a value of one type and returns a --- list of values of another type. +-- collection of values of another type. -- -- For datatypes to work with Collect, a special instance must be given. This -- instance is trivial to write. Given a type @T@, the 'Rep' instance looks like @@ -42,66 +45,65 @@ -- > -- > data T = ... -- > --- > instance Rep (Collect T) T where --- > rep = Collect (:[]) +-- > instance (Alternative f) => Rep (Collect f T) T where +-- > rep = Collect pure -- --- (Note the requirement of overlapping instances.) This instance triggers when --- the result type (the first @T@) matches some value type (the second @T@) --- contained within the argument to 'collect'. See the source of this module for --- more examples. -newtype Collect b a = Collect { selCollect :: a -> [b] } +-- (Note that overlapping instances are required.) This instance triggers when +-- the result type (the @T@ in @Collect f T@) matches the value type (the second +-- @T@) contained within the argument to 'collect'. See the source of this +-- module for more examples. +newtype Collect f b a = Collect { selCollect :: a -> f b } + ----------------------------------------------------------------------------- -- Generic instance declaration ----------------------------------------------------------------------------- -rconstantCollect :: a -> [b] -rconstantCollect _ = [] - -rsumCollect :: Collect c a -> Collect c b -> a :+: b -> [c] +rsumCollect :: Collect f c a -> Collect f c b -> a :+: b -> f 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 +rprodCollect :: (Alternative f) => Collect f c a -> Collect f c b -> a :*: b -> f c +rprodCollect ra rb (a :*: b) = selCollect ra a <|> selCollect rb b -rtypeCollect :: EP b a -> Collect c a -> b -> [c] +rtypeCollect :: EP b a -> Collect f c a -> b -> f 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) +instance (Alternative f) => Generic (Collect f b) where + rint = Collect $ const empty + rinteger = Collect $ const empty + rfloat = Collect $ const empty + rdouble = Collect $ const empty + rchar = Collect $ const empty + runit = Collect $ const empty + rsum ra rb = Collect $ rsumCollect ra rb + rprod ra rb = Collect $ rprodCollect ra rb + rtype ep ra = Collect $ rtypeCollect ep ra ----------------------------------------------------------------------------- -- Rep instance declarations ----------------------------------------------------------------------------- -instance Rep (Collect Int) Int where - rep = Collect (:[]) +instance (Alternative f) => Rep (Collect f Int) Int where + rep = Collect pure -instance Rep (Collect Integer) Integer where - rep = Collect (:[]) +instance (Alternative f) => Rep (Collect f Integer) Integer where + rep = Collect pure -instance Rep (Collect Float) Float where - rep = Collect (:[]) +instance (Alternative f) => Rep (Collect f Float) Float where + rep = Collect pure -instance Rep (Collect Double) Double where - rep = Collect (:[]) +instance (Alternative f) => Rep (Collect f Double) Double where + rep = Collect pure -instance Rep (Collect Char) Char where - rep = Collect (:[]) +instance (Alternative f) => Rep (Collect f Char) Char where + rep = Collect pure ----------------------------------------------------------------------------- -- Exported functions ----------------------------------------------------------------------------- --- | Collect values of type @b@ from some value of type @a@. An empty list means +-- | Collect values of type @b@ from some value of type @a@. An 'empty' 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. @@ -127,6 +129,6 @@ -- -- @collect@ only works if there is an instance for the return type as described -- in the @newtype 'Collect'@. -collect :: (Rep (Collect b) a) => a -> [b] +collect :: (Alternative f, Rep (Collect f b) a) => a -> f b collect = selCollect rep diff --git a/src/Generics/EMGM/Functions/Compare.hs b/src/Generics/EMGM/Functions/Compare.hs --- a/src/Generics/EMGM/Functions/Compare.hs +++ b/src/Generics/EMGM/Functions/Compare.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleContexts #-} - ----------------------------------------------------------------------------- -- | -- Module : Generics.EMGM.Functions.Compare @@ -27,6 +24,11 @@ -- most of the functionality is handled generically. ----------------------------------------------------------------------------- +{-# OPTIONS_GHC -Wall #-} + +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} + module Generics.EMGM.Functions.Compare ( -- * Compare @@ -59,7 +61,7 @@ import Prelude hiding (compare, min, max) import qualified Prelude as P (compare) -import Generics.EMGM.Common +import Generics.EMGM.Base ----------------------------------------------------------------------------- -- Types @@ -73,9 +75,6 @@ -- 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 @@ -88,18 +87,19 @@ 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) + rint = Compare $ P.compare + rinteger = Compare $ P.compare + rfloat = Compare $ P.compare + rdouble = Compare $ P.compare + rchar = Compare $ P.compare + runit = Compare $ P.compare + rsum ra rb = Compare $ rsumCompare ra rb + rprod ra rb = Compare $ rprodCompare ra rb + rtype ep ra = Compare $ rtypeCompare ep ra ----------------------------------------------------------------------------- -- Exported functions diff --git a/src/Generics/EMGM/Functions/Crush.hs b/src/Generics/EMGM/Functions/Crush.hs --- a/src/Generics/EMGM/Functions/Crush.hs +++ b/src/Generics/EMGM/Functions/Crush.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleContexts #-} - ----------------------------------------------------------------------------- -- | -- Module : Generics.EMGM.Functions.Crush @@ -34,6 +31,11 @@ -- 'flattenr' and 'firstr'. ----------------------------------------------------------------------------- +{-# OPTIONS_GHC -Wall #-} + +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} + module Generics.EMGM.Functions.Crush ( -- * Crush functions @@ -76,8 +78,7 @@ import Prelude hiding (and, or, any, all, elem, notElem, sum, product, max, min, maximum, minimum) -import Generics.EMGM.Common.Base -import Generics.EMGM.Common.Representation +import Generics.EMGM.Base import Generics.EMGM.Functions.Compare ----------------------------------------------------------------------------- @@ -85,20 +86,19 @@ ----------------------------------------------------------------------------- -- | Associativity of the binary operator used for 'crush' + data Assoc = AssocLeft -- ^ Left-associative | AssocRight -- ^ Right-associative -- | The type of a generic function that takes an associativity and two -- arguments of different types and returns a value of the type of the second. + 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 @@ -107,18 +107,19 @@ 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) + rint = Crush $ \_ _ -> id + rinteger = Crush $ \_ _ -> id + rfloat = Crush $ \_ _ -> id + rdouble = Crush $ \_ _ -> id + rchar = Crush $ \_ _ -> id + runit = Crush $ \_ _ -> id + rsum ra rb = Crush $ rsumCrush ra rb + rprod ra rb = Crush $ rprodCrush ra rb + rtype ep ra = Crush $ rtypeCrush ep ra ----------------------------------------------------------------------------- -- Exported functions @@ -129,6 +130,7 @@ -- -- 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). @@ -141,10 +143,12 @@ 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 @@ -152,66 +156,77 @@ -- -- 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@. +-- | Extract the first element of a container. 'fail' if the container is empty. -- --- 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 +-- This is the most general form in which you must specify the associativity and +-- the 'Monad' instance. You may prefer to use the more convenient 'firstr' or +-- 'firstl'. + +first :: (Monad m, FRep (Crush [a]) f) => Assoc -> f a -> m a first asc as = case flatten asc as of - [] -> Nothing - a:_ -> Just a + [] -> fail "first: argument is empty" + a:_ -> return a --- | A right-associative variant of 'first'. +-- | A right-associative 'Maybe' 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'. +-- | A left-associative 'Maybe' 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 :: (Rep Compare a, FRep (Crush Bool) f) => a -> f a -> Bool elem x = any (eq 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 :: (Rep Compare a, FRep (Crush Bool) f) => a -> f a -> Bool notElem x = all (neq 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 :: (Rep Compare a, FRep (Crush (Maybe a)) f) => f a -> Maybe a maximum = crushr f Nothing where f x Nothing = Just x @@ -220,6 +235,7 @@ -- | 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 :: (Rep Compare a, FRep (Crush (Maybe a)) f) => f a -> Maybe a minimum = crushr f Nothing where f x Nothing = Just x @@ -227,21 +243,25 @@ -- | 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 --- a/src/Generics/EMGM/Functions/Enum.hs +++ b/src/Generics/EMGM/Functions/Enum.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleContexts #-} - ----------------------------------------------------------------------------- -- | -- Module : Generics.EMGM.Functions.Enum @@ -28,6 +25,11 @@ -- these may overflow, because they are unbounded. ----------------------------------------------------------------------------- +{-# OPTIONS_GHC -Wall #-} + +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} + module Generics.EMGM.Functions.Enum ( Enum(..), enum, @@ -39,7 +41,7 @@ import qualified Prelude as P (Enum) import Data.List (genericTake) -import Generics.EMGM.Common +import Generics.EMGM.Base ----------------------------------------------------------------------------- -- Types @@ -116,16 +118,15 @@ 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) + 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 diff --git a/src/Generics/EMGM/Functions/Everywhere.hs b/src/Generics/EMGM/Functions/Everywhere.hs --- a/src/Generics/EMGM/Functions/Everywhere.hs +++ b/src/Generics/EMGM/Functions/Everywhere.hs @@ -1,10 +1,3 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverlappingInstances #-} - -------------------------------------------------------------------------------- -- | -- Module : Generics.EMGM.Functions.Everywhere @@ -31,7 +24,7 @@ -- -- @ -- -- SYB --- everywhere :: (forall a. 'Data' a => a -> a) -> forall a. 'Data' a => a -> a +-- everywhere :: (forall a. Data a => a -> a) -> forall a. Data a => a -> a -- @ -- -- @ @@ -40,6 +33,14 @@ -- @ -------------------------------------------------------------------------------- +{-# OPTIONS_GHC -Wall #-} + +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverlappingInstances #-} + module Generics.EMGM.Functions.Everywhere ( Everywhere(..), everywhere, @@ -47,12 +48,7 @@ everywhere', ) where -import Generics.EMGM.Common.Base -import Generics.EMGM.Common.Representation - -#ifdef __HADDOCK__ -import Data.Generics (Data) -#endif +import Generics.EMGM.Base -------------------------------------------------------------------------------- -- Types @@ -93,9 +89,6 @@ -- Generic instance declaration -------------------------------------------------------------------------------- -rconstantEverywhere :: (a -> a) -> b -> b -rconstantEverywhere _ = id - rsumEverywhere :: Everywhere a b1 -> Everywhere a b2 -> (a -> a) -> (b1 :+: b2) -> b1 :+: b2 rsumEverywhere ra _ f (L a) = L (selEverywhere ra f a) rsumEverywhere _ rb f (R b) = R (selEverywhere rb f b) @@ -107,10 +100,15 @@ rtypeEverywhere ep ra f = to ep . selEverywhere ra f . from ep instance Generic (Everywhere a) where - rconstant = Everywhere rconstantEverywhere - rsum ra rb = Everywhere (rsumEverywhere ra rb) - rprod ra rb = Everywhere (rprodEverywhere ra rb) - rtype ep ra = Everywhere (rtypeEverywhere ep ra) + rint = Everywhere $ const id + rinteger = Everywhere $ const id + rfloat = Everywhere $ const id + rdouble = Everywhere $ const id + rchar = Everywhere $ const id + runit = Everywhere $ const id + rsum ra rb = Everywhere $ rsumEverywhere ra rb + rprod ra rb = Everywhere $ rprodEverywhere ra rb + rtype ep ra = Everywhere $ rtypeEverywhere ep ra -------------------------------------------------------------------------------- -- Rep instance declarations @@ -201,9 +199,6 @@ -- Generic instance declaration -------------------------------------------------------------------------------- -rconstantEverywhere' :: (a -> a) -> b -> b -rconstantEverywhere' _ = id - rsumEverywhere' :: Everywhere' a b1 -> Everywhere' a b2 -> (a -> a) -> (b1 :+: b2) -> b1 :+: b2 rsumEverywhere' ra _ f (L a) = L (selEverywhere' ra f a) rsumEverywhere' _ rb f (R b) = R (selEverywhere' rb f b) @@ -215,10 +210,15 @@ rtypeEverywhere' ep ra f = to ep . selEverywhere' ra f . from ep instance Generic (Everywhere' a) where - rconstant = Everywhere' rconstantEverywhere' - rsum ra rb = Everywhere' (rsumEverywhere' ra rb) - rprod ra rb = Everywhere' (rprodEverywhere' ra rb) - rtype ep ra = Everywhere' (rtypeEverywhere' ep ra) + rint = Everywhere' $ const id + rinteger = Everywhere' $ const id + rfloat = Everywhere' $ const id + rdouble = Everywhere' $ const id + rchar = Everywhere' $ const id + runit = Everywhere' $ const id + rsum ra rb = Everywhere' $ rsumEverywhere' ra rb + rprod ra rb = Everywhere' $ rprodEverywhere' ra rb + rtype ep ra = Everywhere' $ rtypeEverywhere' ep ra -------------------------------------------------------------------------------- -- Rep instance declarations diff --git a/src/Generics/EMGM/Functions/Map.hs b/src/Generics/EMGM/Functions/Map.hs --- a/src/Generics/EMGM/Functions/Map.hs +++ b/src/Generics/EMGM/Functions/Map.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleContexts #-} - ----------------------------------------------------------------------------- -- | -- Module : Generics.EMGM.Functions.Map @@ -22,6 +19,11 @@ -- type into a value of another using instances provided by the programmer. ----------------------------------------------------------------------------- +{-# OPTIONS_GHC -Wall #-} + +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} + module Generics.EMGM.Functions.Map ( Map(..), map, @@ -32,7 +34,7 @@ import Prelude hiding (map) -import Generics.EMGM.Common +import Generics.EMGM.Base ----------------------------------------------------------------------------- -- Types @@ -46,9 +48,6 @@ -- 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) @@ -60,21 +59,29 @@ 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) + rint2 = Map $ id + rinteger2 = Map $ id + rfloat2 = Map $ id + rdouble2 = Map $ id + rchar2 = Map $ id + runit2 = Map $ id + 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@. This is a convenience function for --- the implementation @'map' ('const' b) as@. +-- | Replace all @a@-values in @f a@ with @b@. Defined as: +-- @ +-- replace as b = map (const b) as +-- @ replace :: (FRep2 Map f) => f a -> b -> f b replace as b = map (const b) as @@ -115,7 +122,7 @@ -- @ -- -- There are no pre-defined instances, and a call to @cast@ will not compile if --- no instances for the input and output type pair is found, so you must define +-- no instances for the input and output type pair are found, so you must define -- instances in order to use @cast@. cast :: (Rep (Map a) b) => a -> b cast = selMap rep diff --git a/src/Generics/EMGM/Functions/Meta.hs b/src/Generics/EMGM/Functions/Meta.hs new file mode 100644 --- /dev/null +++ b/src/Generics/EMGM/Functions/Meta.hs @@ -0,0 +1,147 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Generics.EMGM.Functions.Meta +-- Copyright : (c) 2008 - 2010 Universiteit Utrecht +-- License : BSD3 +-- +-- Maintainer : generics@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- Summary: Functions for extracting meta-information about the representation. +-------------------------------------------------------------------------------- + +{-# OPTIONS_GHC -Wall #-} + +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} + +module Generics.EMGM.Functions.Meta ( + + -- * Embedding-Projection Pair + HasEP(..), + + -- * Constructor Description + Con(..), + conDescr, + + -- * Label Descriptions + Lbls(..), + lblDescrs + +) where + +import Generics.EMGM.Base + +-------------------------------------------------------------------------------- +-- HasEP class +-------------------------------------------------------------------------------- + +-- | A class to reveal the embedding-projection pair for a given datatype and +-- its isomorphic representation type. + +class HasEP a b | a -> b where + -- | The parameter is never evaluated, so @undefined@ is acceptable. + epOf :: a -> EP a b + +-------------------------------------------------------------------------------- +-- Type +-------------------------------------------------------------------------------- + +-- | The type of a generic function that takes one value and returns an optional +-- constructor description. + +newtype Con a = Con { selConstructor :: a -> Maybe ConDescr } + +-------------------------------------------------------------------------------- +-- Generic instance declaration +-------------------------------------------------------------------------------- + +rsumConstructor :: Con a -> Con b -> a :+: b -> Maybe ConDescr +rsumConstructor ra _ (L a) = selConstructor ra a +rsumConstructor _ rb (R b) = selConstructor rb b + +instance Generic Con where + rint = Con $ const Nothing + rinteger = Con $ const Nothing + rfloat = Con $ const Nothing + rdouble = Con $ const Nothing + rchar = Con $ const Nothing + runit = Con $ const Nothing + rsum ra rb = Con $ rsumConstructor ra rb + rprod _ _ = Con $ const Nothing + rcon cd _ = Con $ const $ Just cd + rlbl _ _ = Con $ const Nothing + rtype ep ra = Con $ selConstructor ra . from ep + +-------------------------------------------------------------------------------- +-- Exported function +-------------------------------------------------------------------------------- + +-- | Returns a constructor description if the value is not a primitive. The +-- argument is not evaluated and may be @undefined@. + +conDescr :: (Rep Con a) => a -> Maybe ConDescr +conDescr = selConstructor rep + +-------------------------------------------------------------------------------- +-- Type +-------------------------------------------------------------------------------- + +-- | The type of a generic function that takes a boolean to limit recursion and +-- a value and returns a list of label descriptions for that constructor. + +newtype Lbls a = Lbls { selLabels :: Bool -> a -> [LblDescr] } + +-------------------------------------------------------------------------------- +-- Generic instance declaration +-------------------------------------------------------------------------------- + +rsumLabels :: Lbls a -> Lbls b -> Bool -> a :+: b -> [LblDescr] +rsumLabels ra _ down (L a) = selLabels ra down a +rsumLabels _ rb down (R b) = selLabels rb down b + +rprodLabels :: Lbls a -> Lbls b -> Bool -> a :*: b -> [LblDescr] +rprodLabels ra rb down (a :*: b) = selLabels ra down a ++ selLabels rb down b + +check :: (a -> [b]) -> Bool -> a -> [b] +check act down val = if down then act val else [] + +rconLabels :: ConDescr -> Lbls a -> Bool -> a -> [LblDescr] +rconLabels _ ra = check $ selLabels ra False + +rtypeLabels :: EP b a -> Lbls a -> Bool -> b -> [LblDescr] +rtypeLabels ep ra = check $ selLabels ra True . from ep + +none :: a -> b -> [c] +none _ _ = [] + +one :: c -> a -> b -> [c] +one c _ _ = [c] + +instance Generic Lbls where + rint = Lbls $ none + rinteger = Lbls $ none + rfloat = Lbls $ none + rdouble = Lbls $ none + rchar = Lbls $ none + runit = Lbls $ none + rsum ra rb = Lbls $ rsumLabels ra rb + rprod ra rb = Lbls $ rprodLabels ra rb + rcon cd ra = Lbls $ rconLabels cd ra + rlbl ld _ = Lbls $ one ld + rtype ep ra = Lbls $ rtypeLabels ep ra + +-------------------------------------------------------------------------------- +-- Exported function +-------------------------------------------------------------------------------- + +-- | Returns a list of descriptions for all labels in the head constructor. Does +-- not recurse into the children. The argument is not evaluated and may be +-- @undefined@. + +lblDescrs :: (Rep Lbls a) => a -> [LblDescr] +lblDescrs = selLabels rep True + diff --git a/src/Generics/EMGM/Functions/Read.hs b/src/Generics/EMGM/Functions/Read.hs --- a/src/Generics/EMGM/Functions/Read.hs +++ b/src/Generics/EMGM/Functions/Read.hs @@ -1,10 +1,3 @@ -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverlappingInstances #-} - ----------------------------------------------------------------------------- -- | -- Module : Generics.EMGM.Functions.Read @@ -34,6 +27,15 @@ -- See also "Generics.EMGM.Functions.Show". ----------------------------------------------------------------------------- +{-# OPTIONS_GHC -Wall #-} + +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverlappingInstances #-} + module Generics.EMGM.Functions.Read ( Read(..), readPrec, @@ -44,13 +46,10 @@ ) 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) + 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) @@ -59,7 +58,7 @@ import qualified GHC.Read as GHC (list) -import Generics.EMGM.Common +import Generics.EMGM.Base ----------------------------------------------------------------------------- -- Types @@ -67,21 +66,13 @@ -- | The type of a generic function that takes a constructor-type argument and -- returns a parser combinator for some type. + 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 () @@ -127,173 +118,102 @@ -- | @(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" +braces p = do Punc "{" <- lexP 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 + then return () + else pfail ----------------------------------------------------------------------------- -- 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) + (fmap L $ selRead ra UnknownC) +++ (fmap R $ selRead rb UnknownC) 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) + NormalC -> + do a <- step (selRead ra NormalC) + b <- step (selRead rb NormalC) return (a :*: b) -- Standard infix constructor - ConIfx symbol -> - do ltraceme "ConIfx (a)" - a <- step (selRead ra ConStd) + InfixC symbol -> + do a <- step (selRead ra NormalC) lexT symbol - ltraceme "ConIfx (b)" - b <- step (selRead rb ConStd) + b <- step (selRead rb NormalC) 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)) + RecordC -> + do a <- step $ selRead ra RecordC + comma + b <- step $ selRead rb RecordC return (a :*: b) -- No other patterns expected _ -> - do ltraceme "FAIL" - pfail - - where - ltraceme s = ltrace $ "rprodRead: " ++ show ct ++ " " ++ s + pfail 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 + -- Normal prefix + ConDescr name _ False Prefix -> + do lexT name + step $ selRead ra NormalC - -- Standard infix constructor - ConDescr name _ [] fixity -> - do ltraceme "ConIfx" - let p = prec fixity - RP.prec p $ step $ selRead ra $ ConIfx name + -- Infix without record syntax + ConDescr name _ False fixity -> + do let p = prec fixity + RP.prec p $ step $ selRead ra $ InfixC name - -- Record-style nonfix constructor - ConDescr name _ labels Nonfix -> - do ltraceme "ConRec (a)" - lexT name - braces $ step $ selRead ra $ ConRec labels + -- Record-style prefix + ConDescr name _ True Prefix -> + do lexT name + braces $ step $ selRead ra RecordC - -- Record-style infix constructor - ConDescr name _ labels _ -> - do ltraceme "ConRec (b)" - paren (lexT name) - braces $ step $ selRead ra $ ConRec labels + -- Record-style infix: We don't actually use the fixity info here. We just + -- need to wrap the symbol name in parens. + ConDescr name _ True _ -> + do paren (lexT name) + braces $ step $ selRead ra RecordC - where ltraceme s = ltrace $ "rconRead: " ++ show cd ++ " " ++ s +rlblRead :: LblDescr -> Read a -> ConType -> ReadPrec a +rlblRead (LblDescr label) ra _ = + do lexT label + equals + selRead ra UnknownC 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 +rtypeRead ep ra = fmap (to ep) . selRead ra 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) + rint = Read $ const TR.readPrec + rinteger = Read $ const TR.readPrec + rfloat = Read $ const TR.readPrec + rdouble = Read $ const TR.readPrec + rchar = Read $ const TR.readPrec + runit = Read $ const $ return Unit + rsum ra rb = Read $ rsumRead ra rb + rprod ra rb = Read $ rprodRead ra rb + rcon cd ra = Read $ rconRead cd ra + rlbl ld ra = Read $ rlblRead ld ra + rtype ep ra = Read $ rtypeRead ep ra ----------------------------------------------------------------------------- -- Rep instance declarations @@ -366,7 +286,7 @@ -- "Text.ParserCombinators.ReadPrec" and should be similar to a derived -- implementation of 'Text.Read.readPrec'. readPrec :: (Rep Read a) => ReadPrec a -readPrec = selRead rep ConStd +readPrec = selRead rep UnknownC -- | Attempt to parse a value from the front of the string using the given -- precedence. 'readsPrec' returns a list of (parsed value, remaining string) diff --git a/src/Generics/EMGM/Functions/Show.hs b/src/Generics/EMGM/Functions/Show.hs --- a/src/Generics/EMGM/Functions/Show.hs +++ b/src/Generics/EMGM/Functions/Show.hs @@ -1,10 +1,3 @@ -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverlappingInstances #-} - ----------------------------------------------------------------------------- -- | -- Module : Generics.EMGM.Functions.Show @@ -33,6 +26,15 @@ -- See also "Generics.EMGM.Functions.Read". ----------------------------------------------------------------------------- +{-# OPTIONS_GHC -Wall #-} + +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverlappingInstances #-} + module Generics.EMGM.Functions.Show ( Show(..), showsPrec, @@ -45,7 +47,7 @@ import qualified GHC.Show as GHC (showList__) -import Generics.EMGM.Common +import Generics.EMGM.Base ----------------------------------------------------------------------------- -- Types @@ -55,15 +57,15 @@ -- | The type of a generic function that takes a constructor-type argument, a -- number (precedence), and a value and returns a 'ShowS' function. + newtype Show a = Show { selShow :: ConType -> Int -> a -> ShowS } --- NOTE: Use full type here instead of 'ShowsPrec' for Haddock. ----------------------------------------------------------------------------- -- Utility functions ----------------------------------------------------------------------------- -showSpace :: ShowS -showSpace = showChar ' ' +showSpace :: Bool -> ShowS +showSpace c = if c then showChar ' ' else id showBraces :: ShowsPrec a -> ShowsPrec a showBraces showsPrec' p x = @@ -75,58 +77,38 @@ 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 - other -> - error $ "rconstantShow: Unexpected constructor: '" ++ P.show other ++ "'" - 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 +rsumShow ra _ _ p (L a) = selShow ra UnknownC p a +rsumShow _ rb _ p (R b) = selShow rb UnknownC 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 + -- Normal prefix + NormalC -> + selShowStep ra NormalC p a . + showSpace True . + selShowStep rb NormalC p b - -- Standard infix constructor - ConIfx symbol -> - selShowStep ra ConStd p a . - showSpace . + -- Infix without record syntax + InfixC symbol -> + selShowStep ra NormalC p a . + showSpace True . showString symbol . - showSpace . - selShowStep rb ConStd p b + showSpace True . + selShowStep rb NormalC p b - -- Record-style constructor - ConRec (label:labels) -> + -- Record-style + RecordC -> let p' = p + 1 in - recEntry True label (selShowStep ra ConStd) p' a . - selShowStep rb (ConRec (labels)) p' b + selShowStep ra RecordC p' a . + showString ", " . + selShowStep rb RecordC p' b -- No other patterns expected other -> @@ -138,64 +120,65 @@ rconShow cd ra _ p a = case cd of - -- Standard nonfix constructor - ConDescr name arity [] Nonfix -> + -- Normal prefix + ConDescr name arity False Prefix -> 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 + showSpace hasArgs . + step NormalC appPrec a - -- Standard infix constructor - ConDescr name _ [] fixity -> + -- Infix without record syntax + ConDescr name _ False fixity -> let conPrec = prec fixity in showParen (p > conPrec) $ - showConStep (ConIfx name) conPrec a + step (InfixC 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. + -- Record-style prefix + ConDescr name _ True Prefix -> + + -- NOTE: Technically, we can use 'recPrec' instead of 'appRec' here. The + -- precedence for record construction is higher than function application. + -- However, since GHC puts parens for application, we'll put them, too. + -- That way, we can test the output with a derived Show instance. + showParen (p > appPrec) $ showString name . - showSpace . - showBraces (selShow ra (ConRec labels)) minPrec a + showSpace True . + showBraces (selShow ra RecordC) minPrec a - -- Record-style infix constructor - ConDescr name _ labels _ -> + -- Record-style infix: We don't actually use the fixity info here. We just + -- need to wrap the symbol name in parens. + ConDescr name _ True _ -> 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 + showSpace True . + showBraces (step RecordC) p a - -- Record-style constructor - ConRec (label:[]) -> - recEntry False label (selShowFrom ConStd) + where + step ct = selShow ra ct . (+1) - -- No other patterns expected - other -> - error $ "rtypeShow: Unexpected constructor: '" ++ P.show other ++ "'" +rlblShow :: LblDescr -> Show a -> ConType -> ShowsPrec a +rlblShow (LblDescr label) ra _ _ a = + showString label . + showString " = " . + selShow ra UnknownC minPrec a -- Reset precedence in the field - where selShowFrom ct' p = selShow ra ct' p . from ep +rtypeShow :: EP b a -> Show a -> ConType -> ShowsPrec b +rtypeShow ep ra 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) + rint = Show $ const P.showsPrec + rinteger = Show $ const P.showsPrec + rfloat = Show $ const P.showsPrec + rdouble = Show $ const P.showsPrec + rchar = Show $ const P.showsPrec + runit = Show $ \_ _ _ -> id + rsum ra rb = Show $ rsumShow ra rb + rprod ra rb = Show $ rprodShow ra rb + rcon cd ra = Show $ rconShow cd ra + rlbl ld ra = Show $ rlblShow ld ra + rtype ep ra = Show $ rtypeShow ep ra ----------------------------------------------------------------------------- -- Rep instance declarations @@ -203,7 +186,7 @@ -- | Ad-hoc instance for lists instance (Rep Show a) => Rep Show [a] where - rep = Show $ const $ const $ GHC.showList__ $ selShow rep ConStd minPrec + rep = Show $ const $ const $ GHC.showList__ $ selShow rep UnknownC minPrec -- | Ad-hoc instance for strings instance Rep Show String where @@ -271,7 +254,7 @@ => 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 +showsPrec = selShow rep UnknownC -- | A variant of 'showsPrec' with the minimum precedence (0). shows :: (Rep Show a) => a -> ShowS diff --git a/src/Generics/EMGM/Functions/Transpose.hs b/src/Generics/EMGM/Functions/Transpose.hs new file mode 100644 --- /dev/null +++ b/src/Generics/EMGM/Functions/Transpose.hs @@ -0,0 +1,136 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Generics.EMGM.Functions.Transpose +-- Copyright : (c) 2008 - 2010 Universiteit Utrecht +-- License : BSD3 +-- +-- Maintainer : generics@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- Summary: Generic function thats transposes a value @f (g a)@ to @g (f a)@. +-- +-- This is an interesting generic function since it uses multiple other generic +-- functions: 'Crush', 'Enum', 'Map', and 'ZipWith'. Notably, 'Map' and +-- 'ZipWith' are required for definining the sum and product cases of the +-- generic function. The others make the generic function easy to use. +-- +-- NOTE: Be aware of the special case for empty values noted in the +-- documentation of 'tranpose'. +-------------------------------------------------------------------------------- + +{-# OPTIONS_GHC -Wall #-} + +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} + +module Generics.EMGM.Functions.Transpose ( + Transpose(..), + transpose, + transposeE, +) where + +import Prelude hiding (map, Enum) +import Control.Monad (liftM) +import Data.Maybe (fromMaybe) + +import Generics.EMGM.Base +import Generics.EMGM.Functions.Crush +import Generics.EMGM.Functions.Enum +import Generics.EMGM.Functions.Map +import Generics.EMGM.Functions.ZipWith + +-------------------------------------------------------------------------------- +-- Types +-------------------------------------------------------------------------------- + +-- | The type of a generic function that takes a generic value and non-generic +-- container and returns the container filled with other generic values. + +newtype (Monad m) => Transpose m f c b a = + Transpose { selTranspose :: a -> f c -> m (f b) } + +-------------------------------------------------------------------------------- +-- Utilities +-------------------------------------------------------------------------------- + +lift :: (Monad m) => (a -> b -> c) -> a -> b -> m c +lift f x y = return $ f x y + +replaceM :: (Monad m, FRep2 Map f) => a -> f b -> m (f a) +replaceM = lift (flip replace) + +-------------------------------------------------------------------------------- +-- Generic instance declaration +-------------------------------------------------------------------------------- + +rsumTranspose + :: (Monad m, FRep2 Map f) + => Transpose m f c a2 a1 + -> Transpose m f c b2 b1 + -> (a1 :+: b1) + -> f c + -> m (f (a2 :+: b2)) +rsumTranspose ra _ (L a) = liftM (map L) . selTranspose ra a +rsumTranspose _ rb (R b) = liftM (map R) . selTranspose rb b + +rprodTranspose + :: (Monad m, FRep3 (ZipWith m) f) + => Transpose m f c a2 a1 + -> Transpose m f c b2 b1 + -> (a1 :*: b1) + -> f c + -> m (f (a2 :*: b2)) +rprodTranspose ra rb (a :*: b) x = do + a' <- selTranspose ra a x + b' <- selTranspose rb b x + zipWithM (lift (:*:)) a' b' + +rtypeTranspose + :: (Monad m, FRep2 Map f) + => EP b2 a2 -> EP b1 a1 + -> Transpose m f c a2 a1 + -> b1 + -> f c + -> m (f b2) +rtypeTranspose ep1 ep2 ra b x = do + v <- selTranspose ra (from ep2 b) x + return (map (to ep1) v) + +instance (Monad m, FRep2 Map f, FRep3 (ZipWith m) f) + => Generic2 (Transpose m f c) where + rint2 = Transpose $ replaceM + rinteger2 = Transpose $ replaceM + rfloat2 = Transpose $ replaceM + rdouble2 = Transpose $ replaceM + rchar2 = Transpose $ replaceM + runit2 = Transpose $ replaceM + rsum2 ra rb = Transpose $ rsumTranspose ra rb + rprod2 ra rb = Transpose $ rprodTranspose ra rb + rtype2 ep1 ep2 ra = Transpose $ rtypeTranspose ep1 ep2 ra + +-------------------------------------------------------------------------------- +-- Exported functions +-------------------------------------------------------------------------------- + +-- | Transposes the structure of nested containers (types @f@ and @g@). 'fail' +-- if the outermost container is empty, because there is no generic way to +-- guarantee that both have unit constructors or, if they do, decide which one +-- to choose. See 'transposeE' for an alternative approach. + +transpose + :: (Monad m, FRep (Crush [g a]) f, FRep2 (Transpose m g a) f) + => f (g a) + -> m (g (f a)) +transpose xs = + first AssocRight xs >>= selTranspose (frep2 (Transpose (const . return))) xs + +-- | A convenient version of 'transpose' that returns the 'empty' value on +-- failure. + +transposeE + :: (Rep Enum (g (f a)), FRep (Crush [g a]) f, FRep2 (Transpose Maybe g a) f) + => f (g a) + -> g (f a) +transposeE = fromMaybe empty . transpose + diff --git a/src/Generics/EMGM/Functions/UnzipWith.hs b/src/Generics/EMGM/Functions/UnzipWith.hs --- a/src/Generics/EMGM/Functions/UnzipWith.hs +++ b/src/Generics/EMGM/Functions/UnzipWith.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleContexts #-} - ----------------------------------------------------------------------------- -- | -- Module : Generics.EMGM.Functions.UnzipWith @@ -12,26 +9,32 @@ -- 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 +-- element in a value, splitting the element into two. The result is a pair of -- 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. +-- 'UnzipWith' can be seen as the dual of 'ZipWith', though it has no direct +-- @Prelude@ counterpart. Only 'unzip' has a @Prelude@ analog. -- -- See also "Generics.EMGM.Functions.ZipWith". ----------------------------------------------------------------------------- +{-# OPTIONS_GHC -Wall #-} + +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} + module Generics.EMGM.Functions.UnzipWith ( UnzipWith(..), + unzipWithM, unzipWith, unzip, ) where import Prelude hiding (unzip) -import Generics.EMGM.Common +import Generics.EMGM.Base ----------------------------------------------------------------------------- -- Types @@ -39,74 +42,98 @@ -- | The type of a generic function that takes an argument of one type and -- returns a pair of values with two different types. -newtype UnzipWith a b c = UnzipWith { selUnzipWith :: a -> (b, c) } +newtype UnzipWith m a b c = UnzipWith { selUnzipWith :: a -> m (b, c) } ----------------------------------------------------------------------------- -- Generic3 instance declaration ----------------------------------------------------------------------------- -rconstantUnzipWith :: a -> (a, a) -rconstantUnzipWith x = (x, x) - -runitUnzipWith :: Unit -> (Unit, Unit) -runitUnzipWith _ = (Unit, Unit) +pair :: (Monad m) => a -> m (a, a) +pair x = return (x, x) -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) +rsumUnzipWith + :: (Monad m) + => UnzipWith m a1 a2 a3 + -> UnzipWith m b1 b2 b3 + -> (a1 :+: b1) + -> m (a2 :+: b2, a3 :+: b3) +rsumUnzipWith ra _ (L a) = selUnzipWith ra a >>= \(x, y) -> return (L x, L y) +rsumUnzipWith _ rb (R b) = selUnzipWith rb b >>= \(x, y) -> return (R x, R y) -rprodUnzipWith :: - UnzipWith a1 a2 a3 - -> UnzipWith b1 b2 b3 +rprodUnzipWith + :: (Monad m) + => UnzipWith m a1 a2 a3 + -> UnzipWith m 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) + -> m (a2 :*: b2, a3 :*: b3) +rprodUnzipWith ra rb (a1 :*: b1) = do + (a2, a3) <- selUnzipWith ra a1 + (b2, b3) <- selUnzipWith rb b1 + return (a2 :*: b2, a3 :*: b3) -rtypeUnzipWith :: - EP b1 a1 +rtypeUnzipWith + :: (Monad m) + => EP b1 a1 -> EP b2 a2 -> EP b3 a3 - -> UnzipWith a1 a2 a3 + -> UnzipWith m 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) + -> m (b2, b3) +rtypeUnzipWith ep1 ep2 ep3 ra b1 = do + (a2, a3) <- selUnzipWith ra (from ep1 b1) + return (to ep2 a2, to ep3 a3) -rconUnzipWith :: ConDescr -> UnzipWith a1 a2 a3 -> a1 -> (a2, a3) -rconUnzipWith _ = selUnzipWith +instance (Monad m) => Generic3 (UnzipWith m) where + rint3 = UnzipWith $ pair + rinteger3 = UnzipWith $ pair + rfloat3 = UnzipWith $ pair + rdouble3 = UnzipWith $ pair + rchar3 = UnzipWith $ pair + runit3 = UnzipWith $ pair + rsum3 ra rb = UnzipWith $ rsumUnzipWith ra rb + rprod3 ra rb = UnzipWith $ rprodUnzipWith ra rb + rtype3 ep1 ep2 ep3 ra = UnzipWith $ rtypeUnzipWith ep1 ep2 ep3 ra -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) +----------------------------------------------------------------------------- +-- Identity Monad +----------------------------------------------------------------------------- +-- We introduce our own identity monad, so we don't have to import +-- Control.Monad.Identity and thus depend on the mtl package. + +-- Since the use of 'Id' is completely obscured from the user except as a type +-- in the constraints of 'unzipWith' and 'unzip', we do not export it. + +newtype Id a = Id { runId :: a } + +instance Monad Id where + return a = Id a + m >>= k = k (runId m) + ----------------------------------------------------------------------------- -- Exported functions ----------------------------------------------------------------------------- -- | Splits a container into two structurally equivalent containers by applying -- a function to every element, which splits it into two corresponding elements. -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)) +-- Fails if the spliting function fails --- | 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) +unzipWithM + :: (Monad m, FRep3 (UnzipWith m) f) + => (a -> m (b, c)) -- ^ Splitting function. + -> f a -- ^ Container of @a@-values. + -> m (f b, f c) -- ^ Pair of containers. +unzipWithM f = selUnzipWith (frep3 (UnzipWith f)) + +-- | A specialized version of 'unzipWithM' using the identity monad and a +-- splitting function that does not fail. + +unzipWith :: (FRep3 (UnzipWith Id) f) => (a -> (b, c)) -> f a -> (f b, f c) +unzipWith f = runId . unzipWithM (\x -> Id (f x)) + +-- | A specialized version of 'unzipWith' for pairs. Generic version of +-- @Prelude.unzip@. + +unzip :: (FRep3 (UnzipWith Id) f) => f (b, c) -> (f b, f c) unzip = unzipWith id diff --git a/src/Generics/EMGM/Functions/ZipWith.hs b/src/Generics/EMGM/Functions/ZipWith.hs --- a/src/Generics/EMGM/Functions/ZipWith.hs +++ b/src/Generics/EMGM/Functions/ZipWith.hs @@ -1,10 +1,7 @@ -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleContexts #-} - ----------------------------------------------------------------------------- -- | -- Module : Generics.EMGM.Functions.ZipWith --- Copyright : (c) 2008, 2009 Universiteit Utrecht +-- Copyright : (c) 2008 - 2010 Universiteit Utrecht -- License : BSD3 -- -- Maintainer : generics@haskell.org @@ -16,16 +13,11 @@ -- 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'. +-- The important concepts for 'zipWithM' are /structural equivalence/ and +-- /corresponding elements/. For 'zipWithM' to be successful (and not 'fail'), +-- its two container arguments must have exactly the same 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, 'zipWithM' will 'fail'. -- -- 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 @@ -35,97 +27,111 @@ -- See also "Generics.EMGM.Functions.UnzipWith". ----------------------------------------------------------------------------- +{-# OPTIONS_GHC -Wall #-} + +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} + module Generics.EMGM.Functions.ZipWith ( ZipWith(..), + zipWithM, zipWith, zip, ) where import Prelude hiding (zipWith, zip) +import Control.Monad (liftM) -import Generics.EMGM.Common +import Generics.EMGM.Base ----------------------------------------------------------------------------- -- Types ----------------------------------------------------------------------------- -- | The type of a generic function that takes two arguments of two different --- types and optionally returns a value of a third type. -newtype ZipWith a b c = ZipWith { selZipWith :: a -> b -> Maybe c } +-- types and returns a value of a third type in a Monad. +newtype ZipWith m a b c = ZipWith { selZipWith :: a -> b -> m 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 +check :: (Eq a, Show a, Monad m) => a -> a -> m a +check x y + | x == y = return x + | otherwise = fail $ "mismatched values: '" ++ show x ++ "' /= '" ++ show y ++ "'" -rsumZipWith :: - ZipWith a1 a2 a3 - -> ZipWith b1 b2 b3 +rsumZipWith + :: (Monad m) + => ZipWith m a1 a2 a3 + -> ZipWith m 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 + -> m (a3 :+: b3) +rsumZipWith ra _ (L a1) (L a2) = liftM L $ selZipWith ra a1 a2 +rsumZipWith _ rb (R b1) (R b2) = liftM R $ selZipWith rb b1 b2 +rsumZipWith _ _ _ _ = fail "mismatched sum" -rprodZipWith :: - ZipWith a1 a2 a3 - -> ZipWith b1 b2 b3 +rprodZipWith + :: (Monad m) + => ZipWith m a1 a2 a3 + -> ZipWith m b1 b2 b3 -> (a1 :*: b1) -> (a2 :*: b2) - -> Maybe (a3 :*: b3) + -> m (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 +rtypeZipWith + :: (Monad m) + => EP b1 a1 -> EP b2 a2 -> EP b3 a3 - -> ZipWith a1 a2 a3 + -> ZipWith m a1 a2 a3 -> b1 -> b2 - -> Maybe b3 + -> m 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 + liftM (to ep3) $ selZipWith ra (from ep1 b1) (from ep2 b2) -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) +instance (Monad m) => Generic3 (ZipWith m) where + rint3 = ZipWith $ check + rinteger3 = ZipWith $ check + rfloat3 = ZipWith $ check + rdouble3 = ZipWith $ check + rchar3 = ZipWith $ check + runit3 = ZipWith $ check + rsum3 ra rb = ZipWith $ rsumZipWith ra rb + rprod3 ra rb = ZipWith $ rprodZipWith ra rb + 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. -zipWith :: - (FRep3 ZipWith f) - => (a -> b -> c) -- ^ Binary operator on elements of containers. +-- function to every corresponding pair of elements. Fails if (1) the binary +-- operator fails or (2) @f a@ and @f b@ have different shapes. + +zipWithM + :: (Monad m, FRep3 (ZipWith m) f) + => (a -> b -> m 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 + -> m (f c) -- ^ Container of @c@-values within a Monad @m@. +zipWithM f = selZipWith (frep3 (ZipWith f)) --- | 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)) +-- | A specialized version of 'zipWithM' for the 'Maybe' monad and a binary +-- operator that does not fail. Generic version of @Prelude.zipWith@. + +zipWith :: (FRep3 (ZipWith Maybe) f) => (a -> b -> c) -> f a -> f b -> Maybe (f c) +zipWith f = zipWithM (\a b -> Just $ f a b) + +-- | A specialized version of 'zipWith' for pairs. Generic version of +-- @Prelude.zip@. + +zip :: (FRep3 (ZipWith Maybe) f) => f a -> f b -> Maybe (f (a, b)) zip = zipWith (,) diff --git a/src/Generics/EMGM/Representation.hs b/src/Generics/EMGM/Representation.hs new file mode 100644 --- /dev/null +++ b/src/Generics/EMGM/Representation.hs @@ -0,0 +1,188 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Generics.EMGM.Representation +-- Copyright : (c) 2008, 2009 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. +-- +----------------------------------------------------------------------------- + +{-# OPTIONS_GHC -Wall #-} + +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} + +module Generics.EMGM.Representation ( + + -- * Structure Representation + -- + -- | The unit, sum, and product types form the sum-of-products view for a + -- Haskell datatype. + + Unit(..), + (:+:)(..), + (:*:)(..), + + -- * Constructor Description + -- + -- | A description of the syntax of each constructor provides useful auxiliary + -- information for some generic functions. + + ConDescr(..), + ConType(..), + LblDescr(..), + + -- * Embedding-Projection Pair + -- + -- | A pair of a function and its inverse form the isomorphism between a + -- datatype and its structure representation. + + EP(..), + + -- * 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(..), + Associativity(..), + Prec, + prec, + minPrec, + maxPrec, + appPrec, + recPrec, + + ) where + +import Text.ParserCombinators.ReadPrec (minPrec, Prec) + +infixr 5 :+: +infixr 6 :*: + +-- | 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, Show) + +-- | 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) + +-- | Encodes the string label for a field in a constructor defined with labeled +-- fields (a.k.a. record syntax). + +newtype LblDescr = LblDescr String + deriving (Eq, Ord, Read, Show) + +-- | The embedding-projection pair contains two functions for converting between +-- the datatype and its representation. An @EP@ value preserves an isomorphism +-- (ignoring @_|_@s) between a datatype and its structure representation. +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. + } + +-- | Contains useful meta-information about the syntax used in a constructor +-- declaration. +-- +-- NOTE: It is important that the 'ConDescr' value accurately describe the +-- syntax in a constructor declaration. An incorrect description may lead to +-- faulty 'Read' or 'Show' operation. + +data ConDescr + = ConDescr + { -- | Name of the constructor (without parenthesese if infix). + conName :: String, + + -- | Number of fields. + conArity :: Int, + + -- | Uses labeled fields (a.k.a. record syntax). + conRecord :: Bool, + + -- | Fixity, associativity, precedence. + conFixity :: Fixity + } + deriving (Eq, Show) + +-- | Type of constructor syntax. Used in the generic functions 'Read' and +-- 'Show'. + +data ConType + = UnknownC -- ^ Have not seen the rcon yet + | NormalC -- ^ Normal prefix-style constructor + | InfixC String -- ^ Infix with symbol (no record syntax) + | RecordC -- ^ Record-style (any fixity) + deriving (Eq, Show) + +-- | A constructor's fixity, associativity, and precedence. +data Fixity + -- | Associativity and precedence are the same as function application. + = Prefix + | Infix Associativity Prec + deriving (Eq, Ord, Read, Show) + +-- | A constructor's associativity. +data Associativity + -- | Declared with infixl + = LeftAssoc + + -- | Declared with infixr + | RightAssoc + + -- | Declared with infix + | NonAssoc + deriving (Eq, Ord, Read, Show) + +-- TODO: Need smart constructor(s) for ConDescr, so we can verify things. + +-- | Get the precedence of a fixity value. +prec :: Fixity -> Prec +prec Prefix = appPrec +prec (Infix _ n) = n + +-- | Maximum precedence: 11 +maxPrec :: Prec +maxPrec = recPrec + +-- | Precedence for function application: 10 +appPrec :: Prec +appPrec = 10 + +-- | Precedence for record construction: 11 +recPrec :: Prec +recPrec = appPrec + 1 + diff --git a/tests/A.hs b/tests/A.hs new file mode 100644 --- /dev/null +++ b/tests/A.hs @@ -0,0 +1,166 @@ +----------------------------------------------------------------------------- +-- | +-- Module : A +-- Copyright : (c) 2008 - 2010 Universiteit Utrecht +-- License : BSD3 +-- +-- Maintainer : generics@haskell.org +-- +-- An example type representation. +----------------------------------------------------------------------------- + +-- {-# OPTIONS_GHC -Wall #-} + +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE UndecidableInstances #-} + +module A where + +import Prelude hiding (Read, Show) +import qualified Prelude as P (Read, Show) +import Data.Generics (Data, Typeable) +import Control.Applicative (Alternative, pure) + +import Generics.EMGM.Base +import Generics.EMGM.Functions.Collect +import Generics.EMGM.Functions.Everywhere +import Generics.EMGM.Functions.Meta + +data A a + = A1 a + | A2 Integer (A a) + | A3 { unA3 :: Double } + | A4 { unA4a :: A a, unA4b :: Int } + | A5 { unA5a :: Char, unA5b :: A a, unA5c :: a } + | A a :^: Float + | (:<>:) { unA7a :: A a, unA7b :: A a } + deriving (P.Show, P.Read, Eq, Ord, Data, Typeable) + +infixr 6 :^: +infixl 5 :<>: + +type AS a + {- A1 -} = a + {- A2 -} :+: Integer :*: A a + {- A3 -} :+: Double + {- A4 -} :+: A a :*: Int + {- A5 -} :+: Char :*: A a :*: a + {- :^: -} :+: A a :*: Float + {- :<>: -} :+: A a :*: A a + +fromA :: A a -> AS a +fromA t = case t of + A1 x1 -> L x1 + A2 x1 x2 -> R (L (x1 :*: x2)) + A3 x1 -> R (R (L x1)) + A4 x1 x2 -> R (R (R (L (x1 :*: x2)))) + A5 x1 x2 x3 -> R (R (R (R (L (x1 :*: x2 :*: x3))))) + x1 :^: x2 -> R (R (R (R (R (L (x1 :*: x2)))))) + x1 :<>: x2 -> R (R (R (R (R (R (x1 :*: x2)))))) + +toA :: AS a -> A a +toA s = case s of + L x1 -> A1 x1 + R (L (x1 :*: x2)) -> A2 x1 x2 + R (R (L x1)) -> A3 x1 + R (R (R (L (x1 :*: x2)))) -> A4 x1 x2 + R (R (R (R (L (x1 :*: x2 :*: x3))))) -> A5 x1 x2 x3 + R (R (R (R (R (L (x1 :*: x2)))))) -> x1 :^: x2 + R (R (R (R (R (R (x1 :*: x2)))))) -> x1 :<>: x2 + +epA :: EP (A a) (AS a) +epA = EP fromA toA + +instance HasEP (A a) (AS a) where + epOf _ = epA + +conA1 = ConDescr "A1" 1 False Prefix +conA2 = ConDescr "A2" 2 False Prefix +conA3 = ConDescr "A3" 1 True Prefix +conA4 = ConDescr "A4" 2 True Prefix +conA5 = ConDescr "A5" 3 True Prefix +conA6 = ConDescr ":^:" 2 False (Infix RightAssoc 6) +conA7 = ConDescr ":<>:" 2 True (Infix LeftAssoc 5) + +lblUnA3 = LblDescr "unA3" +lblUnA4a = LblDescr "unA4a" +lblUnA4b = LblDescr "unA4b" +lblUnA5a = LblDescr "unA5a" +lblUnA5b = LblDescr "unA5b" +lblUnA5c = LblDescr "unA5c" +lblUnA7a = LblDescr "unA7a" +lblUnA7b = LblDescr "unA7b" + +instance (Generic g, Rep g a, Rep g Char, Rep g Double, Rep g Float, Rep g Integer, Rep g Int) => Rep g (A a) where + rep = rtype epA + $ rcon conA1 rep + `rsum` rcon conA2 (rep `rprod` rep) + `rsum` rcon conA3 (rlbl lblUnA3 rep) + `rsum` rcon conA4 (rlbl lblUnA4a rep `rprod` rlbl lblUnA4b rep) + `rsum` rcon conA5 (rlbl lblUnA5a rep `rprod` rlbl lblUnA5b rep `rprod` rlbl lblUnA5c rep) + `rsum` rcon conA6 (rep `rprod` rep) + `rsum` rcon conA7 (rlbl lblUnA7a rep `rprod` rlbl lblUnA7b rep) + +instance (Generic g) => FRep g A where + frep ra = rtype epA + $ rcon conA1 ra + `rsum` rcon conA2 (rinteger `rprod` frep ra) + `rsum` rcon conA3 (rlbl lblUnA3 rdouble) + `rsum` rcon conA4 (rlbl lblUnA4a (frep ra) `rprod` rlbl lblUnA4b rint) + `rsum` rcon conA5 (rlbl lblUnA5a rchar `rprod` rlbl lblUnA5b (frep ra) `rprod` rlbl lblUnA5c ra) + `rsum` rcon conA6 (frep ra `rprod` rfloat) + `rsum` rcon conA7 (rlbl lblUnA7a (frep ra) `rprod` rlbl lblUnA7b (frep ra)) + +instance (Generic2 g) => FRep2 g A where + frep2 ra = rtype2 epA epA + $ rcon2 conA1 ra + `rsum2` rcon2 conA2 (rinteger2 `rprod2` frep2 ra) + `rsum2` rcon2 conA3 (rlbl2 lblUnA3 rdouble2) + `rsum2` rcon2 conA4 (rlbl2 lblUnA4a (frep2 ra) `rprod2` rlbl2 lblUnA4b rint2) + `rsum2` rcon2 conA5 (rlbl2 lblUnA5a rchar2 `rprod2` rlbl2 lblUnA5b (frep2 ra) `rprod2` rlbl2 lblUnA5c ra) + `rsum2` rcon2 conA6 (frep2 ra `rprod2` rfloat2) + `rsum2` rcon2 conA7 (rlbl2 lblUnA7a (frep2 ra) `rprod2` rlbl2 lblUnA7b (frep2 ra)) + +instance (Generic3 g) => FRep3 g A where + frep3 ra = rtype3 epA epA epA + $ rcon3 conA1 ra + `rsum3` rcon3 conA2 (rinteger3 `rprod3` frep3 ra) + `rsum3` rcon3 conA3 (rlbl3 lblUnA3 rdouble3) + `rsum3` rcon3 conA4 (rlbl3 lblUnA4a (frep3 ra) `rprod3` rlbl3 lblUnA4b rint3) + `rsum3` rcon3 conA5 (rlbl3 lblUnA5a rchar3 `rprod3` rlbl3 lblUnA5b (frep3 ra) `rprod3` rlbl3 lblUnA5c ra) + `rsum3` rcon3 conA6 (frep3 ra `rprod3` rfloat3) + `rsum3` rcon3 conA7 (rlbl3 lblUnA7a (frep3 ra) `rprod3` rlbl3 lblUnA7b (frep3 ra)) + +instance (Alternative f) => Rep (Collect f (A a)) (A a) where + rep = Collect pure + +instance (Rep (Everywhere (A a)) a) => Rep (Everywhere (A a)) (A a) where + rep = Everywhere app + where + app f x = + case x of + A1 x1 -> f (A1 (selEverywhere rep f x1)) + A2 x1 x2 -> f (A2 (selEverywhere rep f x1) (selEverywhere rep f x2)) + A3 x1 -> f (A3 (selEverywhere rep f x1)) + A4 x1 x2 -> f (A4 (selEverywhere rep f x1) (selEverywhere rep f x2)) + A5 x1 x2 x3 -> f (A5 (selEverywhere rep f x1) (selEverywhere rep f x2) (selEverywhere rep f x3)) + x1 :^: x2 -> f (selEverywhere rep f x1 :^: selEverywhere rep f x2) + x1 :<>: x2 -> f (selEverywhere rep f x1 :<>: selEverywhere rep f x2) + +instance Rep (Everywhere' (A a)) (A a) where + rep = Everywhere' ($) + +v1 = A1 (5 :: Int) +v2 = A2 37 v1 +v3 = A3 9999.9999 :: A Float +v4 = A4 v3 79 +v5 = A5 'a' v4 5.0 +v6 = v5 :^: 0.12345 +v7 = v6 :<>: v6 + diff --git a/tests/B.hs b/tests/B.hs new file mode 100644 --- /dev/null +++ b/tests/B.hs @@ -0,0 +1,146 @@ +----------------------------------------------------------------------------- +-- | +-- Module : B +-- Copyright : (c) 2008 - 2010 Universiteit Utrecht +-- License : BSD3 +-- +-- Maintainer : generics@haskell.org +-- +-- An example type representation. +----------------------------------------------------------------------------- + +-- {-# OPTIONS_GHC -Wall #-} + +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE UndecidableInstances #-} + +module B where + +import Prelude hiding (Read, Show) +import qualified Prelude as P (Read, Show) +import Data.Generics (Data, Typeable) +import Control.Applicative (Alternative, pure) + +import Generics.EMGM.Base +import Generics.EMGM.Functions.Collect +import Generics.EMGM.Functions.Everywhere +import Generics.EMGM.Data.List +import Generics.EMGM.Data.Maybe +import Generics.EMGM.Data.Tuple + +data B a + = B1 (B Double) + | B2 (Maybe a) + | B3 (Maybe [a]) + | B4 (a,a) + | B5 (a,a,a) (a,a,a,a) (a,a,B a,a,a) (a,a,a,a,a,a) (a,a,a,a,a,a,a) + deriving (P.Show, P.Read, Eq, Ord, Data, Typeable) + +type B' a + {- B1 -} = B Double + {- B2 -} :+: Maybe a + {- B3 -} :+: Maybe [a] + {- B4 -} :+: (a,a) + {- B5 -} :+: (a,a,a) :*: (a,a,a,a) :*: (a,a,B a,a,a) :*: (a,a,a,a,a,a) :*: (a,a,a,a,a,a,a) + +fromB :: B a -> B' a +fromB b = case b of + B1 x1 -> L x1 + B2 x1 -> R (L x1) + B3 x1 -> R (R (L x1)) + B4 x1 -> R (R (R (L x1))) + B5 x1 x2 x3 x4 x5 -> R (R (R (R (x1 :*: x2 :*: x3 :*: x4 :*: x5)))) + +toB :: B' a -> B a +toB b = case b of + L x1 -> B1 x1 + R (L x1) -> B2 x1 + R (R (L x1)) -> B3 x1 + R (R (R (L x1))) -> B4 x1 + R (R (R (R (x1 :*: x2 :*: x3 :*: x4 :*: x5)))) -> B5 x1 x2 x3 x4 x5 + +epB :: EP (B a) (B' a) +epB = EP fromB toB + +conB1 = ConDescr "B1" 1 False Prefix +conB2 = ConDescr "B2" 1 False Prefix +conB3 = ConDescr "B3" 1 False Prefix +conB4 = ConDescr "B4" 1 False Prefix +conB5 = ConDescr "B5" 5 False Prefix + +instance (Generic g, Rep g (B Double), Rep g (Maybe a), Rep g (Maybe [a]), + Rep g (a,a), Rep g (a,a,a), Rep g (a,a,a,a), Rep g (a,a,B a,a,a), + Rep g (a,a,a,a,a,a), Rep g (a,a,a,a,a,a,a)) + => Rep g (B a) where + rep = rtype epB + $ rcon conB1 rep + `rsum` rcon conB2 rep + `rsum` rcon conB3 rep + `rsum` rcon conB4 rep + `rsum` rcon conB5 (rep `rprod` rep `rprod` rep `rprod` rep `rprod` rep) + +instance (Generic g) => FRep g B where + frep ra = rtype epB + $ rcon conB1 (frep rdouble) + `rsum` rcon conB2 (frepMaybe ra) + `rsum` rcon conB3 (frep (frepList ra)) + `rsum` rcon conB4 (frepTuple2 ra ra) + `rsum` rcon conB5 (frepTuple3 ra ra ra `rprod` + frepTuple4 ra ra ra ra `rprod` + frepTuple5 ra ra (frep ra) ra ra `rprod` + frepTuple6 ra ra ra ra ra ra `rprod` + frepTuple7 ra ra ra ra ra ra ra) + +instance (Generic2 g) => FRep2 g B where + frep2 ra = rtype2 epB epB + $ rcon2 conB1 (frep2 rdouble2) + `rsum2` rcon2 conB2 (frep2Maybe ra) + `rsum2` rcon2 conB3 (frep2 (frep2List ra)) + `rsum2` rcon2 conB4 (frep2Tuple2 ra ra) + `rsum2` rcon2 conB5 (frep2Tuple3 ra ra ra `rprod2` + frep2Tuple4 ra ra ra ra `rprod2` + frep2Tuple5 ra ra (frep2 ra) ra ra `rprod2` + frep2Tuple6 ra ra ra ra ra ra `rprod2` + frep2Tuple7 ra ra ra ra ra ra ra) + +instance (Generic3 g) => FRep3 g B where + frep3 ra = rtype3 epB epB epB + $ rcon3 conB1 (frep3 rdouble3) + `rsum3` rcon3 conB3 (frep3Maybe ra) + `rsum3` rcon3 conB3 (frep3 (frep3List ra)) + `rsum3` rcon3 conB4 (frep3Tuple2 ra ra) + `rsum3` rcon3 conB5 (frep3Tuple3 ra ra ra `rprod3` + frep3Tuple4 ra ra ra ra `rprod3` + frep3Tuple5 ra ra (frep3 ra) ra ra `rprod3` + frep3Tuple6 ra ra ra ra ra ra `rprod3` + frep3Tuple7 ra ra ra ra ra ra ra) + +instance (Alternative f) => Rep (Collect f (B a)) (B a) where + rep = Collect pure + +instance (Rep (Everywhere (B a)) a, Rep (Everywhere (B a)) (B Double), + Rep (Everywhere (B a)) (Maybe a), Rep (Everywhere (B a)) (Maybe [a]), + Rep (Everywhere (B a)) (a,a), Rep (Everywhere (B a)) (a,a,a), + Rep (Everywhere (B a)) (a,a,a,a), + Rep (Everywhere (B a)) (a,a,B a,a,a), + Rep (Everywhere (B a)) (a,a,a,a,a,a), + Rep (Everywhere (B a)) (a,a,a,a,a,a,a)) + => Rep (Everywhere (B a)) (B a) where + rep = Everywhere app + where + app f x = + case x of + B1 x1 -> f (B1 (selEverywhere rep f x1)) + B2 x1 -> f (B2 (selEverywhere rep f x1)) + B3 x1 -> f (B3 (selEverywhere rep f x1)) + B4 x1 -> f (B4 (selEverywhere rep f x1)) + B5 x1 x2 x3 x4 x5 -> f (B5 (selEverywhere rep f x1) (selEverywhere rep f x2) (selEverywhere rep f x3) (selEverywhere rep f x4) (selEverywhere rep f x5)) + +instance Rep (Everywhere' (B a)) (B a) where + rep = Everywhere' ($) + diff --git a/tests/Compare.hs b/tests/Compare.hs --- a/tests/Compare.hs +++ b/tests/Compare.hs @@ -1,14 +1,14 @@ -{-# LANGUAGE FlexibleContexts #-} - ----------------------------------------------------------------------------- -- | -- Module : Compare --- Copyright : (c) 2008, 2009 Universiteit Utrecht +-- Copyright : (c) 2008 - 2010 Universiteit Utrecht -- License : BSD3 -- -- Maintainer : generics@haskell.org ----------------------------------------------------------------------------- +{-# LANGUAGE FlexibleContexts #-} + module Compare where import Prelude hiding (Show, show, compare, min, max) @@ -17,9 +17,10 @@ import Data.Generics (Data) import Generics.EMGM +import Generics.EMGM.Functions.Compare import Base -import TTree +import A ----------------------------------------------------------------------------- -- Utility functions @@ -56,9 +57,9 @@ test_max :: (P.Show a, Data a, Ord a, Rep Compare a) => a -> a -> Test test_max = test_f max P.max -t1, t2 :: TTree (TTree Float) -t1 = L1 (L3 8.8 :^: 9.9) :<>: L4 (L4 (L2 (L3 11.11) (L1 (L1 22.22))) (L3 33.33)) (L5 0.44 (L3 55.55) 0.66) -t2 = L1 (L3 8.8 :^: 9.9) :<>: L4 (L4 (L2 (L3 11.11) (L1 (L3 22.22))) (L3 33.33)) (L5 0.44 (L3 55.55) 0.66) +t1, t2 :: A (A Float) +t1 = A1 (A3 8.8 :^: 9.9) :<>: A4 (A4 (A2 11 (A1 (A1 22.22))) 33) 44 +t2 = A1 (A3 8.8 :^: 9.9) :<>: A4 (A4 (A2 11 (A1 (A3 22.22))) 33) 44 ----------------------------------------------------------------------------- -- Test collections diff --git a/tests/Derive.hs b/tests/Derive.hs deleted file mode 100644 --- a/tests/Derive.hs +++ /dev/null @@ -1,170 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverlappingInstances #-} -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -fno-warn-unused-binds #-} -{- OPTIONS_GHC -ddump-splices -} - ------------------------------------------------------------------------------ --- | --- Module : Derive --- Copyright : (c) 2008, 2009 Universiteit Utrecht --- License : BSD3 --- --- Maintainer : generics@haskell.org ------------------------------------------------------------------------------ - -module Derive (tests) where - --------------------------------------------------------------------------------- --- Imports --------------------------------------------------------------------------------- - -import Data.Char (ord, toUpper) -import Test.HUnit - -import Generics.EMGM as G -import Generics.EMGM.Derive - --------------------------------------------------------------------------------- --- Test deriving for functor type --------------------------------------------------------------------------------- - -newtype A a = A a - -$(derive ''A) - -data B a - = B1 a Int - | B2 Char a - | B3 (B a) (B a) - | B4 (B Double) - | B5 (Maybe a) - | B6 (A (Maybe [a])) - | B7 (a,a) --- | B_ (Int -> a) -- UNSUPPORTED - --- We only support a functor type containing constant types or another functor --- type. In other words, we don't support higher arity type constructors (>1 --- type arguments). - -$(derive ''B) - --------------------------------------------------------------------------------- --- Test for other things --------------------------------------------------------------------------------- - -data C a - = C1 (a,Int) -- ^ odd tuple - | C2 String -- ^ type synonym - | C3 (a,a,a) (a,a,a,a) (a,a,C a,a,a) (a,a,a,a,a,a) (a,a,a,a,a,a,a) - -- ^ tuples and type constructor application up to arity 7. - | C4 a -- ^ included so we don't get the warning about the repC function's - -- argument being defined but not used. - deriving (Eq, Prelude.Show) - -$(derive ''C) - -test_mapC = "map ord (C3 ...)" ~: G.map ord i ~?= o - where - i = C3 ('a','a','a') ('b','b','b','b') ('c','c',C2 "blah",'c','c') ('d','d','d','d','d','d') ('e','e','e','e','e','e','e') - o = C3 (97,97,97) (98,98,98,98) (99,99,C2 "blah",99,99) (100,100,100,100,100,100) (101,101,101,101,101,101,101) - --------------------------------------------------------------------------------- --- Test for deriving bifunctor type --------------------------------------------------------------------------------- - -data D a b - = D1 a Int - | D2 Double b - | D3 (D a b) - | D4 (D a b) (D a b) - | D5 (D b a) - | D6 (Either a b) (b,a) (b,Int) - | D7 [a] - --- We only support a bifunctor type containing constant types or another --- bifunctor type. In other words, we don't support a bifunctor type containing --- a functor type or a higher arity type constructors (>2 type arguments). - -$(derive ''D) - --------------------------------------------------------------------------------- --- Test for ChangeTo --------------------------------------------------------------------------------- - -infixr 7 :# - -data a :* b - = Int :% a - | Float :# b - | a :* b - -$(deriveWith [(":%", ChangeTo "Percent"), (":#", ChangeTo "Hash"), (":*", ChangeTo "Star")] ''(:*)) - -test_ChangeTo1 = "ChangeTo Percent" ~: conPercent ~?= ConDescr ":%" 2 [] (Infixl 9) -test_ChangeTo2 = "ChangeTo Hash" ~: conHash ~?= ConDescr ":#" 2 [] (Infixr 7) -test_ChangeTo3 = "ChangeTo Star" ~: assert (G.show (to epStar (from epStar x)) `eq` "'a' :* 97") - where - x :: Char :* Integer - x = 'a' :* 97 - --------------------------------------------------------------------------------- --- Test for DefinedAs --------------------------------------------------------------------------------- - -data E = E { unE :: Integer } deriving Prelude.Show - -$(deriveWith [("E", DefinedAs "E")] ''E) -conE = ConDescr "E" 1 [] Nonfix - -test_DefinedAs1 = - "DefinedAs E" ~: - (assert $ Prelude.show (E 37) `eq` "E {unE = 37}" && G.show (E 37) `eq` "E 37") - --------------------------------------------------------------------------------- --- Test for manual deriving --------------------------------------------------------------------------------- - -data F a = F a Int - -$(declareConDescrs ''F) -$(declareEP ''F) -$(declareRepValues ''F) -$(deriveRep ''F) -$(deriveFRep ''F) -$(deriveCollect ''F) -$(deriveEverywhere ''F) - -test_manual1 = - "show $ map ord (C 'a' 4)" ~: - assert (G.show (G.map ord (F 'a' 4)) `eq` "F 97 4") - -test_manual2 = - "collect (F (4::Integer) 3)" ~: - assert (collect (F (4::Integer) 3) `eq` ([F 4 3::F Integer])) - -test_manual3 = - "everywhere toUpper (F 'x' 3)" ~: - assert (everywhere toUpper (F 'x' 3) `eq` F 'X' 3) - --------------------------------------------------------------------------------- --- Test collection --------------------------------------------------------------------------------- - -tests = - "Derive" ~: - [ test_mapC - , test_ChangeTo1 - , test_ChangeTo2 - , test_ChangeTo3 - , test_DefinedAs1 - , test_manual1 - , test_manual2 - , test_manual3 - ] - diff --git a/tests/Enum.hs b/tests/Enum.hs --- a/tests/Enum.hs +++ b/tests/Enum.hs @@ -18,6 +18,7 @@ import Base import Generics.EMGM +import Generics.EMGM.Functions.Enum ----------------------------------------------------------------------------- -- Utility functions diff --git a/tests/Everywhere.hs b/tests/Everywhere.hs --- a/tests/Everywhere.hs +++ b/tests/Everywhere.hs @@ -1,8 +1,7 @@ - ----------------------------------------------------------------------------- -- | -- Module : Everywhere --- Copyright : (c) 2008, 2009 Universiteit Utrecht +-- Copyright : (c) 2008 - 2010 Universiteit Utrecht -- License : BSD3 -- -- Maintainer : generics@haskell.org @@ -10,7 +9,7 @@ module Everywhere (tests) where -import TTree +import A import Generics.EMGM as G import Test.HUnit @@ -60,9 +59,9 @@ f_unit :: () -> () f_unit = id -f_ttree1 :: TTree Int -> TTree Int -f_ttree1 (L1 4) = L1 7 -f_ttree1 (L2 5 (L1 4)) = L1 9 +f_ttree1 :: A Int -> A Int +f_ttree1 (A1 4) = A1 7 +f_ttree1 (A2 5 (A1 4)) = A1 9 f_ttree1 x = x ----------------------------------------------------------------------------- @@ -94,8 +93,8 @@ , test_e "(,,,,)" f_unit ((),(),(),(),()) id , test_e "(,,,,,)" f_unit ((),(),(),(),(),()) id , test_e "(,,,,,,)" f_unit ((),(),(),(),(),(),()) id - , test_e "TTree1" f_ttree1 (L1 4) f_ttree1 - , test_e "TTree2" f_ttree1 (L2 (5::Int) (L1 4)) (const (L2 5 (L1 7))) + , test_e "T1" f_ttree1 (A1 4) f_ttree1 + , test_e "T2" f_ttree1 (A2 5 (A1 4) :: A Int) (const (A2 5 (A1 7))) ] , "Everywhere'" ~: @@ -120,8 +119,8 @@ , test_e' "(,,,,)" f_unit ((),(),(),(),()) id , test_e' "(,,,,,)" f_unit ((),(),(),(),(),()) id , test_e' "(,,,,,,)" f_unit ((),(),(),(),(),(),()) id - , test_e' "TTree1" f_ttree1 (L1 4) f_ttree1 - , test_e' "TTree2" f_ttree1 (L2 (5::Int) (L1 4)) (const (L1 9)) + , test_e' "T1" f_ttree1 (A1 4) f_ttree1 + , test_e' "T2" f_ttree1 (A2 5 (A1 4) :: A Int) (const (A1 9)) ] ] diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -8,8 +8,10 @@ -- Maintainer : generics@haskell.org ----------------------------------------------------------------------------- -module Main where +module Main (main) where +import System.Exit (exitSuccess, exitFailure) + import Test.HUnit import qualified Crush (tests) @@ -21,8 +23,7 @@ import qualified ZipWith (tests) import qualified UnzipWith (tests) import qualified Map (tests) -import qualified Bimap (tests) -import qualified Derive (tests) +-- import qualified Bimap (tests) -- Make sure the examples compile: import qualified Ex00StartHere () @@ -37,11 +38,13 @@ , ZipWith.tests , UnzipWith.tests , Map.tests - , Bimap.tests - , Derive.tests +-- , Bimap.tests ] main = do putStrLn "Running tests for EMGM..." - runTestTT tests + counts <- runTestTT tests + if errors counts > 0 || failures counts > 0 + then exitFailure + else exitSuccess diff --git a/tests/Map.hs b/tests/Map.hs --- a/tests/Map.hs +++ b/tests/Map.hs @@ -20,6 +20,7 @@ import Test.HUnit import Generics.EMGM as G +import Generics.EMGM.Functions.Map ----------------------------------------------------------------------------- -- Utility functions diff --git a/tests/ReadShow.hs b/tests/ReadShow.hs --- a/tests/ReadShow.hs +++ b/tests/ReadShow.hs @@ -1,15 +1,15 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} - ----------------------------------------------------------------------------- -- | -- Module : ReadShow --- Copyright : (c) 2008, 2009 Universiteit Utrecht +-- Copyright : (c) 2008 - 2010 Universiteit Utrecht -- License : BSD3 -- -- Maintainer : generics@haskell.org ----------------------------------------------------------------------------- +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} + module ReadShow (tests) where import Prelude hiding (Read, Show, readsPrec, reads, read, show) @@ -18,9 +18,11 @@ import Test.HUnit import Generics.EMGM +import Generics.EMGM.Functions.Read +import Generics.EMGM.Functions.Show import Base -import TTree +import A ----------------------------------------------------------------------------- -- Utility functions @@ -59,17 +61,17 @@ , test_all True (Right '2' :: Either Float Char) , test_all True (Nothing :: Maybe Double) , test_all True (Just 256 :: Maybe Int) - , test_all True (L1 5 :: TTree Int) - , test_all True (L1 (Just 5) :: TTree (Maybe Int)) - , test_all True (L2 88 (L1 99) :: TTree Int) - , test_all True (L3 654 :: TTree Int) - , test_all True (Just (L3 654) :: Maybe (TTree Int)) - , test_all True (L4 (L2 1 (L3 2)) 3 :: TTree Int) - , test_all True (L5 101 (L4 (L3 102) 103) 104 :: TTree Int) - , test_all True (L3 'g' :^: 'a' :: TTree Char) - , test_all True ((L3 'F' :^: 'a') :^: 'g' :: TTree Char) - , test_all False (L1 1.1 :<>: L1 1.2 :^: 1.3 :: TTree Float) - , test_all False (L1 (L3 8.8 :^: 9.9) :<>: L4 (L4 (L2 (L3 11.11) (L1 (L1 22.22))) (L3 33.33)) (L5 0.44 (L3 55.55) 0.66) :: TTree (TTree Float)) + , test_all True (A1 5 :: A Int) + , test_all True (A1 (Just 5) :: A (Maybe Int)) + , test_all True (A2 88 (A1 99) :: A Int) + , test_all True (A3 654 :: A Int) + , test_all True (Just (A3 654) :: Maybe (A Int)) + , test_all True (A4 (A2 1 (A3 2)) 3 :: A Int) + , test_all True (A5 'a' (A4 (A3 102) 103) 104 :: A Int) + , test_all True (A3 8.0 :^: 8.0 :: A Char) + , test_all True ((A3 (-0.2) :^: 0.2) :^: 2.0 :: A Char) + , test_all False (A1 1.1 :<>: A1 1.2 :^: 1.3 :: A Float) + , test_all False (A1 (A3 8.8 :^: 9.9) :<>: A4 (A4 (A2 101 (A1 (A1 22.22))) (-1)) 55 :: A (A Float)) , test_all True [1,2,3,4,5 :: Int] , test_all True [[5.3,3.5],[35.0],[0.53 :: Float]] , test_all True "abcdefgh" @@ -80,6 +82,6 @@ , test_all True (1::Int,2::Float,3::Double,'4') , test_all True (1::Int,2::Float,3::Double,'4',False) , test_all True (1::Int,2::Float,3::Double,'4',False,Just (6::Int)) - , test_all True (1::Int,2::Float,3::Double,'4',False,Just (6::Int),L1 (7::Float)) + , test_all True (1::Int,2::Float,3::Double,'4',False,Just (6::Int),A1 (7::Float)) ] diff --git a/tests/TTree.hs b/tests/TTree.hs deleted file mode 100644 --- a/tests/TTree.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE OverlappingInstances #-} -{-# LANGUAGE UndecidableInstances #-} -{- OPTIONS -ddump-splices -} - ------------------------------------------------------------------------------ --- | --- Module : TTree --- Copyright : (c) 2008, 2009 Universiteit Utrecht --- License : BSD3 --- --- Maintainer : generics@haskell.org ------------------------------------------------------------------------------ - -module TTree where - -import Prelude hiding (Read, Show) -import qualified Prelude as P (Read, Show) -import Data.Generics (Data, Typeable) - -import Generics.EMGM.Derive - -infixr 6 :^: -infixl 5 :<>: - -data TTree a - = L1 a - | L2 a (TTree a) - | L3 { unL3 :: a } - | L4 { unL4t :: TTree a, unL4a :: a } - | L5 { unL5a1 :: a, unL5t :: TTree a, unL5a2 :: a } - | TTree a :^: a - | (:<>:) { left :: TTree a, right :: TTree a } - deriving (P.Show, P.Read, Eq, Ord, Data, Typeable) - -$(deriveWith [(":<>:", DefinedAs "L6")] ''TTree) -conL6 = ConDescr ":<>:" 2 ["left","right"] (Infixr 5) -