emgm 0.1 → 0.2

raw patch · 48 files changed

+3468/−356 lines, 48 filesdep +template-haskelldep ~HUnitdep ~QuickCheckdep ~basesetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: template-haskell

Dependency ranges changed: HUnit, QuickCheck, base

API changes (from Hackage documentation)

Files

• README +7/−6
• Setup.lhs +35/−5
• emgm.cabal +71/−46
• examples/Ex00StartHere.hs +43/−0
• examples/Ex01UsingFunctions.hs +72/−0
• examples/Ex02AddingDatatypeSupport.hs +116/−0
• examples/Ex03DefiningFunctions.hs +57/−0
• src/Generics/EMGM.hs +310/−34
• src/Generics/EMGM/Common.hs +2/−0
• src/Generics/EMGM/Common/Base.hs +4/−5
• src/Generics/EMGM/Common/Base2.hs +10/−5
• src/Generics/EMGM/Common/Base3.hs +4/−5
• src/Generics/EMGM/Common/Derive.hs +538/−0
• src/Generics/EMGM/Common/Derive/Common.hs +147/−0
• src/Generics/EMGM/Common/Derive/ConDescr.hs +113/−0
• src/Generics/EMGM/Common/Derive/EP.hs +155/−0
• src/Generics/EMGM/Common/Derive/Instance.hs +295/−0
• src/Generics/EMGM/Common/Representation.hs +34/−24
• src/Generics/EMGM/Data.hs +3/−1
• src/Generics/EMGM/Data/Bool.hs +33/−17
• src/Generics/EMGM/Data/Either.hs +38/−17
• src/Generics/EMGM/Data/List.hs +22/−22
• src/Generics/EMGM/Data/Maybe.hs +33/−20
• src/Generics/EMGM/Data/TH.hs +71/−0
• src/Generics/EMGM/Data/Tuple.hs +69/−23
• src/Generics/EMGM/Functions/Collect.hs +42/−71
• src/Generics/EMGM/Functions/Compare.hs +16/−12
• src/Generics/EMGM/Functions/Crush.hs +15/−12
• src/Generics/EMGM/Functions/Enum.hs +2/−1
• src/Generics/EMGM/Functions/Map.hs +9/−1
• src/Generics/EMGM/Functions/Read.hs +2/−4
• src/Generics/EMGM/Functions/Show.hs +12/−8
• src/Generics/EMGM/Functions/UnzipWith.hs +2/−2
• src/Generics/EMGM/Functions/ZipWith.hs +3/−3
• tests/Base.hs +36/−0
• tests/Bimap.hs +87/−0
• tests/Collect.hs +39/−0
• tests/Compare.hs +115/−0
• tests/Crush.hs +113/−0
• tests/Derive.hs +157/−0
• tests/Enum.hs +70/−0
• tests/Main.hs +16/−12
• tests/Map.hs +38/−0
• tests/ReadShow.hs +76/−0
• tests/TTree.hs +116/−0
• tests/UnzipWith.hs +35/−0
• tests/ZipWith.hs +45/−0
• util/hpc.lhs +140/−0

@@ -34,8 +34,8 @@  EMGM has the following requirements: -*  [GHC] 6.8.1 - It has been tested with versions 6.8.3 and 6.9.20080916.-*  [Cabal] library 1.2.1 - It has been tested with versions 1.2.3 and 1.4.0.1.+*  [GHC] 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/@@ -157,13 +157,14 @@ In addition to the requirements for using the library, EMGM has the following requirements for development: -*  Cabal library 1.4.0.1 - This is preferred for uploading to HackageDB. Some+*  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.0] - Required for testing.-*  HUnit 1.2 - Required for testing.+*  [QuickCheck] 2.1 - Required for testing.+*  [HUnit] 1.2 - Required for testing. -[QuickCheck 2.0]: http://darcs.haskell.org/QuickCheck/+[QuickCheck]: http://hackage.haskell.org/cgi-bin/hackage-scripts/package/QuickCheck+[HUnit]: http://hackage.haskell.org/cgi-bin/hackage-scripts/package/HUnit  ### Configuring ### 

@@ -6,18 +6,48 @@  module Main (main) where -import Distribution.Simple (defaultMainWithHooks, simpleUserHooks, UserHooks(..))-import System.Cmd (system)-import System.FilePath ((</>))+import System.Cmd+  ( system+  ) +import System.FilePath+  ( (</>)+  )++import Distribution.Simple+  ( defaultMainWithHooks+  , simpleUserHooks+  , UserHooks(runTests, haddockHook)+  )++import Distribution.Simple.LocalBuildInfo+  ( LocalBuildInfo(withPrograms)+  )++import Distribution.Simple.Program+  ( userSpecifyArgs+  )+ main :: IO ()-main = defaultMainWithHooks hooks where-  hooks = simpleUserHooks { runTests = runTests' }+main = defaultMainWithHooks hooks+  where+    hooks = simpleUserHooks+            { runTests    = runTests'+            , haddockHook = haddockHook'+            } +-- Run a 'test' binary that gets built when configured with '-ftest'. 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' pkg lbi = haddockHook simpleUserHooks pkg lbi { withPrograms = p }+  where+    p = userSpecifyArgs "haddock" ["--optghc=-D__HADDOCK__"] (withPrograms lbi)  \end{code} 

@@ -1,5 +1,5 @@ name:                   emgm-version:                0.1+version:                0.2 synopsis:               Extensible and Modular Generics for the Masses homepage:               http://www.cs.uu.nl/wiki/GenericProgramming/EMGM description:@@ -7,7 +7,7 @@   EMGM is a general-purpose library for generic programming with type classes.   .   The design is based on the idea of modeling algebraic datatypes as-  sum-of-product structures. Many datatypes can be modeled this way, and,+  sum-of-product structures. Many datatypes can be modeled this way, and   because they all share a common structure, we can write generic functions that   work on this structure.   .@@ -19,47 +19,20 @@   what you need to define your own generic functions, to add generic support for   your datatype, or to define ad-hoc cases.   .-  (2) 'Functions' - /A collection of useful generic functions./-  These work with a variety of datatypes and provide a wide range of operations.-  For example, there is 'crush', a generalization of the fold functions. It is-  one of the most useful functions, because it allows you to flexibly extract-  the elements of a polymorphic container.-  .-  (3) 'Data' - /Support for using standard datatypes generically./+  (2) 'Data' - /Support for using standard datatypes generically./   Types such as @[a]@, tuples, and @Maybe@ are built into Haskell or come   included in the standard libraries. EMGM provides full support for generic   functions on these datatypes. The modules in this component are also useful as   guides when adding generic support for your own datatypes.   .-  EMGM originated in the research of Ralf Hinze, Bruno Oliveira, and Andres Löh-  [1,2]. The library was further explored in a comparison of generic programming-  libraries by Alexey Rodriguez, et al [3]. Lastly, this released package was-  developed simultaneously with the writing of lecture notes for the 2008-  Advanced Functional Programming Summer School [4] (forthcoming). These are-  good resources for learning how the library works and how to use it, but be-  aware that names may have been changed to protect the innocent.-  .-  (1) Ralf Hinze. Generics for the Masses. In ICFP 2004: Proceedings of the 9th ACM-  SIGPLAN international conference on Functional programming, pages 236-243. ACM-  Press, 2004.-  (<http://www.informatik.uni-bonn.de/~ralf/publications.html#P21>)-  .-  (2) Bruno C. d. S. Oliveira, Ralf Hinze, and Andres Löh. Extensible and Modular-  Generics for the Masses. In Henrik Nilsson, editor, Trends in Functional-  Programming, pages 199-216, 2006.-  (<http://web.comlab.ox.ac.uk/publications/publication444-abstract.html>)-  .-  (3) Alexey Rodriguez, Johan Jeuring, Patrik Jansson, Alex Gerdes, Oleg Kiselyov,-  and Bruno C. d. S. Oliveira. Comparing Libraries for Generic Programming in-  Haskell. Technical Report UU-CS-2008-010. Department of Information and-  Computing Sciences, Utrecht University.-  (<http://www.cs.uu.nl/wiki/bin/view/Alexey/ComparingLibrariesForGenericProgrammingInHaskell>)+  (3) 'Functions' - /A collection of useful generic functions./+  These work with a variety of datatypes and provide a wide range of operations.+  For example, there is 'crush', a generalization of the fold functions. It is+  one of the most useful functions, because it allows you to flexibly extract+  the elements of a polymorphic container.   .-  (4) Johan Jeuring, Sean Leather, José Pedro Magalhães, and Alexey Rodriguez-  Yakushev. Libraries for Generic Programming in Haskell. Technical Report-  UU-CS-2008-025. Department of Information and Computing Sciences, Utrecht-  University.-  (<http://www.cs.uu.nl/research/techreps/UU-CS-2008-025.html>)+  For more information on the EMGM library, see the homepage:+  <http://www.cs.uu.nl/wiki/GenericProgramming/EMGM>  category:               Generics copyright:              (c) 2008 Universiteit Utrecht@@ -71,14 +44,36 @@                         Andres Löh maintainer:             generics@haskell.org stability:              experimental-extra-source-files:     README+extra-source-files:     README,+                        examples/Ex00StartHere.hs,+                        examples/Ex01UsingFunctions.hs,+                        examples/Ex02AddingDatatypeSupport.hs,+                        examples/Ex03DefiningFunctions.hs,+                        tests/Base.hs,+                        tests/Bimap.hs,+                        tests/Collect.hs,+                        tests/Compare.hs,+                        tests/Crush.hs,+                        tests/Derive.hs,+                        tests/Enum.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.9.20080916+tested-with:            GHC == 6.8.3, GHC == 6.10.1  -------------------------------------------------------------------------------- +flag th23+  description:          Define a CPP flag that enables conditional compilation+                        for template-haskell package version 2.3 and newer.+ flag test   description:          Enable the test configuration: Build the test                         executable, reduce build time.@@ -100,6 +95,7 @@  Library   hs-source-dirs:       src+   exposed-modules:      Generics.EMGM                          -- Common foundation@@ -108,6 +104,7 @@                         Generics.EMGM.Common.Base                         Generics.EMGM.Common.Base2                         Generics.EMGM.Common.Base3+                        Generics.EMGM.Common.Derive                          -- Generic functions                         Generics.EMGM.Functions@@ -128,8 +125,24 @@                         Generics.EMGM.Data.List                         Generics.EMGM.Data.Maybe                         Generics.EMGM.Data.Tuple+                        Generics.EMGM.Data.TH -  build-depends:        base >= 3.0+  other-modules:        Generics.EMGM.Common.Derive.Common+                        Generics.EMGM.Common.Derive.ConDescr+                        Generics.EMGM.Common.Derive.EP+                        Generics.EMGM.Common.Derive.Instance++  build-depends:        base >= 3.0 && < 4.0,+                        template-haskell < 2.4++  -- Include deriveRep for Loc. This was introduced with+  -- template-haskell-2.3, included with GHC 6.10.+  if flag(th23)+    build-depends:      template-haskell >= 2.3+    cpp-options:        -DTH_LOC_DERIVEREP+  else+    build-depends:      template-haskell < 2.3+   extensions:           CPP    ghc-options:          -Wall@@ -156,16 +169,28 @@   extensions:           CPP   main-is:              Main.hs -  ghc-options:          -Wall -O0 -fno-warn-missing-signatures+  build-depends:        base >= 3.0 && < 4.0,+                        template-haskell < 2.4 -  -- Add program coverage if configured with "-fhpc".-  if flag(hpc)-    ghc-options:        -fhpc+  -- Include deriveRep for Loc. This was introduced with+  -- template-haskell-2.3, included with GHC 6.10.+  if flag(th23)+    build-depends:      template-haskell >= 2.3+    cpp-options:        -DTH_LOC_DERIVEREP+  else+    build-depends:      template-haskell < 2.3    -- Only enable the build-depends here if configured with "-ftest". This-  -- keeps users from having to install QuickCheck 2 in order to use EMGM.+  -- allows users to use EMGM without having to install QuickCheck.   if flag(test)-    build-depends:      QuickCheck >= 2.0, HUnit >= 1.2+    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 

@@ -0,0 +1,43 @@++-----------------------------------------------------------------------------+-- |+-- Module      :  Ex00StartHere+-- Copyright   :  (c) 2008 Universiteit Utrecht+-- License     :  BSD3+--+-- Maintainer  :  generics@haskell.org+--+-- Start here to go through the examples. This module gives a brief overview of+-- the included examples, so that you may then jump to the desired module.+--+-----------------------------------------------------------------------------++module Ex00StartHere where++-- The best way to try these out is to load each into the GHCi interpreter and+-- see what happens when you evaluate various expressions.++-- Before you begin, be sure that you have correctly installed the 'emgm'+-- library. Otherwise, you will have trouble compiling these modules.++----------------------------+import Ex01UsingFunctions ()+----------------------------+-- ^ This module covers the basic usage of several generic functions provided by+-- the library. It's a good start if you have never used such a library, because+-- it demonstrates some of the advantages and restrictions necessary for use.++-----------------------------------+import Ex02AddingDatatypeSupport ()+-----------------------------------+-- ^ This module demonstrates adding support for generic functions to a simple+-- 'Tree' datatype. If you have have your own types that you want EMGM to+-- support, this example should help you get started.++-------------------------------+import Ex03DefiningFunctions ()+-------------------------------+-- ^ This module provides an example of writing a simple generic function. It+-- will help you get started with your own, by showing the typical steps+-- necessary.+

@@ -0,0 +1,72 @@++-----------------------------------------------------------------------------+-- |+-- Module      :  Ex01UsingFunctions+-- Copyright   :  (c) 2008 Universiteit Utrecht+-- License     :  BSD3+--+-- Maintainer  :  generics@haskell.org+--+-- This module shows how you can use the EMGM library to apply predefined+-- generic functions to the Predule datatypes. Functionality such as reading and+-- showing values is demonstrated. Several terms are successively defined and+-- their evaluation is shown in a comment after the definition.+--+-----------------------------------------------------------------------------++module Ex01UsingFunctions where++-- Using generic functions on Prelude types++-- Since Generics.EMGM redefines functions from the standard Haskell Prelude,+-- you need to either use a qualified import for the generic functions or+-- hide the ones from the prelude. Here we choose to do the former.+import qualified Generics.EMGM as G++-- Some simple examples+example1 = G.show (Just 'r')+-- Evaluates to: "Just 'r'"++-- You need to explicitly type the 3 as an Int, else it will be inferred as+-- having type Num a, which will not work+example2 = G.show (3 :: Int)+-- Evaluates to: "3"++-- The same happens in lists+example3 = G.show [1..(10 :: Int)]+-- Evaluates to: "[1,2,3,4,5,6,7,8,9,10]"++-- Many types have Rep instances, but remember all types must be monomorphic+example4 = G.show (Left 'p' :: Either Char (),+           Just (Right 'r' :: Either () Char),+           [False, True])+-- Evaluates to: "(Left 'p',Just (Right 'r'),[False,True])"++-- read works almost like its Prelude counterpart, with the exception that it+-- returns a Maybe value+example5 :: Maybe Int+example5 = G.read "5"+-- Evaluates to: Just 5++example6 :: Maybe Int+example6 = G.read "%"+-- Evaluates to: Nothing++example7 :: Maybe (Either Char (), Maybe (Either () Char), [Bool])+example7 = G.read "(Left 'p', Just (Right 'r'), [False, True])"+-- Just (Left 'p',Just (Right 'r'),[False,True])++example8 = G.zip [1..10::Int] ['a'..'j']+-- Evaluates to: Just [(1,'a'),(2,'b'),(3,'c'),(4,'d'),(5,'e'),(6,'f'),(7,'g'),(8,'h'),(9,'i'),(10,'j')]++example9 = G.zipWith (+) [1..3::Int] [3,2,1]+-- Evaluates to: Just [4,4,4]++-- firstr behaves likes head+example10 = G.firstr $ take 100 (G.enum :: [(Int, Bool)])+-- Evaluates to: Just (0,False)++-- Generic comparison of generic and standard read+example11 = example5 `G.eq` Just (read "5")+-- Evaluates to: True+

@@ -0,0 +1,116 @@++-----------------------------------------------------------------------------+-- |+-- Module      :  Ex02AddingDatatypeSupport+-- Copyright   :  (c) 2008 Universiteit Utrecht+-- License     :  BSD3+--+-- Maintainer  :  generics@haskell.org+--+-- Second example module of using the EMGM library --- using the predefined+-- generic functions on user-defined datatypes.++-- This example module shows how you can use the EMGM library to apply+-- predefined generic functions to your own datatypes. Functionality such+-- as enumeration and flattening is examplified. Several terms are+-- successively defined and their evaluation is shown in a comment after the+-- definition.+--+-----------------------------------------------------------------------------++-- We need a few language extensions. The easiest way is to add the following+-- comments.+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE MultiParamTypeClasses  #-}++module Ex02AddingDatatypeSupport where++import Generics.EMGM.Common+import Generics.EMGM.Data()+import qualified Generics.EMGM.Functions as G++-- Using generic functions on your own datatypes++-- Let's define some datatypes:+data Tree a = Leaf a | Branch (Tree a) (Tree a)++-- For your datatypes, you have to define your own instances as below:+--    Embedding projection pair (conversion between the datatype and a+--    structural generic representation):+epTree = EP from' to' where+  from' (Leaf aa) = L (aa)+  from' (Branch aa ab) = R (aa :*: (ab))+  to' (L (aa)) = (Leaf aa)+  to' (R (aa :*: (ab))) = (Branch aa ab)++--    Description of the constructors:+conLeaf, conBranch :: ConDescr+conLeaf = ConDescr {+  conName = "Leaf",+  conArity = 1, conLabels = [], conFixity = Nonfix+  }+conBranch = ConDescr {+  conName = "Branch",+  conArity = 2, conLabels = [], conFixity = Nonfix+  }++--    More structural definition:+rTree :: Generic g => g a -> g (Tree a)+rTree ra = rtype epTree (rsum (rcon conLeaf (ra)) ((rcon conBranch (rprod (rTree ra) (rTree ra)))))++--    Instance of Rep:+instance (Generic g, Rep g a) => Rep g (Tree a) where+  rep = rTree rep++--    For container types, these should also be specified:+rTree2 :: Generic2 g => g a b -> g (Tree a) (Tree b)+rTree2 ra = rtype2 epTree epTree (rsum2 (rcon2 conLeaf ra) ((rcon2 conBranch (rprod2 (rTree2 ra) (rTree2 ra)))))++rTree3 :: Generic3 g => g a b c -> g (Tree a) (Tree b) (Tree c)+rTree3 ra = rtype3 epTree epTree epTree (rsum3 (rcon3 conLeaf ra) ((rcon3 conBranch (rprod3 (rTree3 ra) (rTree3 ra)))))++instance Generic g => FRep g Tree where+  frep = rTree++instance Generic2 g => FRep2 g Tree where+  frep2 = rTree2++instance Generic3 g => FRep3 g Tree where+  frep3 = rTree3++-- The code to allow your datatypes to be used generically ends here.++-- Some trees to use in the examples+tree1, tree2, tree3 :: Tree Int+tree1 = Leaf 1+tree2 = Branch tree1 (Leaf 2)+tree3 = Branch tree2 (Branch tree2 tree1)++tree4 :: Tree Char+tree4 = Branch (Leaf 'p') (Leaf 'q')++-- A bigger tree created with enum+tree5 :: Tree Bool+tree5 = G.enum !! 1000++-- Showing a tree+example1 = G.show tree3+-- Evaluates to: "Branch (Branch (Leaf 1) (Leaf 2)) (Branch (Branch (Leaf 1) (Leaf 2)) (Leaf 1))"++-- Reading a tree+example2 :: Maybe (Tree Int)+example2 = G.read example1+-- G.show example2 evaluates to: "Just (Branch (Branch (Leaf 1) (Leaf 2)) (Branch (Branch (Leaf 1) (Leaf 2)) (Leaf 1)))"++-- Zipping two trees+example3 = G.zip tree2 tree4+-- G.show example3 evaluates to: "Just (Branch (Leaf (1,'p')) (Leaf (2,'q')))"++-- Flattening a tree+example4 = G.flattenr tree5+-- Evaluates to: [False,False,False,False,False,False,False,False,False,False]++-- Mapping a function over a tree and zipping it with the original tree+example5 = G.zip tree5 (G.map not tree5)+-- G.show example5 evaluates to: "Just (Branch (Branch (Leaf (False,True)) (Branch (Leaf (False,True)) (Branch (Leaf (False,True)) (Leaf (False,True))))) (Branch (Branch (Branch (Leaf (False,True)) (Leaf (False,True))) (Branch (Leaf (False,True)) (Leaf (False,True)))) (Branch (Leaf (False,True)) (Leaf (False,True)))))"+

@@ -0,0 +1,57 @@+{-# LANGUAGE FlexibleContexts           #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Ex03DefiningFunctions+-- Copyright   :  (c) 2008 Universiteit Utrecht+-- License     :  BSD3+--+-- Maintainer  :  generics@haskell.org+--+-- This example module shows how you can use the EMGM library to define your own+-- generic functions. As an example, the function which produces an empty value+-- of a datatype is defined. Several terms are successively defined and their+-- evaluation is shown in a comment after the definition.+--+-----------------------------------------------------------------------------++module Ex03DefiningFunctions where++import Generics.EMGM as G hiding (empty)++-- Defining your own generic functions++-- Empty is a simple generic producer.++-- Type for empty+newtype Empty a = Empty { selEmpty :: a }++-- Instance of Generic+instance Generic Empty where+  rconstant      = error "Unreachable"+  rint           = Empty 0+  rinteger       = Empty 0+  rfloat         = Empty 0+  rdouble        = Empty 0+  rchar          = Empty '\NUL'+  runit          = Empty Unit+  rsum     ra _  = Empty (L (selEmpty ra))+  rprod    ra rb = Empty (selEmpty ra :*: selEmpty rb)+  rcon  _  ra    = Empty (selEmpty ra)+  rtype ep ra    = Empty (to ep (selEmpty ra))++-- This is the function that actually gets used. It returns an "empty" value of+-- a datatype.+empty :: (Rep Empty a) => a+empty = selEmpty rep++-- Examples of using 'empty'++emptyDouble :: Double+emptyDouble = empty+-- Evaluates to: 0.0++emptyList :: (Rep Empty a) => [a]+emptyList = empty+-- (emptyList :: [Int]) evaluates to: []+

@@ -1,34 +1,310 @@------------------------------------------------------------------------------
--- |
--- Module      :  Generics.EMGM
--- Copyright   :  (c) 2008 Universiteit Utrecht
--- License     :  BSD3
---
--- Maintainer  :  generics@haskell.org
--- Stability   :  experimental
--- Portability :  non-portable
---
--- \"Extensible and Modular Generics for the Masses\" --- EMGM.
---
--- This top-level module re-exports all other modules of the
--- Generics.EMGM library.
---
------------------------------------------------------------------------------
-
-module Generics.EMGM (
-
-  -- * Common foundation
-  module Generics.EMGM.Common,
-
-  -- * Generic functions
-  module Generics.EMGM.Functions,
-
-  -- * Supported datatypes
-  module Generics.EMGM.Data,
-
-) where
-
-import Generics.EMGM.Common
-import Generics.EMGM.Functions
-import Generics.EMGM.Data
-
+{-# LANGUAGE CPP                    #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Generics.EMGM+-- Copyright   :  (c) 2008 Universiteit Utrecht+-- License     :  BSD3+--+-- Maintainer  :  generics@haskell.org+-- Stability   :  experimental+-- Portability :  non-portable+--+-- EMGM is \"Extensible and Modular Generics for the Masses,\" a library for+-- datatype-generic programming in Haskell.+--+-- 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.Data" - Datatypes with predefined support in EMGM.+--+-- * "Generics.EMGM.Functions" - Generic functions included with EMGM.+-----------------------------------------------------------------------------++module Generics.EMGM (++  -- * Common Infrastructure+  --+  -- | This is the collection of types, classes, and functions used to define+  -- generic functions and to build representations for datatypes.++  -- ** Datatype Representation+  --+  -- | These are the types and functions required to represent a datatype for+  -- use by generic functions.++  -- *** Structure Representation Types+  --+  -- | 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(..),+  prec,+  minPrec,+  maxPrec,+  appPrec,+  recPrec,++  -- ** Representation Dispatchers+  --+  -- | Type classes simplify the application of generic functions by providing+  -- (a.k.a. \"dispatching\") the appropriate structure representation. These+  -- classes are divided into the kinds they support (monomorphic, functor, and+  -- bifunctor).+  --+  -- Note that the numerical suffix represents the number of generic type+  -- variables used in the generic function. No suffix represents 1 generic type+  -- variable.++  -- *** Monomorphic+  --+  -- | All types of kind @*@ should have an instance here. This includes types+  -- applied to type variables: @[a]@, @'Maybe' a@, @'Either' a b@, etc.++  Rep(..),++  -- *** Functor+  --+  -- | Types of kind @* -> *@ should have an instance here. This includes @[]@,+  -- 'Maybe', etc.++  FRep(..),+  FRep2(..),+  FRep3(..),++  -- *** Bifunctor+  --+  -- | Types of kind @* -> * -> *@ should have an instance here. This includes+  -- @(,)@, 'Either', etc.++  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 simplest way to get a representation for a datatype is using the+  -- following functions 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@.+  --+  -- For more details or more flexibility in what is derived, see+  -- "Generics.EMGM.Common.Derive".++  derive,+  deriveWith,+  Modifier(..),+  Modifiers,++  -- * Generic Functions+  --+  -- | The following collection of functions use the common EMGM infrastructure+  -- to work on all datatypes that have instances for a certain representation+  -- dispatcher. These functions are categorized by the core generic+  -- functionality. For example, 'flattenr' is a type of \"crush\" function,+  -- because it is defined by the 'Generic' instance of the @newtype 'Crush'@.+  --+  -- More information for each of these is available in its respective module.++  -- ** Collect Functions+  --+  -- | Functions that collect values of one type from values of a possibly+  -- different type.+  --+  -- For more details, see "Generics.EMGM.Functions.Collect".++  Collect(..),++  collect,++  -- ** Compare Functions+  --+  -- | 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+  --+  -- | 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+  --+  -- | Functions that enumerate the values of a datatype.+  --+  -- For more details, see "Generics.EMGM.Functions.Enum".++  Enum(..),++  enum,+  enumN,++  empty,++  -- ** Map Functions+  --+  -- | Functions that apply non-generic functions to every element in a+  -- polymorphic (functor or bifunctor) container.+  --+  -- For more details, see "Generics.EMGM.Functions.Map".++  Map(..),++  map,++  replace,++  bimap,++  -- ** Read Functions+  --+  -- | 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+  --+  -- | 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+  --+  -- | Functions that split a polymorphic functor values into two structurally+  -- equilvalent values.+  --+  -- For more details, see "Generics.EMGM.Functions.UnzipWith".++  UnzipWith(..),++  unzip,+  unzipWith,++  -- ** ZipWith Functions+  --+  -- | Functions that combine two structurally equilvalent, polymorphic functor+  -- values into one.+  --+  -- For more details, see "Generics.EMGM.Functions.ZipWith".++  ZipWith(..),++  zip,+  zipWith,++) where++import qualified Prelude++import Generics.EMGM.Common+import Generics.EMGM.Functions++-- Hide the embedding-projection pairs and constructor descriptions. We don't+-- want to export them to the world. We only want the instances.+import Generics.EMGM.Data ()+

@@ -17,6 +17,7 @@   module Generics.EMGM.Common.Base,
   module Generics.EMGM.Common.Base2,
   module Generics.EMGM.Common.Base3,
+  module Generics.EMGM.Common.Derive,
 
 ) where
 
@@ -24,4 +25,5 @@ import Generics.EMGM.Common.Base
 import Generics.EMGM.Common.Base2
 import Generics.EMGM.Common.Base3
+import Generics.EMGM.Common.Derive
 

@@ -101,12 +101,12 @@   -- 'rconstant'.)   runit     :: g Unit -  -- | Case for the structural representation type '(:+:)', called \"sum\". It+  -- | 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 '(:*:)', called \"product\".+  -- | 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)@@ -165,9 +165,8 @@ instance (Generic g, Rep g a, Rep g b) => Rep g (a :*: b) where   rep = rprod rep rep --- | The 'Generic' representation dispatcher for datatypes of functional kind--- @* -> *@, often called container types, type constructors, or functor types.--- (No default implementation.)+-- | 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) 

@@ -34,6 +34,7 @@    -- * Representation dispatcher classes   FRep2(..),+  BiFRep2(..), ) where  import Generics.EMGM.Common.Representation@@ -83,12 +84,12 @@   -- 'rconstant2'.)   runit2     :: g Unit Unit -  -- | Case for the structural representation type '(:+:)', called \"sum\". It+  -- | 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 '(:*:)', called \"product\".+  -- | 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)@@ -116,9 +117,13 @@    rcon2      = const id --- | The 'Generic2' representation dispatcher for datatypes of functional kind--- @* -> *@, often called container types, type constructors, or functor types.--- (No default implementation.)+-- | 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) 

@@ -85,12 +85,12 @@   -- 'rconstant3'.)   runit3     :: g Unit Unit Unit -  -- | Case for the structural representation type '(:+:)', called \"sum\". It+  -- | 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 '(:*:)', called \"product\".+  -- | 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)@@ -118,9 +118,8 @@    rcon3      = const id --- | The 'Generic3' representation dispatcher for datatypes of functional kind--- @* -> *@, often called container types, type constructors, or functor types.--- (No default implementation.)+-- | 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) 

@@ -0,0 +1,538 @@+{-# LANGUAGE CPP                    #-}+{-# LANGUAGE TemplateHaskell        #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Generics.EMGM.Common.Derive+-- Copyright   :  (c) 2008 Universiteit Utrecht+-- License     :  BSD3+--+-- Maintainer  :  generics@haskell.org+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Summary: Functions for generating support for using a datatype with EMGM.+--+-- 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 described here.+-----------------------------------------------------------------------------++module Generics.EMGM.Common.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,++  -- * 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.Common.Derive+  --   data T a = C a Int+  -- @+  --+  -- @+  --   $(declareConDescrs ''T)+  --   $(declareEP ''T)+  --   $(deriveRep ''T)+  --   $(deriveFRep ''T)+  --   $(deriveCollect ''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,++  -- ** 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,++) where++-----------------------------------------------------------------------------+-- Imports+-----------------------------------------------------------------------------++import Prelude++import Language.Haskell.TH+import Data.Maybe (catMaybes)++import Generics.EMGM.Common.Derive.Common++-- 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.Common.Derive.ConDescr (mkConDescr)+import Generics.EMGM.Common.Derive.EP (mkEP)+import Generics.EMGM.Common.Derive.Instance+#endif++-- These are imported only for Haddock.+#ifdef __HADDOCK__+import Generics.EMGM.Common.Base+import Generics.EMGM.Common.Base2+import Generics.EMGM.Common.Base3+import Generics.EMGM.Common.Representation+import Generics.EMGM.Functions.Collect+#endif++-----------------------------------------------------------------------------+-- 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)++deriveRepBase :: DT -> Name  -> Name  -> Q [Dec]+deriveRepBase dt epName g = do+  return [mkRepInst epName g dt]++deriveFRepBase :: DT -> Name -> Name -> Name -> Q [Dec]+deriveFRepBase dt epName g ra =+  return [frepInstDec, frep2InstDec, frep3InstDec]+  where+    frepInstDec  = mkFRepInst  ra epName g dt+    frep2InstDec = mkFRep2Inst ra epName g dt+    frep3InstDec = mkFRep3Inst ra epName g dt++deriveBiFRepBase :: DT -> Name -> Name -> Name -> Name -> Q [Dec]+deriveBiFRepBase dt epName g ra rb =+  return [mkBiFRep2Inst ra rb epName 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++  g <- newName "g"+  repInstDecs <- deriveRepBase dt epName g++  ra <- newName "ra"+  frepInstDecs <- deriveFRepBase dt epName g ra++  rb <- newName "rb"+  bifrepInstDecs <- deriveBiFRepBase dt epName g ra rb++  let higherOrderRepInstDecs =+        case length (tvars dt) of+          1 -> frepInstDecs+          2 -> bifrepInstDecs+          _ -> []++  collectInstDec <- mkRepCollectInst dt++  return $+    conDescrDecs           +++    epDecs                 +++    repInstDecs            +++    higherOrderRepInstDecs +++    [collectInstDec]++#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"+--   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 (1 per constructor)+-- @+--+-- @+--   conC :: 'ConDescr'+--   conC = 'ConDescr' \"C\" 2 [] 'Nonfix'+-- @+--+-- @+--   -- (2) Embedding-projection pair declarations (1 per type)+-- @+--+-- @+--   epT :: 'EP' (T a) (a :*: 'Int')+--   epT = 'EP' fromT toT+--     where fromT (C v1 v2) = v1 :*: v2+--           toT (v1 :*: v2) = C v1 v2+-- @+--+-- @+--   -- (3) 'Rep' instance (1 per type)+-- @+--+-- @+--   instance ('Generic' g, 'Rep' g a, 'Rep' g 'Int') => 'Rep' g (T a) where+--     'rep' = 'rtype' epT ('rcon' conC ('rprod' 'rep' 'rep'))+-- @+--+-- @+--   -- (4) Higher arity instances if applicable (either 'FRep', 'FRep2', and+--   -- 'FRep3' together, or 'BiFRep2')+-- @+--+-- @+--   instance ('Generic' g) => 'FRep' g T where+--     'frep' ra = 'rtype' epT ('rcon' conC ('rprod' ra 'rint'))+-- @+--+-- @+--   -- In this case, similar instances would be generated for 'FRep2' and 'FRep3'.+-- @+--+-- @+--   -- (5) Function-specific instances (1 per type)+-- @+--+-- @+--   instance 'Rep' ('Collect' 'Char') 'Char' where+--     'rep' = 'Collect' (:[])+-- @+--+-- Note that the constructor description @conC@ and embedding-project pair @epT@+-- are top-level values. This allows them to be shared between multiple+-- instances. If these names conflict with your own, you may want to put the+-- @$(derive ...)@ declaration in its own module and restrict the export list.+derive :: Name -> Q [Dec]+derive = deriveWith []++--------------------------------------------------------------------------------++-- | 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 '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+  (epName, _) <- declareEPBase mods dt+  g <- newName "g"+  repInstDecs <- deriveRepBase dt epName 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 '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+  g <- newName "g"+  ra <- newName "ra"+  frepInstDecs <- deriveFRepBase dt epName g ra+  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+  g <- newName "g"+  ra <- newName "ra"+  rb <- newName "rb"+  bifrepInstDecs <- deriveBiFRepBase dt epName g ra rb+  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+

@@ -0,0 +1,147 @@+{-# LANGUAGE CPP                    #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Generics.EMGM.Common.Derive+-- Copyright   :  (c) 2008 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.Common.Derive.Common where++-----------------------------------------------------------------------------+-- Imports+-----------------------------------------------------------------------------++import Language.Haskell.TH+import Data.Maybe (fromMaybe)++-----------------------------------------------------------------------------+-- 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)]++-----------------------------------------------------------------------------+-- 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 ""+

@@ -0,0 +1,113 @@+{-# LANGUAGE CPP                    #-}+{-# LANGUAGE TemplateHaskell        #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Generics.EMGM.Common.Derive.ConDescr+-- Copyright   :  (c) 2008 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.Common.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.Common.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+

@@ -0,0 +1,155 @@+{-# LANGUAGE CPP                    #-}+{-# LANGUAGE TemplateHaskell        #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Generics.EMGM.Common.Derive.EP+-- Copyright   :  (c) 2008 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.Common.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.Common.Derive.Common++-----------------------------------------------------------------------------+-- General functions+-----------------------------------------------------------------------------++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 :: NCon -> Exp+dataE (NCon name _ _ vars) = foldl (\e -> AppE e . VarE) (ConE name) vars++dataP :: NCon -> Pat+dataP (NCon name _ _ vars) = ConP name (map VarP vars)++--------------------------------------------------------------------------------++-- | 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)++--------------------------------------------------------------------------------++-- | Map constructors to syntax elements for datatypes+consDatas :: (NCon -> a) -> [NCon] -> [a]+consDatas mkData = map mkData++-- | 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 (consDatas dataP) (consReps unitE prodE VarE sumE)+toClauses   = consClauses (consReps unitP prodP VarP sumP) (consDatas dataE)++-- | 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 funName = FunD funName (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+

@@ -0,0 +1,295 @@+{-# LANGUAGE CPP                        #-}+{-# LANGUAGE TemplateHaskell            #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE MultiParamTypeClasses      #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Generics.EMGM.Common.Derive+-- Copyright   :  (c) 2008 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.Common.Derive.Instance (+#ifndef __HADDOCK__+  mkRepInst,+  mkFRepInst,+  mkFRep2Inst,+  mkFRep3Inst,+  mkBiFRep2Inst,+  mkRepCollectInst,+#endif+) where++#ifndef __HADDOCK__++-----------------------------------------------------------------------------+-- Imports+-----------------------------------------------------------------------------++import Data.List (nub)+import Language.Haskell.TH++import Generics.EMGM.Common.Base+import Generics.EMGM.Common.Base2+import Generics.EMGM.Common.Base3+import Generics.EMGM.Common.Derive.Common++import Generics.EMGM.Functions.Collect++-----------------------------------------------------------------------------+-- Types+-----------------------------------------------------------------------------++data RepOpt = OptRep | OptFRep Name | OptFRep2 Name | OptFRep3 Name | OptBiFRep2 Name Name+  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'+  }++-----------------------------------------------------------------------------+-- General functions+-----------------------------------------------------------------------------++-- | 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++-- | 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++-- Given a name for a constant type and the rep option, get an appropriate+-- expression name.+conTypeExpName :: Name -> RepOpt -> Name+conTypeExpName typeName =+  case nameBase typeName of+    "Int"     -> rintN+    "Integer" -> rintegerN+    "Float"   -> rfloatN+    "Double"  -> rdoubleN+    "Char"    -> rcharN+    n         -> error $ "Error! Unsupported constant type: " ++ n++typeUnknownError :: Type -> a+typeUnknownError t = error $ "Error! Unsupported type: " ++ pprint t++-- | When defining a representation with one type variable (e.g. 'frep',+-- 'frep2', 'frep3'), find the expression that will represent the given 'Type'+-- value.+--+-- Note that this may be changed to support a larger variety of types.+var1Exp :: Name -> RepOpt -> Type -> Exp+var1Exp typeVarName opt = toExp+  where+    toExp (AppT (ConT _) arg) = AppE (VarE (repN opt)) (toExp arg)+    toExp (ConT typeName)     = VarE (conTypeExpName typeName opt)+    toExp (VarT _)            = VarE typeVarName+    toExp t                   = typeUnknownError t++-- | When defining a representation with two type variables (e.g. 'bifrep2'),+-- find the expression that will represent the given 'Type' value.+--+-- Note that this may be changed to support a larger variety of types.+var2Exp :: Name -> Name -> RepOpt -> DT -> Type -> Exp+var2Exp name1 name2 opt dt = toExp+  where+    toExp (AppT (AppT (ConT _) arg1) arg2) = app2 arg1 arg2+    toExp (ConT typeName)                  = VarE (conTypeExpName typeName opt)+    toExp t@(VarT name) | name == tv1      = VarE name1+                        | name == tv2      = VarE name2+                        | otherwise        = typeUnknownError t+    toExp t                                = typeUnknownError t+    tv1:tv2:_ = tvars dt+    app2 arg1 arg2 = AppE (AppE (VarE (repN opt)) (toExp arg1)) (toExp arg2)++-- | Produce the variable expression for the appropriate 'rep', 'frep', etc.+varRepExp :: RepOpt -> DT -> Type -> Exp+varRepExp opt dt t =+  case opt of+    OptRep                 -> VarE (repN opt)+    OptFRep name           -> var1Exp name opt t+    OptFRep2 name          -> var1Exp name opt t+    OptFRep3 name          -> var1Exp name opt t+    OptBiFRep2 name1 name2 -> var2Exp name1 name2 opt dt t++-- | Construct the lambda abstraction for the appropriate 'rep', 'frep', etc.+repLamE :: RepOpt -> Exp -> Exp+repLamE OptRep                   = id+repLamE (OptFRep name)           = LamE [VarP name]+repLamE (OptFRep2 name)          = LamE [VarP name]+repLamE (OptFRep3 name)          = LamE [VarP name]+repLamE (OptBiFRep2 name1 name2) = LamE [VarP name1, VarP name2]++-- | Type constructor arity: The number of type variables to remove in an+-- instance type.+typeArity :: RepOpt -> Int+typeArity OptRep           = 0+typeArity (OptFRep _)      = 1+typeArity (OptFRep2 _)     = 1+typeArity (OptFRep3 _)     = 1+typeArity (OptBiFRep2 _ _) = 2++-- | Construct the expression for the appropriate 'rtype', 'rtype2', etc.+rtypeE :: RepOpt -> Name -> Exp -> Exp+rtypeE opt epName sopE =+  case opt of+    OptRep           -> appToSop ep1+    (OptFRep _)      -> appToSop ep1+    (OptFRep2 _)     -> appToSop ep2+    (OptFRep3 _)     -> appToSop ep3+    (OptBiFRep2 _ _) -> appToSop ep2+  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 :: RepOpt -> DT -> Exp+repSopE opt dt = mkSopDT inject unit mkSum mkProd wrapProd dt+  where+    mkSum = AppE . AppE (VarE $ rsumN opt)+    mkProd = AppE . AppE (VarE $ rprodN opt)+    unit = VarE $ runitN opt+    inject = varRepExp opt dt+    wrapProd ncon = AppE (AppE (VarE (rconN opt)) (VarE (cdescr ncon)))++-- | Make the declaration of the value for the rep instance+mkRepD :: RepOpt -> Name -> DT -> Dec+mkRepD opt epName dt = ValD (VarP (repN opt)) (NormalB (lamExp rtypeExp)) []+  where+    sopExp = repSopE opt dt+    rtypeExp = rtypeE opt epName sopExp+    lamExp = repLamE opt++--------------------------------------------------------------------------------++mkGenericT :: RepOpt -> Type -> Type+mkGenericT opt = AppT (ConT (genericCN opt))++mkRepT :: RepOpt -> Type -> Type -> Type+mkRepT opt funType = AppT (AppT (ConT (repCN opt)) funType)++-- | Make the rep instance context+mkRepInstCxt :: RepOpt -> Type -> [NCon] -> Cxt+mkRepInstCxt opt funType = insGeneric . checkRepOpt . addRepCxt+  where+    -- Build a list of the 'Rep' class constraints+    addRepCxt = nub . toRepCxt . toConArgTypes+    toConArgTypes = concatMap cargtypes+    toRepCxt = map $ mkRepT opt funType++    -- Only allow the actual 'Rep' class constraints, not one of the 'FRep'+    -- classes+    checkRepOpt = if opt == OptRep then id else const []++    -- Insert the 'Generic' class constraint+    insGeneric = (:) $ mkGenericT opt funType++dropLast :: Int -> [a] -> [a]+dropLast n xs = if len > n then take (len - n) xs else []+  where+    len = length xs++-- | Make a type as applied to its type variables (if any) from a DT+mkAppliedType :: RepOpt -> DT -> Type+mkAppliedType opt dt = appTypeCon varTypes+  where+    appTypeCon = foldl AppT (ConT (tname dt)) . dropLast (typeArity opt)+    varTypes = map VarT (tvars dt)++-- | Make the rep instance type+mkRepInstT :: RepOpt -> DT -> Type -> Type+mkRepInstT opt dt funType = mkRepT opt funType (mkAppliedType opt dt)++-- | Make the instance for a representation type class+mkRepInstWith :: RepOpt -> Name -> Name -> DT -> Dec+mkRepInstWith opt epName g dt = InstanceD cxt' typ [dec]+  where+    gVar = VarT g+    cxt' = mkRepInstCxt opt gVar (ncons dt)+    typ = mkRepInstT opt dt gVar+    dec = mkRepD opt epName dt++-----------------------------------------------------------------------------+-- Exported Functions+-----------------------------------------------------------------------------++-- | Make the instance for 'Rep'+mkRepInst :: Name -> Name -> DT -> Dec+mkRepInst = mkRepInstWith OptRep++-- | Make the instance for 'FRep'+mkFRepInst :: Name -> Name -> Name -> DT -> Dec+mkFRepInst = mkRepInstWith . OptFRep++-- | Make the instance for 'FRep2'+mkFRep2Inst :: Name -> Name -> Name -> DT -> Dec+mkFRep2Inst = mkRepInstWith . OptFRep2++-- | Make the instance for 'FRep3'+mkFRep3Inst :: Name -> Name -> Name -> DT -> Dec+mkFRep3Inst = mkRepInstWith . OptFRep3++-- | Make the instance for 'BiFRep2'+mkBiFRep2Inst :: Name -> Name -> Name -> Name -> DT -> Dec+mkBiFRep2Inst ra rb = mkRepInstWith (OptBiFRep2 ra rb)++-- | Make the instance for a Rep Collect T (where T is the type)+mkRepCollectInst :: DT -> Q Dec+mkRepCollectInst dt = do+  let t = mkAppliedType OptRep dt+  let typ = mkRepInstT OptRep dt (AppT (ConT ''Collect) t)+  e <- [|Collect (\x -> [x])|]+  let dec = ValD (VarP 'rep) (NormalB e) []+  return $ InstanceD [] typ [dec]++#endif+

@@ -1,3 +1,4 @@+ ----------------------------------------------------------------------------- -- | -- Module      :  Generics.EMGM.Common.Representation@@ -11,7 +12,7 @@ -- 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+-- '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.@@ -29,24 +30,31 @@  module Generics.EMGM.Common.Representation ( -  -- * Structure representation-  -- | The generic sum-of-products view of a Haskell datatype.+  -- * Structure Representation+  --+  -- | The unit, sum, and product types form the sum-of-products view for a+  -- Haskell datatype.    Unit(..),   (:+:)(..),   (:*:)(..), -  -- * Constructor description-  -- | Since this library does not have access to the syntax of a @data@-  -- declaration, it relies on 'ConDescr' for meta-information. It is-  -- important that the 'ConDescr' for a constructor accurately describe the-  -- actual syntax in the declaration. An incorrect description may lead to-  -- bad 'Read' or 'Show' operation.+  -- * 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+  -- * 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. @@ -58,10 +66,6 @@   appPrec,   recPrec, -  -- * Embedding-projection pair--  EP(..),-   ) where  import Text.ParserCombinators.ReadPrec (minPrec, Prec)@@ -69,10 +73,10 @@ infixr 5 :+: infixr 6 :*: --- | 'Unit' encodes a constructor with no arguments. An analogous standard+-- | The \"unit\" encodes a constructor with no arguments. An analogous standard -- Haskell type is @()@. data Unit-  = Unit -- ^ The only value of type 'Unit' (ignoring @_|_@).+  = 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@@ -101,9 +105,9 @@   = a :*: b -- ^ A pair of arguments   deriving (Eq, Ord, Read, Show) --- | The Embedding-Projection pair contains two functions for converting between--- the datatype and its representation. This pair preserves an isomorphism--- (ignoring @_|_@s) between a datatype and its structure.+-- | 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.@@ -113,6 +117,10 @@ -- | 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,@@ -127,7 +135,7 @@      , conFixity   :: Fixity   -- ^ Infix or not, associativity, precedence.     }-  deriving Show+  deriving (Eq, Show)  -- | The constructor type used in 'Read' and 'Show' to determine how to parse or -- print the constructor.@@ -135,14 +143,16 @@   = ConStd             -- ^ Standard (function-type, nonfix)   | ConRec [String]    -- ^ Record-style (nonfix or infix)   | ConIfx String      -- ^ Infix (no record syntax)-  deriving Show+  deriving (Eq, Show)  -- TODO: Need smart constructor(s) for ConDescr, so we can verify things. --- | Determine an identifier's status as infix or not. If infix, the--- associativity and precedence are also determined.+-- | 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. Precedence is same as function application (see 'appPrec').+  = 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.

@@ -8,7 +8,7 @@ -- Stability   :  experimental
 -- Portability :  non-portable
 --
--- Exports all modules in the Generics.EMGM.Data.* hierarchy.
+-- Exports all modules in Generics.EMGM.Data.* for convenience.
 -----------------------------------------------------------------------------
 
 module Generics.EMGM.Data (
@@ -18,6 +18,7 @@   module Generics.EMGM.Data.List,
   module Generics.EMGM.Data.Maybe,
   module Generics.EMGM.Data.Tuple,
+  module Generics.EMGM.Data.TH,
 
 ) where
 
@@ -26,4 +27,5 @@ import Generics.EMGM.Data.List
 import Generics.EMGM.Data.Maybe
 import Generics.EMGM.Data.Tuple
+import Generics.EMGM.Data.TH
 

@@ -1,8 +1,12 @@+{-# LANGUAGE CPP                    #-}+{-# LANGUAGE TemplateHaskell        #-}+{-# LANGUAGE TypeOperators          #-} {-# LANGUAGE FlexibleInstances      #-} {-# LANGUAGE MultiParamTypeClasses  #-}-{-# LANGUAGE TypeOperators          #-} {-# LANGUAGE OverlappingInstances   #-}+{-# LANGUAGE UndecidableInstances   #-} {-# OPTIONS -fno-warn-orphans       #-}+{-  OPTIONS -ddump-splices           -}  ----------------------------------------------------------------------------- -- |@@ -16,26 +20,29 @@ -- -- Summary: Generic representation and instances for 'Bool'. ----- This module exports the reusable components of the 'Bool'--- representation. These include the embedding-projection pair used in a type--- representation as well as the type representation of 'Bool' for--- 'Generic'.------ This module also exports the instance for the representation dispatcher--- 'Rep'.+-- 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. -----------------------------------------------------------------------------  module Generics.EMGM.Data.Bool (--  -- * Embedding-projection pair   epBool,--  -- * Representation-  rBool,+  conFalse,+  conTrue, ) where  import Generics.EMGM.Common+import Generics.EMGM.Functions.Collect +#ifndef __HADDOCK__++$(derive ''Bool)++#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.+ ----------------------------------------------------------------------------- -- Embedding-projection pair -----------------------------------------------------------------------------@@ -48,7 +55,7 @@ toBool (L Unit) = False toBool (R Unit) = True --- | Embedding-projection pair for @Bool@+-- | Embedding-projection pair for 'Bool' epBool :: EP Bool (Unit :+: Unit) epBool = EP fromBool toBool @@ -56,11 +63,15 @@ -- Representation values ----------------------------------------------------------------------------- -conFalse, conTrue :: ConDescr+-- | Constructor description for 'False'+conFalse :: ConDescr conFalse = ConDescr "False" 0 [] Nonfix-conTrue  = ConDescr "True"  0 [] Nonfix --- | Representation for @Bool@ in 'Generic'+-- | Constructor description for 'True'+conTrue :: ConDescr+conTrue = ConDescr "True" 0 [] Nonfix++-- | Representation for 'Bool' in 'Generic' rBool :: (Generic g) => g Bool rBool = rtype epBool (rcon conFalse runit `rsum` rcon conTrue runit) @@ -70,4 +81,9 @@  instance (Generic g) => Rep g Bool where   rep = rBool++instance Rep (Collect Bool) Bool where+  rep = Collect (:[])++#endif 

@@ -1,8 +1,12 @@+{-# LANGUAGE CPP                    #-}+{-# LANGUAGE TemplateHaskell        #-}+{-# LANGUAGE TypeOperators          #-} {-# LANGUAGE FlexibleInstances      #-} {-# LANGUAGE MultiParamTypeClasses  #-}-{-# LANGUAGE TypeOperators          #-} {-# LANGUAGE OverlappingInstances   #-}+{-# LANGUAGE UndecidableInstances   #-} {-# OPTIONS -fno-warn-orphans       #-}+{-  OPTIONS -ddump-splices           -}  ----------------------------------------------------------------------------- -- |@@ -14,28 +18,31 @@ -- Stability   :  experimental -- Portability :  non-portable ----- Summary: Generic representation and instances for @'Either' a b@.------ This module exports the reusable components of the @'Either' a b@--- representation. These include the embedding-projection pair used in a type--- representation as well as the type representation of @'Either' a b@ for--- 'Generic'.+-- Summary: Generic representation and instances for 'Either'. ----- This module also exports the instance for the representation dispatcher--- 'Rep'.+-- The main purpose of this module is to export the instances for the+-- representation dispatchers 'Rep' and 'BiFRep2'. For the rare cases in which+-- it is needed, this module also exports the embedding-projection pair and+-- constructor description. -----------------------------------------------------------------------------  module Generics.EMGM.Data.Either (--  -- * Embedding-projection pair   epEither,--  -- * Representation-  rEither,+  conLeft,+  conRight, ) where  import Generics.EMGM.Common+import Generics.EMGM.Functions.Collect +#ifndef __HADDOCK__++$(derive ''Either)++#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.+ ----------------------------------------------------------------------------- -- Embedding-projection pair -----------------------------------------------------------------------------@@ -48,7 +55,7 @@ toEither (L a) = Left a toEither (R b) = Right b --- | Embedding-projection pair for @Either a b@+-- | Embedding-projection pair for 'Either' epEither :: EP (Either a b) (a :+: b) epEither = EP fromEither toEither @@ -56,8 +63,12 @@ -- Representation values ----------------------------------------------------------------------------- -conLeft, conRight :: ConDescr-conLeft  = ConDescr "Left"  1 [] Nonfix+-- | Constructor description for 'Left'+conLeft :: ConDescr+conLeft = ConDescr "Left" 1 [] Nonfix++-- | Constructor description for 'Right'+conRight :: ConDescr conRight = ConDescr "Right" 1 [] Nonfix  -- | Representation for @Either a b@ in 'Generic'@@ -70,4 +81,14 @@  instance (Generic g, Rep g a, Rep g b) => Rep g (Either a b) where   rep = rEither rep rep++instance (Generic2 g) => BiFRep2 g Either where+  bifrep2 ra rb =+    rtype2 epEither epEither $+      rcon2 conLeft ra `rsum2` rcon2 conRight rb++instance Rep (Collect (Either a b)) (Either a b) where+  rep = Collect (:[])++#endif 

@@ -14,29 +14,22 @@ -- Stability   :  experimental -- Portability :  non-portable ----- Summary: Generic representation and instances for @[a]@.------ This module exports the reusable components of the @[a]@ representation.--- These include the embedding-projection pair used in a type representation as--- well as the type representations of @[a]@ for 'Generic', 'Generic2', and--- 'Generic3'.+-- Summary: Generic representation and instances for lists. ----- This module also exports the instances for the representation dispatchers--- 'Rep', 'FRep', 'FRep2', and 'FRep3'.+-- The main purpose of this module is to export the instances for the+-- representation dispatchers 'Rep', 'FRep', 'FRep2', and 'FRep3'. For the rare+-- cases in which it is needed, this module also exports the+-- embedding-projection pair and constructor description. -----------------------------------------------------------------------------  module Generics.EMGM.Data.List (--  -- * Embedding-projection pair   epList,--  -- * Representations-  rList,-  rList2,-  rList3+  conNil,+  conCons, ) where  import Generics.EMGM.Common+import Generics.EMGM.Functions.Collect  ----------------------------------------------------------------------------- -- Embedding-projection pair@@ -50,7 +43,7 @@ toList (L Unit)        =  [] toList (R (a :*: as))  =  a : as --- | Embedding-projection pair for @[a]@+-- | Embedding-projection pair for lists epList :: EP [a] (Unit :+: (a :*: [a])) epList = EP fromList toList @@ -58,23 +51,27 @@ -- Representation values ----------------------------------------------------------------------------- -conNil, conCons :: ConDescr-conNil  = ConDescr "[]" 0 [] Nonfix-conCons = ConDescr ":"  2 [] (Infixr 5)+-- | Constructor description for ''nil'': @[]@+conNil :: ConDescr+conNil = ConDescr "[]" 0 [] Nonfix --- | Representation for @[a]@ in 'Generic'+-- | Constructor description for ''cons'': @(:)@+conCons :: ConDescr+conCons = ConDescr ":" 2 [] (Infixr 5)++-- | Representation for lists in 'Generic' rList :: (Generic g) => g a -> g [a] rList ra =   rtype epList     (rcon conNil runit `rsum` rcon conCons (ra `rprod` rList ra)) --- | Representation for @[a]@ in 'Generic2'+-- | Representation for lists in 'Generic2' rList2 :: (Generic2 g) => g a b -> g [a] [b] rList2 ra =   rtype2 epList epList     (rcon2 conNil runit2 `rsum2` rcon2 conCons (ra `rprod2` rList2 ra)) --- | Representation for @[a]@ in 'Generic3'+-- | Representation for lists in 'Generic3' rList3 :: (Generic3 g) => g a b c -> g [a] [b] [c] rList3 ra =   rtype3 epList epList epList@@ -95,4 +92,7 @@  instance (Generic3 g) => FRep3 g [] where   frep3 = rList3++instance Rep (Collect [a]) [a] where+  rep = Collect (:[]) 

@@ -1,8 +1,12 @@+{-# LANGUAGE CPP                    #-}+{-# LANGUAGE TemplateHaskell        #-}+{-# LANGUAGE TypeOperators          #-} {-# LANGUAGE FlexibleInstances      #-} {-# LANGUAGE MultiParamTypeClasses  #-}-{-# LANGUAGE TypeOperators          #-} {-# LANGUAGE OverlappingInstances   #-}+{-# LANGUAGE UndecidableInstances   #-} {-# OPTIONS -fno-warn-orphans       #-}+{-  OPTIONS -ddump-splices           -}  ----------------------------------------------------------------------------- -- |@@ -14,31 +18,31 @@ -- Stability   :  experimental -- Portability :  non-portable ----- Summary: Generic representation and instances for @'Maybe' a@.------ This module exports the reusable components of the @'Maybe' a@ representation.--- These include the embedding-projection pair used in a type representation as--- well as the type representations of @'Maybe' a@ for 'Generic', 'Generic2',--- and 'Generic3'.------ This module also exports the instances for the representation dispatchers--- 'Rep', 'FRep', 'FRep2', and 'FRep3'.+-- Summary: Generic representation and instances for 'Maybe'. --+-- The main purpose of this module is to export the instances for the+-- representation dispatchers 'Rep', 'FRep', 'FRep2', and 'FRep3'. For the rare+-- cases in which it is needed, this module also exports the+-- embedding-projection pair and constructor description. -----------------------------------------------------------------------------  module Generics.EMGM.Data.Maybe (--  -- * Embedding-projection pair   epMaybe,--  -- * Representations-  rMaybe,-  rMaybe2,-  rMaybe3,+  conNothing,+  conJust, ) where  import Generics.EMGM.Common+import Generics.EMGM.Functions.Collect +#ifndef __HADDOCK__++$(derive ''Maybe)++#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.+ ----------------------------------------------------------------------------- -- Embedding-projection pair -----------------------------------------------------------------------------@@ -51,7 +55,7 @@ toMaybe (L Unit)  =  Nothing toMaybe (R a)     =  Just a --- | Embedding-projection pair for @Maybe a@+-- | Embedding-projection pair for 'Maybe' epMaybe :: EP (Maybe a) (Unit :+: a) epMaybe = EP fromMaybe toMaybe @@ -59,10 +63,14 @@ -- Representation values ----------------------------------------------------------------------------- -conNothing, conJust :: ConDescr+-- | Constructor description for 'Nothing'+conNothing :: ConDescr conNothing = ConDescr "Nothing" 0 [] Nonfix-conJust    = ConDescr "Just"    1 [] Nonfix +-- | Constructor description for 'Just'+conJust :: ConDescr+conJust = ConDescr "Just" 1 [] Nonfix+ -- | Representation for @Maybe a@ in 'Generic' rMaybe :: (Generic g) => g a -> g (Maybe a) rMaybe ra =@@ -96,4 +104,9 @@  instance (Generic3 g) => FRep3 g Maybe where   frep3 = rMaybe3++instance Rep (Collect (Maybe a)) (Maybe a) where+  rep = Collect (:[])++#endif 

@@ -0,0 +1,71 @@+{-# 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 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.Common hiding (Fixity, ConDescr(..))+import Language.Haskell.TH++#ifndef __HADDOCK__++$(derive ''Name)+$(derive ''Dec)+$(derive ''Exp)+$(derive ''Con)+$(derive ''Type)+$(derive ''Match)+$(derive ''Clause)+$(derive ''Body)+$(derive ''Guard)+$(derive ''Stmt)+$(derive ''Range)+$(derive ''Lit)+$(derive ''Pat)+$(derive ''Strict)+$(derive ''Foreign)+$(derive ''Callconv)+$(derive ''Safety)+$(derive ''FunDep)+$(derive ''Info)++#ifdef TH_LOC_DERIVEREP+-- This type is only provided in template-haskell-2.3 (included with GHC 6.10)+-- and up.+$(derive ''Loc)+#endif++$(derive ''Fixity)+$(derive ''FixityDirection)++#endif+

@@ -15,38 +15,48 @@ -- Portability :  non-portable -- -- Summary: Generic representation and instances for tuples of arity 0--- (a.k.a. unit) and 2 to 7.------ This module exports the reusable components of tuple representations. These--- include the embedding-projection pair used in a type representation as well--- as the type representations for 'Generic'.+-- (''unit'') and 2 to 7. ----- This module also exports the instances for the representation dispatcher--- 'Rep'.+-- The main purpose of this module is to export the instances for the+-- representation dispatchers, 'Rep' and (where appropriate) 'BiFRep2'. For the+-- rare cases in which it is needed, this module also exports the+-- embedding-projection pair and constructor description. -----------------------------------------------------------------------------  module Generics.EMGM.Data.Tuple ( -  -- * Embedding-projection pairs+  -- * Unit: @()@   epTuple0,+  conTuple0,++  -- * Pair: @(a,b)@   epTuple2,+  conTuple2,++  -- * Triple: @(a,b,c)@   epTuple3,+  conTuple3,++  -- * Quadruple: @(a,b,c,d)@   epTuple4,+  conTuple4,++  -- * Quintuple: @(a,b,c,d,e)@   epTuple5,+  conTuple5,++  -- * Sextuple: @(a,b,c,d,e,f)@   epTuple6,+  conTuple6,++  -- * Septuple: @(a,b,c,d,e,f,h)@   epTuple7,+  conTuple7, -  -- * Representations-  rTuple0,-  rTuple2,-  rTuple3,-  rTuple4,-  rTuple5,-  rTuple6,-  rTuple7, ) where  import Generics.EMGM.Common+import Generics.EMGM.Functions.Collect  ----------------------------------------------------------------------------- -- 0: ()@@ -57,11 +67,12 @@ epTuple0 = EP (\() -> Unit)               (\Unit -> ()) +-- | Constructor description for @()@ conTuple0 :: ConDescr conTuple0 = ConDescr "()" 0 [] Nonfix  -- | Representation for @()@ in 'Generic'-rTuple0 :: Generic g => g ()+rTuple0 :: (Generic g) => g () rTuple0 =   rtype epTuple0 $         rcon conTuple0 runit@@ -75,15 +86,22 @@ epTuple2 = EP (\(a,b) -> a :*: b)               (\(a :*: b) -> (a,b)) +-- | Constructor description for @(a,b)@ conTuple2 :: ConDescr conTuple2 = ConDescr "(,)" 2 [] Nonfix  -- | Representation for @(a,b)@ in 'Generic'-rTuple2 :: Generic g => g a -> g b -> g (a,b)+rTuple2 :: (Generic g) => g a -> g b -> g (a,b) rTuple2 ra rb =   rtype epTuple2 $         rcon conTuple2 (ra `rprod` rb) +-- | Representation for @(,)@ in 'Generic2'+rTuple2_2 :: (Generic2 g) => g a c -> g b d -> g (a,b) (c,d)+rTuple2_2 ra rb =+  rtype2 epTuple2 epTuple2 $+         rcon2 conTuple2 (ra `rprod2` rb)+ ----------------------------------------------------------------------------- -- 3: (a,b,c) -----------------------------------------------------------------------------@@ -93,11 +111,12 @@ epTuple3 = EP (\(a,b,c) -> a :*: b :*: c)               (\(a :*: b :*: c) -> (a,b,c)) +-- | Constructor description for @(a,b,c)@ conTuple3 :: ConDescr conTuple3 = ConDescr "(,,)" 3 [] Nonfix  -- | Representation for @(a,b,c)@ in 'Generic'-rTuple3 :: Generic g => g a -> g b -> g c -> g (a,b,c)+rTuple3 :: (Generic g) => g a -> g b -> g c -> g (a,b,c) rTuple3 ra rb rc =   rtype epTuple3 $         rcon conTuple3 (ra `rprod` rb `rprod` rc)@@ -111,11 +130,12 @@ epTuple4 = EP (\(a,b,c,d) -> a :*: b :*: c :*: d)               (\(a :*: b :*: c :*: d) -> (a,b,c,d)) +-- | Constructor description for @(a,b,c,d)@ conTuple4 :: ConDescr conTuple4 = ConDescr "(,,,)" 4 [] Nonfix  -- | Representation for @(a,b,c,d)@ in 'Generic'-rTuple4 :: Generic g => g a -> g b -> g c -> g d -> g (a,b,c,d)+rTuple4 :: (Generic g) => g a -> g b -> g c -> g d -> g (a,b,c,d) rTuple4 ra rb rc rd =   rtype epTuple4 $         rcon conTuple4 (ra `rprod` rb `rprod` rc `rprod` rd)@@ -129,11 +149,12 @@ epTuple5 = EP (\(a,b,c,d,e) -> a :*: b :*: c :*: d :*: e)               (\(a :*: b :*: c :*: d :*: e) -> (a,b,c,d,e)) +-- | Constructor description for @(a,b,c,d,e)@ conTuple5 :: ConDescr conTuple5 = ConDescr "(,,,,)" 5 [] Nonfix  -- | Representation for @(a,b,c,d,e)@ in 'Generic'-rTuple5 :: Generic g => g a -> g b -> g c -> g d -> g e -> g (a,b,c,d,e)+rTuple5 :: (Generic g) => g a -> g b -> g c -> g d -> g e -> g (a,b,c,d,e) rTuple5 ra rb rc rd re =   rtype epTuple5 $         rcon conTuple5 (ra `rprod` rb `rprod` rc `rprod` rd `rprod` re)@@ -147,11 +168,12 @@ 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)) +-- | Constructor description for @(a,b,c,d,e,f)@ conTuple6 :: ConDescr conTuple6 = ConDescr "(,,,,,)" 6 [] Nonfix  -- | Representation for @(a,b,c,d,e,f)@ in 'Generic'-rTuple6 :: Generic g => g a -> g b -> g c -> g d -> g e -> g f -> g (a,b,c,d,e,f)+rTuple6 :: (Generic g) => g a -> g b -> g c -> g d -> g e -> g f -> g (a,b,c,d,e,f) rTuple6 ra rb rc rd re rf =   rtype epTuple6 $         rcon conTuple6 (ra `rprod` rb `rprod` rc `rprod` rd `rprod` re `rprod` rf)@@ -166,11 +188,12 @@ 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)) +-- | Constructor description for @(a,b,c,d,e,f,h)@ conTuple7 :: ConDescr conTuple7 = ConDescr "(,,,,,)" 7 [] Nonfix  -- | Representation for @(a,b,c,d,e,f,h)@ in 'Generic'-rTuple7 :: Generic g => g a -> g b -> g c -> g d -> g e -> g f -> g h -> g (a,b,c,d,e,f,h)+rTuple7 :: (Generic g) => g a -> g b -> g c -> g d -> g e -> g f -> g h -> g (a,b,c,d,e,f,h) rTuple7 ra rb rc rd re rf rh =   rtype epTuple7 $         rcon conTuple7 (ra `rprod` rb `rprod` rc `rprod` rd `rprod` re `rprod` rf `rprod` rh)@@ -200,4 +223,27 @@ instance (Generic g, Rep g a, Rep g b, Rep g c, Rep g d, Rep g e, Rep g f, Rep g h) => Rep g (a,b,c,d,e,f,h) where   rep = rTuple7 rep rep rep rep rep rep rep +instance (Generic2 g) => BiFRep2 g (,) where+  bifrep2 = rTuple2_2++instance Rep (Collect ()) () where+  rep = Collect (:[])++instance Rep (Collect (a,b)) (a,b) where+  rep = Collect (:[])++instance Rep (Collect (a,b,c)) (a,b,c) where+  rep = Collect (:[])++instance Rep (Collect (a,b,c,d)) (a,b,c,d) where+  rep = Collect (:[])++instance Rep (Collect (a,b,c,d,e)) (a,b,c,d,e) where+  rep = Collect (:[])++instance Rep (Collect (a,b,c,d,e,f)) (a,b,c,d,e,f) where+  rep = Collect (:[])++instance Rep (Collect (a,b,c,d,e,f,h)) (a,b,c,d,e,f,h) where+  rep = Collect (:[]) 

@@ -17,30 +17,26 @@ -- Summary: Generic function that collects all values of a specified type from a -- generic value. ----- 'collect' works by searching a datatype for values that are the same type as--- the return type specified. Here are some examples using the same value but--- different return types:------ @---   GHCi> collect [Just 1, Nothing, Just (2 :: Int)] :: [Int]---   [1,2]---   GHCi> collect [Just 1, Nothing, Just (2 :: Int)] :: [Maybe Int]---   [Just 1,Nothing,Just 2]---   GHCi> collect [Just 1, Nothing, Just (2 :: Int)] :: [[Maybe Int]]---   [[Just 1,Nothing,Just 2]]--- @------ Note that the number @2@ has the type @Int@. Some arguments (such as numeric--- constants which have type @Num a => a@) may need explicit type annotations.--- By design, there is no connection that can be inferred between the return--- type and the argument type.------ 'collect' only works if the return type has been made an instance of 'Rep'.--- The library provides instances for all datatypes with included--- representation.+-----------------------------------------------------------------------------++module Generics.EMGM.Functions.Collect (+  Collect(..),+  collect,+) where++import Generics.EMGM.Common.Base+import Generics.EMGM.Common.Representation++-----------------------------------------------------------------------------+-- Types+-----------------------------------------------------------------------------++-- | The type of a generic function that takes a value of one type and returns a+-- list of values of another type. ----- An instance is trivial to write. Given a type @D@, the 'Rep' instance looks--- like this:+-- For datatypes to work with Collect, a special instance must be given. This+-- instance is trivial to write. Given a type @D@, the 'Rep' instance looks like+-- this: -- -- >  {-# LANGUAGE OverlappingInstances #-} -- >@@ -53,20 +49,6 @@ -- the result type (the first @D@) matches some value type (the second @D@) -- contained within the argument to 'collect'. See the source of this module for -- more examples.--------------------------------------------------------------------------------module Generics.EMGM.Functions.Collect (-  Collect(..),-  collect,-) where--import Generics.EMGM.Common---------------------------------------------------------------------------------- Types---------------------------------------------------------------------------------- | Type for 'collect' newtype Collect b a = Collect { selCollect :: a -> [b] }  -----------------------------------------------------------------------------@@ -115,39 +97,6 @@ instance Rep (Collect Char) Char where   rep = Collect (:[]) -instance Rep (Collect Bool) Bool where-  rep = Collect (:[])--instance Rep (Collect (Either a b)) (Either a b) where-  rep = Collect (:[])--instance Rep (Collect [a]) [a] where-  rep = Collect (:[])--instance Rep (Collect (Maybe a)) (Maybe a) where-  rep = Collect (:[])--instance Rep (Collect ()) () where-  rep = Collect (:[])--instance Rep (Collect (a,b)) (a,b) where-  rep = Collect (:[])--instance Rep (Collect (a,b,c)) (a,b,c) where-  rep = Collect (:[])--instance Rep (Collect (a,b,c,d)) (a,b,c,d) where-  rep = Collect (:[])--instance Rep (Collect (a,b,c,d,e)) (a,b,c,d,e) where-  rep = Collect (:[])--instance Rep (Collect (a,b,c,d,e,f)) (a,b,c,d,e,f) where-  rep = Collect (:[])--instance Rep (Collect (a,b,c,d,e,f,h)) (a,b,c,d,e,f,h) where-  rep = Collect (:[])- ----------------------------------------------------------------------------- -- Exported functions -----------------------------------------------------------------------------@@ -155,7 +104,29 @@ -- | Collect values of type @b@ from some value of type @a@. An empty list means -- no values were collected. If you expected otherwise, be sure that you have an -- instance such as @'Rep' ('Collect' B) B@ for the type @B@ that you are--- collecting. See the description of this module for details.+-- collecting.+--+-- @collect@ works by searching a datatype for values that are the same type as+-- the return type specified. Here are some examples using the same value but+-- different return types:+--+-- @+--   ghci> let x = [Left 1, Right 'a', Left 2] :: [Either Int Char]+--   ghci> collect x :: [Int]+--   [1,2]+--   ghci> collect x :: [Char]+--   \"a\"+--   ghci> collect x == x+--   True+-- @+--+-- Note that the numerical constants have been declared @Int@ using the type+-- annotation. Since these natively have the type @Num a => a@, you may need to+-- give explicit types. By design, there is no connection that can be inferred+-- between the return type and the argument type.+--+-- @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 = selCollect rep 

@@ -65,14 +65,15 @@ -- Types ----------------------------------------------------------------------------- --- | Type for 'compare'+-- | The type of a generic function that takes two values of the same type and+-- returns an 'Ordering'. newtype Compare a = Compare { selCompare :: a -> a -> Ordering }  ----------------------------------------------------------------------------- -- Generic instance declaration ----------------------------------------------------------------------------- -rconstantCompare :: Ord a => a -> a -> Ordering+rconstantCompare :: (Ord a) => a -> a -> Ordering rconstantCompare = P.compare  rsumCompare :: Compare a -> Compare b -> a :+: b -> a :+: b -> Ordering@@ -104,59 +105,62 @@ -- Exported functions ----------------------------------------------------------------------------- +-- Set the fixity and precedence the same as the infix operators according to+-- the Haskell Report: http://www.haskell.org/onlinereport/decls.html+infix 4 `compare`, `lt`, `lteq`, `eq`, `neq`, `gt`, `gteq`, `min`, `max`+ -- | Compare two values and return an 'Ordering' (i.e. @LT@, @GT@, or @EQ@). -- This is implemented exactly as if the datatype was @deriving Ord@.--compare :: Rep Compare a => a -> a -> Ordering+compare :: (Rep Compare a) => a -> a -> Ordering compare = selCompare rep  -- | Less than. Returns @x < y@.-lt :: Rep Compare a => a -> a -> Bool+lt :: (Rep Compare a) => a -> a -> Bool lt x y =   case compare x y of     LT -> True     _  -> False  -- | Less than or equal to. Returns @x <= y@.-lteq :: Rep Compare a => a -> a -> Bool+lteq :: (Rep Compare a) => a -> a -> Bool lteq x y =   case compare x y of     GT -> False     _  -> True  -- | Equal to. Returns @x == y@.-eq :: Rep Compare a => a -> a -> Bool+eq :: (Rep Compare a) => a -> a -> Bool eq x y =   case compare x y of     EQ -> True     _  -> False  -- | Not equal to. Returns @x /= y@.-neq :: Rep Compare a => a -> a -> Bool+neq :: (Rep Compare a) => a -> a -> Bool neq x y =   case compare x y of     EQ -> False     _  -> True  -- | Greater than. Returns @x > y@.-gt :: Rep Compare a => a -> a -> Bool+gt :: (Rep Compare a) => a -> a -> Bool gt x y =   case compare x y of     GT -> True     _  -> False  -- | Greater than or equal to. Returns @x >= y@.-gteq :: Rep Compare a => a -> a -> Bool+gteq :: (Rep Compare a) => a -> a -> Bool gteq x y =   case compare x y of     LT -> False     _  -> True  -- | The minimum of two values.-min :: Rep Compare a => a -> a -> a+min :: (Rep Compare a) => a -> a -> a min x y = if x `lteq` y then x else y  -- | The maximum of two values.-max :: Rep Compare a => a -> a -> a+max :: (Rep Compare a) => a -> a -> a max x y = if x `gteq` y then x else y 

@@ -26,9 +26,9 @@ -- but there are variants specific to left- and right-associativity for -- convenience. ----- Many standard Haskell datatypes (e.g. '[]', 'Data.Tree') are designed such+-- Many standard Haskell datatypes (e.g. @[]@, @Data.Tree@) are designed such -- that a constructor with more than one argument (i.e. a product structurally--- represented by '(:*:)') has the element on the left and any recursive points+-- represented by @(:*:)@) has the element on the left and any recursive points -- towards the right. Due to this, the right-associative functions would -- typically produce the expected values. See examples in the comments for -- 'flattenr' and 'firstr'.@@ -67,16 +67,18 @@   all,   sum,   product,-  maximum,   minimum,+  maximum,   elem,   notElem,  ) where -import Prelude hiding (and, or, any, all, elem, notElem, sum, product, maximum, minimum)+import Prelude hiding (and, or, any, all, elem, notElem, sum, product, max, min, maximum, minimum) -import Generics.EMGM.Common+import Generics.EMGM.Common.Base+import Generics.EMGM.Common.Representation+import Generics.EMGM.Functions.Compare  ----------------------------------------------------------------------------- -- Types@@ -86,7 +88,8 @@ data Assoc = AssocLeft  -- ^ Left-associative            | AssocRight -- ^ Right-associative --- | Type for 'crush'+-- | 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 }  -----------------------------------------------------------------------------@@ -188,13 +191,13 @@  -- | Determine if an element is a member of a container. This is a -- generalization of the 'Prelude' function of the same name.-elem :: (Eq a, FRep (Crush Bool) f) => a -> f a -> Bool-elem x = any (== x)+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 :: (Eq a, FRep (Crush Bool) f) => a -> f a -> Bool-notElem x = all (/= x)+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.@@ -209,7 +212,7 @@ -- | Determine the maximum element of a container. If the container is empty, -- return 'Nothing'. This is a generalization of the 'Prelude' function of the -- same name.-maximum :: (Ord a, FRep (Crush (Maybe a)) f) => f a -> Maybe a+maximum :: (Rep Compare a, FRep (Crush (Maybe a)) f) => f a -> Maybe a maximum = crushr f Nothing   where f x Nothing  = Just x         f x (Just y) = Just $ max x y@@ -217,7 +220,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 :: (Ord a, FRep (Crush (Maybe a)) f) => f a -> Maybe a+minimum :: (Rep Compare a, FRep (Crush (Maybe a)) f) => f a -> Maybe a minimum = crushr f Nothing   where f x Nothing  = Just x         f x (Just y) = Just $ min x y

@@ -45,7 +45,8 @@ -- Types ----------------------------------------------------------------------------- --- | Type for 'enum'+-- | The type of a generic function that takes no arguments and returns a list+-- of some type. newtype Enum a = Enum { selEnum :: [a] }  -----------------------------------------------------------------------------

@@ -23,6 +23,7 @@   Map(..),   map,   replace,+  bimap, ) where  import Prelude hiding (map)@@ -33,7 +34,8 @@ -- Types ----------------------------------------------------------------------------- --- | Type for 'map'+-- | The type of a generic function that takes a value of one type and returns a+-- value of a different type. newtype Map a b = Map { selMap :: a -> b }  -----------------------------------------------------------------------------@@ -70,4 +72,10 @@ -- | Replace all @a@-values in @as@ with @b@. replace :: (FRep2 Map f) => f a -> b -> f b replace as b = map (const b) as++-- | Given a datatype @F a b@, @bimap f g@ applies the function @f :: a -> c@ to+-- every @a@-element and the function @g :: b -> d@ to every @b@-element. The+-- result is a value with transformed elements: @F c d@.+bimap :: (BiFRep2 Map f) => (a -> c) -> (b -> d) -> f a b -> f c d+bimap f g = selMap $ bifrep2 (Map f) (Map g) 

@@ -65,7 +65,8 @@ -- Types ----------------------------------------------------------------------------- --- | Type for 'readPrec'+-- | 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 }  -----------------------------------------------------------------------------@@ -364,9 +365,6 @@ -- operator precedence. This uses the library in -- "Text.ParserCombinators.ReadPrec" and should be similar to a derived -- implementation of 'Text.Read.readPrec'.------ Note that all of the other read functions in this module are derived from--- 'readPrec'. readPrec :: (Rep Read a) => ReadPrec a readPrec = selRead rep ConStd 

@@ -41,7 +41,7 @@ ) where  import Prelude hiding (Show, showsPrec, show, shows)-import qualified Prelude as P (Show, showsPrec)+import qualified Prelude as P (Show, showsPrec, show)  import qualified GHC.Show as GHC (showList__) @@ -53,8 +53,10 @@  type ShowsPrec a = Int -> a -> ShowS --- | Type for 'showsPrec'-newtype Show a = Show { selShow :: ConType -> ShowsPrec a }+-- | 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@@ -95,7 +97,8 @@     ConRec (label:[]) -> recEntry False label P.showsPrec      -- No other patterns expected-    _ -> error "Should not reach here!"+    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@@ -126,7 +129,8 @@       selShowStep rb (ConRec (labels)) p' b      -- No other patterns expected-    _ -> error "Should not reach here!"+    other ->+      error $ "rprodShow: Unexpected constructor: '" ++ P.show other ++ "'"    where selShowStep r ct' = selShow r ct' . (+1) @@ -181,7 +185,8 @@       recEntry False label (selShowFrom ConStd)      -- No other patterns expected-    _ -> error "Should not reach here!"+    other ->+      error $ "rtypeShow: Unexpected constructor: '" ++ P.show other ++ "'"    where selShowFrom ct' p = selShow ra ct' p . from ep @@ -260,8 +265,7 @@ -----------------------------------------------------------------------------  -- | Convert a value to a readable string starting with the operator precedence--- of the enclosing context. All of the remaining functions are derived from--- 'showsPrec'.+-- of the enclosing context. showsPrec ::   (Rep Show a)   => Int      -- ^ Operator precedence of the enclosing context (a number from 0 to 11).

@@ -37,7 +37,8 @@ -- Types ----------------------------------------------------------------------------- --- | Type for 'unzipWith'+-- | 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) }  -----------------------------------------------------------------------------@@ -96,7 +97,6 @@  -- | Splits a container into two structurally equivalent containers by applying -- a function to every element, which splits it into two corresponding elements.--- All other functions in this module are derived from 'unzipWith'. unzipWith ::   (FRep3 UnzipWith f)   => (a -> (b, c)) -- ^ Splitting function.

@@ -49,7 +49,8 @@ -- Types ----------------------------------------------------------------------------- --- | Type for 'zipWith'+-- | 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 }  -----------------------------------------------------------------------------@@ -111,8 +112,7 @@  -- | Combine two structurally equivalent containers into one by applying a -- function to every corresponding pair of elements. Returns 'Nothing' if @f a@--- and @f b@ have different shapes. All other functions in this module are--- derived from 'zipWith'.+-- and @f b@ have different shapes. zipWith ::   (FRep3 ZipWith f)   => (a -> b -> c)       -- ^ Binary operator on elements of containers.

@@ -0,0 +1,36 @@+{-# LANGUAGE TypeOperators    #-}+{-# OPTIONS -fno-warn-orphans #-}++module Base where++import Generics.EMGM++import Control.Monad (liftM2)+import Test.QuickCheck (quickCheckResult, Arbitrary(..), oneof)+import Test.QuickCheck.Test (isSuccess)+import qualified Test.QuickCheck as QC (Testable)+import Test.HUnit as HU+import Data.Generics (Data, dataTypeOf, dataTypeName)++-- Instances of Arbitrary for representation++instance Arbitrary Unit where+  arbitrary = return Unit++instance (Arbitrary a, Arbitrary b) => Arbitrary (a :+: b) where+  arbitrary = oneof [fmap L arbitrary, fmap R arbitrary]++instance (Arbitrary a, Arbitrary b) => Arbitrary (a :*: b) where+  arbitrary = liftM2 (:*:) arbitrary arbitrary++-- Useful testing functions++infixr 0 ~|:++-- | Label and run quickCheck on a test+(~|:) :: (QC.Testable prop) => String -> prop -> Test+lbl ~|: t = lbl ~: quickCheckResult t >>= return . isSuccess++typeNameOf :: Data a => a -> String+typeNameOf = dataTypeName . dataTypeOf+

@@ -0,0 +1,87 @@+{-# LANGUAGE TemplateHaskell            #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE Rank2Types                 #-}+{-# OPTIONS_GHC -fno-warn-unused-binds  #-}++module Bimap (tests) where++import Test.HUnit ((~:))+import Data.Char (ord, chr)++import Base ((~|:))+import Generics.EMGM hiding (Show)++--------------------------------------------------------------------------------+-- Fixed-point stuff+--------------------------------------------------------------------------------++-- Note that these are unused for now. They can potentially be useful for+-- enhancing the library, however.++data Fix f a = In (f a (Fix f a))++out :: Fix f a -> f a (Fix f a)+out (In x) = x++fold :: (BiFRep2 Map f) => (f a c -> c) -> Fix f a -> c+fold f = f . bimap id (fold f) . out++unfold :: (BiFRep2 Map f) => (b -> f a b) -> b -> Fix f a+unfold f = In . bimap id (unfold f) . f++hylo :: (BiFRep2 Map f) => (b -> f a b) -> (f a c -> c) -> b -> c+hylo f g = g . bimap id (hylo f g) . f++build :: (BiFRep2 Map f) => (forall b. (f a b -> b) -> b) -> Fix f a+build f = f In++--------------------------------------------------------------------------------+-- Tuple, Either+--------------------------------------------------------------------------------++test_tuple1 = "bimap ord chr ('G', 97)" ~|: bimap ord chr ('G', 97) == (ord 'G', chr 97)++test_either1 = "bimap ord chr (Left 'G')" ~|: bimap ord chr (Left 'G') == Left (ord 'G')+test_either2 = "bimap ord chr (Right 97)" ~|: bimap ord chr (Right 97) == Right (chr 97)++--------------------------------------------------------------------------------+-- ListF+--------------------------------------------------------------------------------++data ListF a b = NilF | ConsF a b+  deriving (Eq, Show)++$(derive ''ListF)++test_list_simple1 = "bimap chr ord (ConsF 4 'a')" ~|: bimap chr ord (ConsF 4 'a') == ConsF (chr 4) (ord 'a')+test_list_simple2 = "bimap chr ord NilF" ~|: bimap chr ord NilF == NilF++--------------------------------------------------------------------------------+-- TreeF+--------------------------------------------------------------------------------++data TreeF a b = TipF a | BinF b b+  deriving (Eq, Show)++$(derive ''TreeF)++test_tree_simple1 = "bimap chr ord (BinF 'c' 'd')" ~|: bimap chr ord (BinF 'c' 'd') == BinF (ord 'c') (ord 'd')+test_tree_simple2 = "bimap chr ord (TipF 1)" ~|: bimap chr ord (TipF 1) == TipF (chr 1)++-----------------------------------------------------------------------------+-- Test collection+-----------------------------------------------------------------------------++tests =+  "Bimap" ~:+    [ test_tuple1+    , test_either1+    , test_either2+    , test_list_simple1+    , test_list_simple2+    , test_tree_simple1+    , test_tree_simple2+    ]+

@@ -0,0 +1,39 @@++module Collect (tests) where++import Test.HUnit+import Generics.EMGM++-----------------------------------------------------------------------------+-- Utility functions+-----------------------------------------------------------------------------++test_c descr actual expected = descr ~: (collect actual) ~?= expected++-----------------------------------------------------------------------------+-- Test collection+-----------------------------------------------------------------------------++tests =+  "Collect" ~:+    [ test_c "[Maybe Int] -> [Int]" [Just 1,Nothing,Just 2::Maybe Int] [1,2::Int]+    , test_c "[Maybe Int] -> [Maybe Int]" [Just 1,Nothing,Just 2::Maybe Int] [Just 1,Nothing,Just 2::Maybe Int]+    , test_c "Maybe [String] -> [String]" (Just ["a","b"]) ["a","b"]+    , test_c "Maybe Float -> [Float]" (Just (3::Float)) [3::Float]+    , test_c "Either Integer Double -> [Integer]" (Left 98::Either Integer Double) [98::Integer]+    , test_c "Either Integer Double -> [Double]" (Left 98::Either Integer Double) ([]::[Double])+    , test_c "Either Integer Double -> [Either Integer Double]" (Left 98::Either Integer Double) [Left 98::Either Integer Double]+    , test_c "(Bool,Double) -> [Double]" (True,99::Double) [99::Double]+    , test_c "(Bool,Double,Float) -> [Bool]" (False,99::Double,0::Float) [False]+    , test_c "(Int,Double,Float,Integer) -> [Float]" (1::Int,99::Double,0::Float,2::Integer) [0::Float]+    , test_c "(Char,Char,Int,Char,Int) -> [Char]" ('a','b',5::Int,'c',9::Int) "abc"+    , test_c "(Int,[Float],Int,[Float],Int,[Float]) -> [[Float]]" (1::Int,[11::Float],5::Int,[22::Float],9::Int,[33::Float]) [[11],[22],[33::Float]]+    , test_c "(Int,Int,Int,Int,Int,Int,Int) -> [Int]" (1::Int,3::Int,5::Int,7::Int,9::Int,11::Int,13::Int) [1,3,5,7,9,11,13::Int]+    , test_c "Maybe (Int,Int,Int,Int,Int,Int,Int) -> [(Int,Int,Int,Int,Int,Int,Int)]" (Just (1::Int,3::Int,5::Int,7::Int,9::Int,11::Int,13::Int)) [(1::Int,3::Int,5::Int,7::Int,9::Int,11::Int,13::Int)]+    , test_c "[(Int,Int,Int,Int,Int,Int)] -> [(Int,Int,Int,Int,Int,Int)]" [(1::Int,3::Int,5::Int,7::Int,9::Int,11::Int)] [(1::Int,3::Int,5::Int,7::Int,9::Int,11::Int)]+    , test_c "[(Int,Int,Int,Int,Int)] -> [(Int,Int,Int,Int,Int)]" (1::Int,3::Int,5::Int,7::Int,9::Int) [(1::Int,3::Int,5::Int,7::Int,9::Int)]+    , test_c "[(Int,Double,Float,Integer)] -> [(Int,Double,Float,Integer)]" (1::Int,99::Double,0::Float,2::Integer) [(1::Int,99::Double,0::Float,2::Integer)]+    , test_c "Either (Bool,Double) (Bool,Double,Float) -> [(Bool,Double)]" (Left (True,99)::Either (Bool,Double) (Bool,Double,Float)) [(True,99::Double)]+    , test_c "Either (Bool,Double) (Bool,Double,Float) -> [(Bool,Double,Float)]" (Right (False,99,0)::Either (Bool,Double) (Bool,Double,Float)) [(False,99::Double,0::Float)]+    ]+

@@ -0,0 +1,115 @@+{-# LANGUAGE FlexibleContexts #-}++module Compare where++import Prelude hiding (Show, show, compare, min, max)+import qualified Prelude as P (Show, show, compare, min, max)+import Test.HUnit+import Data.Generics (Data)++import Generics.EMGM++import Base+import TTree++-----------------------------------------------------------------------------+-- Utility functions+-----------------------------------------------------------------------------++test_f mine theirs x y =+  P.show x ++ " `eq` (" ++ P.show y ++ " :: " ++ typeNameOf y ++ ")" ~:+    x `mine` y ~?= x `theirs` y++test_compare :: (P.Show a, Data a, Ord a, Rep Compare a) => a -> a -> Test+test_compare = test_f compare P.compare++test_eq :: (P.Show a, Data a, Eq a, Rep Compare a) => a -> a -> Test+test_eq = test_f eq (==)++test_neq :: (P.Show a, Data a, Eq a, Rep Compare a) => a -> a -> Test+test_neq = test_f neq (/=)++test_lt :: (P.Show a, Data a, Ord a, Rep Compare a) => a -> a -> Test+test_lt = test_f lt (<)++test_lteq :: (P.Show a, Data a, Ord a, Rep Compare a) => a -> a -> Test+test_lteq = test_f lteq (<=)++test_gt :: (P.Show a, Data a, Ord a, Rep Compare a) => a -> a -> Test+test_gt = test_f gt (>)++test_gteq :: (P.Show a, Data a, Ord a, Rep Compare a) => a -> a -> Test+test_gteq = test_f gteq (>=)++test_min :: (P.Show a, Data a, Ord a, Rep Compare a) => a -> a -> Test+test_min = test_f min P.min++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)++-----------------------------------------------------------------------------+-- Test collections+-----------------------------------------------------------------------------++test_constants =+  "constants" ~:+    [ test_compare 42 (42 :: Int)+    , test_compare (-1) (100 :: Float)+    , test_compare 100 (-1 :: Double)+    , test_compare 42 (42 :: Integer)+    , test_compare '8' ('b' :: Char)+    ]++test_structure =+  "structure" ~:+    [ test_compare Nothing (Just (42 :: Int))+    , test_compare Nothing (Nothing :: Maybe Char)+    , test_compare (Just (42 :: Int)) Nothing+    , test_compare (1::Int,2::Int,3::Int,4::Int,5::Int) (1::Int,2::Int,3::Int,4::Int,5::Int)+    , test_compare (1::Int,2::Int,3::Int,4::Int,5::Int) (1::Int,2::Int,3::Int,3::Int,5::Int)+    , test_compare (1::Int,2::Int,3::Int,4::Int,5::Int) (1::Int,2::Int,3::Int,4::Int,6::Int)+    ]++test_functions =+  "functions" ~:+    [ "eq" ~:+        [ test_eq t1 t1+        , test_eq t1 t2+        ]+    , "neq" ~:+        [ test_neq t2 t2+        , test_neq t2 t1+        ]+    , "lt" ~:+        [ test_lt t2 t2+        , test_lt t2 t1+        , test_lt t1 t2+        ]+    , "gt" ~:+        [ test_gt t1 t1+        , test_gt t2 t1+        , test_gt t1 t2+        ]+    , "lteq" ~:+        [ test_lteq t1 t1+        , test_lteq t2 t1+        , test_lteq t1 t2+        ]+    , "gteq" ~:+        [ test_gteq t2 t2+        , test_gteq t2 t1+        , test_gteq t1 t2+        ]+    ]++tests =+  "Compare" ~:+    [ test_constants+    , test_structure+    , test_functions+    ]+

@@ -0,0 +1,113 @@+{-# LANGUAGE FlexibleContexts #-}++module Crush (tests) where++import Prelude as P++import Base++import Test.HUnit++import Generics.EMGM.Functions.Crush as C++-----------------------------------------------------------------------------+-- Utility functions+-----------------------------------------------------------------------------++eqf :: (Eq b) => (a -> b) -> (a -> b) -> a -> Bool+eqf f1 f2 as = f1 as == f2 as++eqpf :: (Eq b) => p -> (p -> a -> b) -> (p -> a -> b) -> a -> Bool+eqpf p f1 f2 as = f1 p as == f2 p as++fromList :: ([a] -> a) -> [a] -> Maybe a+fromList _ [] = Nothing+fromList f xs = Just (f xs)++-----------------------------------------------------------------------------+-- Tests+-----------------------------------------------------------------------------++test_crush1 =+  "crush AssocLeft (:) [] [1,2] ~> [2,1]" ~:+    crushl (:) [] [1,2] ~?= [2,1::Int]++test_crush2 =+  "crush AssocRight (:) [] [1,2] ~> [1,2]" ~:+    crush AssocRight (:) [] [1,2] ~?= [1,2::Int]++-----------------------------------------------------------------------------+-- Properties+-----------------------------------------------------------------------------++test_flattenl_reverse = "flattenl == Prelude.reverse" ~|: f+  where f :: [Float] -> Bool+        f ls = flattenl ls == reverse ls++test_flattenr = "flattenr == id" ~|: f+  where f :: [Int] -> Bool+        f ls = flattenr ls == ls++test_firstl = "firstl == Prelude.last" ~|: f+  where f :: [Int] -> Bool+        f ls = firstl ls == last' ls+        last' :: [a] -> Maybe a+        last' [] = Nothing+        last' as = Just $ last as++test_firstr = "firstr == Prelude.head" ~|: f+  where f :: [Double] -> Bool+        f ls = firstr ls == head' ls+        head' :: [a] -> Maybe a+        head' [] = Nothing+        head' as = Just $ head as++test_and = "and == Prelude.and" ~|: (eqf C.and P.and :: [Bool] -> Bool)++test_or = "or == Prelude.or" ~|: (eqf C.or P.or :: [Bool] -> Bool)++test_any = "any == Prelude.any" ~|: (eqpf (== 0) C.any P.any :: [Integer] -> Bool)++test_all = "all == Prelude.all" ~|: (eqpf f C.all P.all :: [Float] -> Bool)+  where f x = abs x > 2++test_sum = "sum == Prelude.sum" ~|: (eqf C.sum P.sum :: [Int] -> Bool)++test_product = "product == Prelude.product" ~|: (eqf C.product P.product :: [Int] -> Bool)++test_minimum = "minimum == Prelude.minimum" ~|: (eqf C.minimum (fromList P.minimum) :: [Int] -> Bool)++test_maximum = "maximum == Prelude.maximum" ~|: (eqf C.maximum (fromList P.maximum) :: [Int] -> Bool)++test_elem1 = "elem 5 [1,2,5,2]" ~: assert (C.elem 5 [1,2,5,2::Int])+test_elem2 = "elem 8 [1,2,5,2]" ~: assert (not $ C.elem 8 [1,2,5,2::Int])++test_notElem1 = "notElem 5 [1,2,5,2]" ~: assert (not $ C.notElem 5 [1,2,5,2::Int])+test_notElem2 = "notElem 8 [1,2,5,2]" ~: assert (C.notElem 8 [1,2,5,2::Int])++-----------------------------------------------------------------------------+-- Test collection+-----------------------------------------------------------------------------++tests =+  "Crush" ~:+    [ test_crush1+    , test_crush2+    , test_flattenl_reverse+    , test_flattenr+    , test_firstl+    , test_firstr+    , test_and+    , test_or+    , test_any+    , test_all+    , test_sum+    , test_product+    , test_minimum+    , test_maximum+    , test_elem1+    , test_elem2+    , test_notElem1+    , test_notElem2+    ]+

@@ -0,0 +1,157 @@+{-# LANGUAGE CPP                        #-}+{-# LANGUAGE TemplateHaskell            #-}+{-# LANGUAGE TypeOperators              #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE OverlappingInstances       #-}+{-# LANGUAGE UndecidableInstances       #-}+{-# OPTIONS_GHC -fno-warn-unused-binds  #-}+{-  OPTIONS_GHC -ddump-splices           -}++module Derive (tests) where++--------------------------------------------------------------------------------+-- Imports+--------------------------------------------------------------------------------++import Data.Char (ord)+import Test.HUnit++import Generics.EMGM as G+import Generics.EMGM.Data.Tuple (epTuple2, conTuple2)+import Generics.EMGM.Common.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 (Int -> a)         -- UNSUPPORTED+--  | B8 (a,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 contained tuple+--------------------------------------------------------------------------------++-- We don't currently support deriving representations for the following type,+-- but one should be able to do this manually.++data C a+  = C (a,Int)++epC = EP fromC toC+  where+    fromC (C v1) = v1+    toC v1 = C v1++-- | Representation for @(a,b)@ in 'Generic'+rTuple2 :: (Generic g) => g a -> g b -> g (a,b)+rTuple2 ra rb = rtype epTuple2 $ rcon conTuple2 (ra `rprod` rb)++-- Could potentially support the types with the below, but it would only work+-- for types that we know about, e.g. tuples and Either.+instance (Generic g) => FRep g C where+  frep ra = rtype epC (rTuple2 ra rint)++--------------------------------------------------------------------------------+-- 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)+--  | D6 [a]            -- UNSUPPORTED++-- 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)+$(deriveRep ''F)+$(deriveFRep ''F)+$(deriveCollect ''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 collection+--------------------------------------------------------------------------------++tests =+  "Derive" ~:+    [ test_ChangeTo1+    , test_ChangeTo2+    , test_ChangeTo3+    , test_DefinedAs1+    , test_manual1+    , test_manual2+    ]+

@@ -0,0 +1,70 @@+{-# LANGUAGE FlexibleContexts #-}++module Enum (tests) where++import Prelude hiding (Show, Enum)+import qualified Prelude as P (Show)+import Data.Generics (Data)+import Test.HUnit++import Base+import Generics.EMGM++-----------------------------------------------------------------------------+-- Utility functions+-----------------------------------------------------------------------------++n100 :: Num a => [a]+n100 =+  [0,-1,1,-2,2,-3,3,-4,4,-5,5,-6,6,-7,7,-8,8,-9,9,-10,10,-11,11,-12,12+  ,-13,13,-14,14,-15,15,-16,16,-17,17,-18,18,-19,19,-20,20,-21,21,-22+  ,22,-23,23,-24,24,-25,25,-26,26,-27,27,-28,28,-29,29,-30,30,-31,31,-32+  ,32,-33,33,-34,34,-35,35,-36,36,-37,37,-38,38,-39,39,-40,40,-41,41,-42+  ,42,-43,43,-44,44,-45,45,-46,46,-47,47,-48,48,-49,49,-50+  ]++test_num_100 :: (Data a, Rep Enum a, Eq a, P.Show a) => [a] -> Test+test_num_100 ns = "enum :: " ++ typeNameOf ns ~: enumN (100::Int) ~?= ns++l50 :: [[Int]]+l50 =+  [[],[0],[0,0],[-1],[0,0,0],[-1,0],[1],[0,-1],[-1,0,0],[1,0],[-2]+  ,[0,0,0,0],[-1,-1],[1,0,0],[-2,0],[2],[0,-1,0],[-1,0,0,0],[1,-1]+  ,[-2,0,0],[2,0],[-3],[0,1],[-1,-1,0],[1,0,0,0],[-2,-1],[2,0,0],[-3,0]+  ,[3],[0,0,-1],[-1,1],[1,-1,0],[-2,0,0,0],[2,-1],[-3,0,0],[3,0],[-4]+  ,[0,-1,0,0],[-1,0,-1],[1,1],[-2,-1,0],[2,0,0,0],[-3,-1],[3,0,0],[-4,0]+  ,[4],[0,1,0],[-1,-1,0,0],[1,0,-1],[-2,1]+  ]++test_empty x = "empty :: " ++ typeNameOf x ~: empty ~?= x++-----------------------------------------------------------------------------+-- Test functions+-----------------------------------------------------------------------------++test_length_char = "enum :: [Char]" ~: length (enum :: [Char]) ~?= 1114112++test_int_100 = test_num_100 (n100 :: [Int])+test_integer_100 = test_num_100 (n100 :: [Integer])+test_float_100 = test_num_100 (n100 :: [Float])+test_double_100 = test_num_100 (n100 :: [Double])++test_list_50 = "enum :: [[Int]]" ~: enumN (50::Int) ~?= l50++-----------------------------------------------------------------------------+-- Test collection+-----------------------------------------------------------------------------++tests = "Enum" ~:+          [ test_length_char+          , test_int_100+          , test_integer_100+          , test_float_100+          , test_double_100+          , test_list_50+          , test_empty ([] :: [Char])+          , test_empty '\NUL'+          , test_empty (Nothing :: Maybe [Double])+          , test_empty ((0,0,0,0) :: (Int,Integer,Float,Double))+          ]+

@@ -3,18 +3,19 @@  import Test.HUnit -import qualified TestQC-import qualified Crush-import qualified ReadShow-import qualified Compare-import qualified Collect-import qualified Enum-import qualified ZipWith-import qualified UnzipWith-import qualified Map+import qualified Crush          (tests)+import qualified ReadShow       (tests)+import qualified Compare        (tests)+import qualified Collect        (tests)+import qualified Enum           (tests)+import qualified ZipWith        (tests)+import qualified UnzipWith      (tests)+import qualified Map            (tests)+import qualified Bimap          (tests)+import qualified Derive         (tests)  -- Make sure the examples compile:-import Ex00StartHere ()+import qualified Ex00StartHere  ()  tests =   "All" ~: [ Crush.tests@@ -25,8 +26,11 @@            , ZipWith.tests            , UnzipWith.tests            , Map.tests+           , Bimap.tests+           , Derive.tests            ] -main = do TestQC.main-          runTestTT tests+main =+  do putStrLn "Running tests for EMGM..."+     runTestTT tests 

@@ -0,0 +1,38 @@+{-# LANGUAGE FlexibleContexts #-}++module Map (tests) where++import Prelude hiding (map)+import qualified Prelude as P (map)+import Data.Char (ord)+import Test.HUnit++import Generics.EMGM++-----------------------------------------------------------------------------+-- Utility functions+-----------------------------------------------------------------------------++-----------------------------------------------------------------------------+-- Test functions+-----------------------------------------------------------------------------++test_map1 = "map [Int]" ~: map (*3) [1,2,3::Int] ~?= P.map (*3) [1,2,3]+test_map2 = "map (Maybe Char)" ~: map ord (Just 'a') ~?= Just (ord 'a')+test_map3 = "map (Maybe Char)" ~: map ord Nothing ~?= Nothing++test_replace1 =+  "replace [Float] [[Double]]" ~:+    replace [0.1,0.2,0.3::Float] ([]::[Double]) ~?= [[],[],[]]++-----------------------------------------------------------------------------+-- Test collection+-----------------------------------------------------------------------------++tests = "Map" ~:+          [ test_map1+          , test_map2+          , test_map3+          , test_replace1+          ]+

@@ -0,0 +1,76 @@+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}++module ReadShow (tests) where++import Prelude hiding (Read, Show, readsPrec, reads, read, show)+import qualified Prelude as P (Read, Show, read, show)+import Data.Generics (Data)+import Test.HUnit++import Generics.EMGM++import Base+import TTree++-----------------------------------------------------------------------------+-- Utility functions+-----------------------------------------------------------------------------++test_all :: (Eq a, Data a, P.Read a, P.Show a, Rep Read a, Rep Show a)+         => Bool -> a -> Test+test_all notIfxRec x =+  let expected = P.show x+      actual   = show x in+  "x = " ++ P.show x ++ " :: " ++ typeNameOf x ~:++    -- The following is conditional on whether x has an infix constructor with+    -- record syntax. That is currently broken in GHC.+    (if notIfxRec then ["P.read . show == id" ~: P.read actual ~?= x] else [])+    +++    [ "read . P.show == id" ~: read expected ~?= Just x+    , "read . show == id"   ~: read actual ~?= Just x+    , "show == P.show"      ~: actual ~?= expected+    ]++-----------------------------------------------------------------------------+-- Test collection+-----------------------------------------------------------------------------++tests =+  "ReadShow" ~:+    [ test_all True  (42 :: Int)+    , test_all True  (9999999999999999999999999999999 :: Integer)+    , test_all True  (4.2 :: Float)+    , test_all True  (5.3 :: Double)+    , test_all True  ('\t' :: Char)+    , test_all True  (True :: Bool)+    , test_all True  (Just True :: Maybe Bool)+    , test_all True  (Left 7.8888 :: Either Float Char)+    , 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  [1,2,3,4,5 :: Int]+    , test_all True  [[5.3,3.5],[35.0],[0.53 :: Float]]+    , test_all True  "abcdefgh"+    , test_all True  (Just "abcdefgh")+    , test_all True  ()+    , test_all True  (1::Int,2::Float)+    , test_all True  (1::Int,2::Float,3::Double)+    , 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))+    ]+

@@ -0,0 +1,116 @@+{-# LANGUAGE TemplateHaskell          #-}+{-# LANGUAGE FlexibleInstances        #-}+{-# LANGUAGE MultiParamTypeClasses    #-}+{-# LANGUAGE DeriveDataTypeable       #-}+{-# LANGUAGE UndecidableInstances     #-}+{-  OPTIONS -ddump-splices             -}++module TTree where++import Prelude hiding (Read, Show)+import qualified Prelude as P (Read, Show)+import Data.Generics (Data, Typeable)++import Generics.EMGM++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)++{-++type TTreeS a+  {- L1   -} =   a+  {- L2   -} :+: a :*: TTree a+  {- L3   -} :+: a+  {- L4   -} :+: TTree a :*: a+  {- L5   -} :+: a :*: TTree a :*: a+  {- :^:  -} :+: TTree a :*: a+  {- :<>: -} :+: TTree a :*: TTree a++fromTTree :: TTree a -> TTreeS a+fromTTree (L1 a)         = L a+fromTTree (L2 a tt)      = R (L (a :*: tt))+fromTTree (L3 a)         = R (R (L a))+fromTTree (L4 a tt)      = R (R (R (L (a :*: tt))))+fromTTree (L5 a1 tt a2)  = R (R (R (R (L (a1 :*: tt :*: a2)))))+fromTTree (tt :^: a)     = R (R (R (R (R (L (tt :*: a))))))+fromTTree (tt1 :<>: tt2) = R (R (R (R (R (R (tt1 :*: tt2))))))++toTTree :: TTreeS a -> TTree a+toTTree (L a)                                  = (L1 a)+toTTree (R (L (a :*: tt)))                     = (L2 a tt)+toTTree (R (R (L a)))                          = (L3 a)+toTTree (R (R (R (L (tt :*: a)))))             = (L4 tt a)+toTTree (R (R (R (R (L (a1 :*: tt :*: a2)))))) = (L5 a1 tt a2)+toTTree (R (R (R (R (R (L (tt :*: a)))))))     = (tt :^: a)+toTTree (R (R (R (R (R (R (tt1 :*: tt2)))))))  = (tt1 :<>: tt2)++epTTree :: EP (TTree a) (TTreeS a)+epTTree = EP fromTTree toTTree++l1, l2, l3, l4, l5, b1, b2 :: ConDescr+l1 = ConDescr "L1"   1 [] Nonfix+l2 = ConDescr "L2"   2 [] Nonfix+l3 = ConDescr "L3"   1 ["unL3"] Nonfix+l4 = ConDescr "L4"   2 ["unL4t","unL4a"] Nonfix+l5 = ConDescr "L5"   3 ["unL5a1","unL5t","unL5a2"] Nonfix+b1 = ConDescr ":^:"  2 [] (Infixr 6)+b2 = ConDescr ":<>:" 2 ["left","right"] (Infixr 5)++rTTree :: Generic g => g a -> g (TTree a)+rTTree ra = rtype epTTree $+   {- L1   -}        rcon l1 ra+   {- L2   -} `rsum` rcon l2 (ra `rprod` rTTree ra)+   {- L3   -} `rsum` rcon l3 ra+   {- L4   -} `rsum` rcon l4 (rTTree ra `rprod` ra)+   {- L5   -} `rsum` rcon l5 (ra `rprod` rTTree ra `rprod` ra)+   {- :^:  -} `rsum` rcon b1 (rTTree ra `rprod` ra)+   {- :<>: -} `rsum` rcon b2 (rTTree ra `rprod` rTTree ra)++instance (Generic g, Rep g a) => Rep g (TTree a) where+  rep = rTTree rep++instance Generic g => FRep g TTree where+  frep = rTTree++rTTree2 :: Generic2 g => g a b -> g (TTree a) (TTree b)+rTTree2 ra = rtype2 epTTree epTTree $+   {- L1   -}         rcon2 l1 ra+   {- L2   -} `rsum2` rcon2 l2 (ra `rprod2` rTTree2 ra)+   {- L3   -} `rsum2` rcon2 l3 ra+   {- L4   -} `rsum2` rcon2 l4 (rTTree2 ra `rprod2` ra)+   {- L5   -} `rsum2` rcon2 l5 (ra `rprod2` rTTree2 ra `rprod2` ra)+   {- :^:  -} `rsum2` rcon2 b1 (rTTree2 ra `rprod2` ra)+   {- :<>: -} `rsum2` rcon2 b2 (rTTree2 ra `rprod2` rTTree2 ra)++instance Generic2 g => FRep2 g TTree where+  frep2 = rTTree2++rTTree3 :: Generic3 g => g a b c -> g (TTree a) (TTree b) (TTree c)+rTTree3 ra = rtype3 epTTree epTTree epTTree $+   {- L1   -}         rcon3 l1 ra+   {- L2   -} `rsum3` rcon3 l2 (ra `rprod3` rTTree3 ra)+   {- L3   -} `rsum3` rcon3 l3 ra+   {- L4   -} `rsum3` rcon3 l4 (rTTree3 ra `rprod3` ra)+   {- L5   -} `rsum3` rcon3 l5 (ra `rprod3` rTTree3 ra `rprod3` ra)+   {- :^:  -} `rsum3` rcon3 b1 (rTTree3 ra `rprod3` ra)+   {- :<>: -} `rsum3` rcon3 b2 (rTTree3 ra `rprod3` rTTree3 ra)++instance Generic3 g => FRep3 g TTree where+  frep3 = rTTree3++-}+

@@ -0,0 +1,35 @@+{-# LANGUAGE FlexibleContexts #-}++module UnzipWith (tests) where++import Prelude hiding (unzip)+import qualified Prelude as P (zip, unzip)+import Test.HUnit+import Generics.EMGM++-----------------------------------------------------------------------------+-- Tests+-----------------------------------------------------------------------------++test_unzipWith1 =+  let ls = [2.5, 1.8::Double]+      split :: Double -> (Int, Double)+      split = properFraction+  in "unzipWith1" ~: unzipWith split ls ~?= ([2,1],[0.5,0.8])++test_unzip1 =+  let ls = [1..7::Int]+      sl = reverse ls+      z = P.zip ls sl+  in "unzip1" ~: unzip z ~?= P.unzip z++-----------------------------------------------------------------------------+-- Test collection+-----------------------------------------------------------------------------++tests =+  "UnzipWith" ~:+    [ test_unzipWith1+    , test_unzip1+    ]+

@@ -0,0 +1,45 @@+{-# LANGUAGE FlexibleContexts #-}++module ZipWith (tests) where++import Prelude hiding (zipWith, zip)+import qualified Prelude as P (zipWith, zip)+import Test.HUnit+import Generics.EMGM++-----------------------------------------------------------------------------+-- Tests+-----------------------------------------------------------------------------++test_zipWith1 =+  let ls = [1..7::Int]+      sl = reverse ls+  in "zipWith1" ~: zipWith (+) ls sl ~?= Just (P.zipWith (+) ls sl)++test_zipWith2 =+  let ls = [1..7::Int]+      sl = [1..8::Int]+  in "zipWith2" ~: zipWith (+) ls sl ~?= Nothing++test_zip1 =+  let ls = [1..7::Int]+      sl = reverse ls+  in "zip1" ~: zip ls sl ~?= Just (P.zip ls sl)+  +test_zip2 =+  let ls = [1..7::Int]+      sl = 8 : reverse ls+  in "zip2" ~: zip ls sl ~?= Nothing -- zip does not behave like P.zip.++-----------------------------------------------------------------------------+-- Test collection+-----------------------------------------------------------------------------++tests =+  "ZipWith" ~:+    [ test_zipWith1+    , test_zipWith2+    , test_zip1+    , test_zip2+    ]+

@@ -0,0 +1,140 @@+#! /usr/bin/env runhaskell++\begin{code}++module Main (main) where++import System.Cmd (system)+import System.Exit (ExitCode(..))+import System.FilePath ((</>))+import System.Directory+import System.Environment+import Text.Regex++main :: IO ()+main =+  do as <- getArgs+     jopt <- checkArgs as+     case jopt of+       Nothing  -> printUsage+       Just opt ->+         do exists <- dirsExist+            if not exists+               then+                 putStrLn failureMsg+               else+                 do files <- excludedFiles+                    let cmd = hpc opt files+                    putStrLn cmd+                    exitCode <- system cmd+                    putStrLn $+                      case exitCode of+                        ExitSuccess   -> successMsg opt+                        ExitFailure _ -> ""++-- Directory and file locations++distDir      = "dist"+testsDir     = "tests"+examplesDir  = "examples"+hpcDir       = distDir </> "hpc"+hpcIndex     = hpcDir </> "hpc_index.html"+testExec     = distDir </> "build" </> "test" </> "test"++deriveDir    = "src" </> "Generics" </> "EMGM" </> "Common" </> "Derive"++dirsExist =+  do testDirExists <- doesDirectoryExist testsDir+     examplesDirExists <- doesDirectoryExist examplesDir+     return $ testDirExists && examplesDirExists++excludedFiles :: IO [String]+excludedFiles =+  do testFiles <- getDirectoryContents testsDir+     examplesFiles <- getDirectoryContents examplesDir++     -- The exporting files have nothing important.+     let exportFiles =+           [ "Generics.EMGM.hs"+           , "Generics.EMGM.Common.hs"+           , "Generics.EMGM.Data.hs"+           , "Generics.EMGM.Functions.hs"+           ]++     -- The Base* and Representation files are primarily class declarations.+     let baseFiles =+           [ "Generics.EMGM.Common.Base.hs"+           , "Generics.EMGM.Common.Base2.hs"+           , "Generics.EMGM.Common.Base3.hs"+           , "Generics.EMGM.Common.Representation.hs"+           ]++     -- Template Haskell code is not covered under HPC.+     deriveFiles <- getDirectoryContents deriveDir+     let thFiles =+           "Generics.EMGM.Data.TH.hs" :+           "Generics.EMGM.Common.Derive.hs" :+           map ("Generics.EMGM.Common.Derive." ++) deriveFiles++     return $ testFiles ++ examplesFiles ++ exportFiles ++ baseFiles ++ thFiles++-- Convert file name to module name if Haskell file (.hs)+toModuleName str =+  case matchRegex (mkRegex "(.*)\\.hs$") str of+    Just xs  -> xs+    Nothing  -> []++-- Flags for hpc++toExcludeFlags = unwords . map excludeFlag . concatMap toModuleName+  where excludeFlag = (++) "--exclude="++destFlag = showString "--destdir=" . showString hpcDir++-- Command for hpc+hpc opt files+  = showString "hpc"+  . showChar ' '+  . case opt of+      Markup -> showString "markup " . destFlag+      Report -> showString "report"+  . showChar ' '+  . showString (toExcludeFlags files)+  . showChar ' '+  . showString testExec+  $ ""++data Option = Markup | Report++checkArgs args+  = if length args /= 1+       then return Nothing+       else case head args of+              "markup" -> return $ Just Markup+              "report" -> return $ Just Report+              _        -> return Nothing++printUsage+  = do prog <- getProgName+       putStrLn $ usageMsg prog++-- Messages++usageMsg prog+  = showString "Usage: "+  . showString prog+  . showString " markup|report"+  $ ""++successMsg opt+  = showString "Done." $+      case opt of+        Markup -> showString "\nHPC documentation created: " hpcIndex+        Report -> ""++failureMsg+  = showString "Error: You must be in the top-level EMGM directory to run this command.\n"+  $            "       You should also have both examples/ and tests/ directories."++\end{code}+