emgm 0.2 → 0.3

raw patch · 58 files changed

+3384/−1692 lines, 58 filesdep ~template-haskellsetup-changedPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: template-haskell

API changes (from Hackage documentation)

Files

• LICENSE +1/−1
• Setup.lhs +99/−4
• emgm.cabal +40/−47
• examples/Ex00StartHere.hs +1/−1
• examples/Ex01UsingFunctions.hs +1/−1
• examples/Ex02AddingDatatypeSupport.hs +2/−3
• examples/Ex03DefiningFunctions.hs +1/−1
• src/Generics/EMGM.hs +39/−22
• src/Generics/EMGM/Common.hs +1/−3
• src/Generics/EMGM/Common/Base.hs +1/−1
• src/Generics/EMGM/Common/Base2.hs +1/−1
• src/Generics/EMGM/Common/Base3.hs +1/−1
• src/Generics/EMGM/Common/Derive.hs +0/−538
• src/Generics/EMGM/Common/Derive/Common.hs +0/−147
• src/Generics/EMGM/Common/Derive/ConDescr.hs +0/−113
• src/Generics/EMGM/Common/Derive/EP.hs +0/−155
• src/Generics/EMGM/Common/Derive/Instance.hs +0/−295
• src/Generics/EMGM/Common/Representation.hs +1/−1
• src/Generics/EMGM/Data.hs +0/−31
• src/Generics/EMGM/Data/Bool.hs +47/−15
• src/Generics/EMGM/Data/Either.hs +54/−18
• src/Generics/EMGM/Data/List.hs +54/−30
• src/Generics/EMGM/Data/Maybe.hs +50/−27
• src/Generics/EMGM/Data/TH.hs +24/−24
• src/Generics/EMGM/Data/Tuple.hs +389/−70
• src/Generics/EMGM/Derive.hs +311/−0
• src/Generics/EMGM/Derive/Common.hs +342/−0
• src/Generics/EMGM/Derive/ConDescr.hs +113/−0
• src/Generics/EMGM/Derive/EP.hs +125/−0
• src/Generics/EMGM/Derive/Functions.hs +92/−0
• src/Generics/EMGM/Derive/Instance.hs +266/−0
• src/Generics/EMGM/Derive/Internal.hs +675/−0
• src/Generics/EMGM/Functions.hs +3/−1
• src/Generics/EMGM/Functions/Collect.hs +14/−14
• src/Generics/EMGM/Functions/Compare.hs +1/−1
• src/Generics/EMGM/Functions/Crush.hs +1/−1
• src/Generics/EMGM/Functions/Enum.hs +1/−1
• src/Generics/EMGM/Functions/Everywhere.hs +266/−0
• src/Generics/EMGM/Functions/Map.hs +48/−7
• src/Generics/EMGM/Functions/Read.hs +1/−1
• src/Generics/EMGM/Functions/Show.hs +1/−1
• src/Generics/EMGM/Functions/UnzipWith.hs +1/−1
• src/Generics/EMGM/Functions/ZipWith.hs +1/−1
• tests/Base.hs +9/−0
• tests/Bimap.hs +10/−0
• tests/Collect.hs +9/−0
• tests/Compare.hs +9/−0
• tests/Crush.hs +9/−0
• tests/Derive.hs +37/−24
• tests/Enum.hs +9/−0
• tests/Everywhere.hs +128/−0
• tests/Main.hs +11/−0
• tests/Map.hs +36/−3
• tests/ReadShow.hs +9/−0
• tests/TTree.hs +12/−86
• tests/UnzipWith.hs +9/−0
• tests/ZipWith.hs +9/−0
• util/hpc.lhs +9/−0

@@ -1,4 +1,4 @@-Copyright (c) 2008 Universiteit Utrecht+Copyright (c) 2008, 2009 Universiteit Utrecht All rights reserved.  Redistribution and use in source and binary forms, with or without modification,

@@ -1,8 +1,17 @@ #! /usr/bin/env runhaskell  \begin{code}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS -Wall #-} -{-# OPTIONS -Wall -fno-warn-missing-signatures #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Setup+-- Copyright   :  (c) 2008, 2009 Universiteit Utrecht+-- License     :  BSD3+--+-- Maintainer  :  generics@haskell.org+-----------------------------------------------------------------------------  module Main (main) where @@ -14,29 +23,50 @@   ( (</>)   ) +import Data.Version+  ( Version(..)+  )+ import Distribution.Simple   ( defaultMainWithHooks   , simpleUserHooks-  , UserHooks(runTests, haddockHook)+  , UserHooks(runTests, haddockHook, buildHook)+  , Args   )  import Distribution.Simple.LocalBuildInfo-  ( LocalBuildInfo(withPrograms)+  ( LocalBuildInfo(..)   )  import Distribution.Simple.Program   ( userSpecifyArgs   ) +import Distribution.Simple.Setup+  ( HaddockFlags+  , BuildFlags+  )++import Distribution.Package++import Distribution.PackageDescription+  ( PackageDescription(..)+  , BuildInfo(..)+  , Library(..)+  , Executable(..)+  )+ main :: IO () main = defaultMainWithHooks hooks   where     hooks = simpleUserHooks             { runTests    = runTests'             , haddockHook = haddockHook'+            , buildHook   = buildHook'             }  -- Run a 'test' binary that gets built when configured with '-ftest'.+runTests' :: Args -> Bool -> PackageDescription -> LocalBuildInfo -> IO () runTests' _ _ _ _ = system cmd >> return ()   where testdir = "dist" </> "build" </> "test"         testcmd = "." </> "test"@@ -45,9 +75,74 @@ -- 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 }+haddockHook' :: PackageDescription -> LocalBuildInfo -> UserHooks -> HaddockFlags -> IO ()+haddockHook' pkg lbi =+  haddockHook simpleUserHooks pkg (lbi { withPrograms = p })   where     p = userSpecifyArgs "haddock" ["--optghc=-D__HADDOCK__"] (withPrograms lbi)++-- Insert CPP flag for building with template-haskell versions >= 2.3. This was+-- previously done in the .cabal file, but it was not backwards compatible with+-- Cabal 1.2. This should work with Cabal from 1.2 to 1.6 at least.+buildHook' :: PackageDescription -> LocalBuildInfo -> UserHooks -> BuildFlags -> IO ()+buildHook' pkg lbi hooks flags = do+  buildHook simpleUserHooks pkg (lbi { localPkgDescr = newPkgDescr }) hooks flags+  where++    -- Old local package description+    oldPkgDescr = localPkgDescr lbi++    -- New local package description+    newPkgDescr =+      case thVersion of+        Nothing      ->+          oldPkgDescr+        Just version ->+          if version >= Version [2,3] []+          then+            oldPkgDescr+              { library = addThCppToLibrary (library oldPkgDescr)+              , executables = map addThCppToExec (executables oldPkgDescr)+              }+          else+            oldPkgDescr++    -- Template Haskell package name+    thPackageName = mkPackageName "template-haskell"++    mkPackageName :: (Read a) => String -> a+    mkPackageName nm =+      fst $ head $ reads shownNm ++ reads ("PackageName " ++ shownNm)+      where+        shownNm = show nm++    -- template-haskell version+    thVersion = findThVersion (packageDeps lbi)++    -- CPP options for template-haskell >= 2.3+    thCppOpt = "-DTH_LOC_DERIVEREP"++    -- Find the version of the template-haskell package+    findThVersion []          = Nothing+    findThVersion (PackageIdentifier name version:ps)+      | name == thPackageName = Just version+      | otherwise             = findThVersion ps++    -- Add the template-haskell CPP flag to a BuildInfo+    addThCppToBuildInfo :: BuildInfo -> BuildInfo+    addThCppToBuildInfo bi =+      bi { cppOptions = thCppOpt : cppOptions bi }++    -- Add the template-haskell CPP flag to a library package description+    addThCppToLibrary :: Maybe Library -> Maybe Library+    addThCppToLibrary ml = do+      lib <- ml+      return (lib { libBuildInfo = addThCppToBuildInfo (libBuildInfo lib) })++    -- Add the template-haskell CPP flag to an executable package description+    addThCppToExec :: Executable -> Executable+    addThCppToExec exec =+      exec { buildInfo = addThCppToBuildInfo (buildInfo exec) }  \end{code} 

@@ -1,5 +1,5 @@ name:                   emgm-version:                0.2+version:                0.3 synopsis:               Extensible and Modular Generics for the Masses homepage:               http://www.cs.uu.nl/wiki/GenericProgramming/EMGM description:@@ -11,31 +11,39 @@   because they all share a common structure, we can write generic functions that   work on this structure.   .-  The library provides three main components:+  The primary features of the library are:   .-  (1) 'Common' - /A common foundation for building generic functions and adding support for datatypes./-  This includes the collection of datatypes (e.g. sum, product, unit) and type-  classes (e.g. 'Generic', 'Rep'), that are used throughout the library. This is-  what you need to define your own generic functions, to add generic support for-  your datatype, or to define ad-hoc cases.+  * /A platform for building generic functions and adding support for user-defined datatypes./   .-  (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 includes an important collection of datatypes (e.g. sum, product, and+  unit) and type classes (e.g. @Generic@ and @Rep@). Everything you need for+  your own generic functions or datatypes can be found here.   .-  (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.+  * /Many useful generic functions./   .-  For more information on the EMGM library, see the homepage:+  These provide a wide range of functionality. For example, there is @crush@+  ("Generics.EMGM.Functions.Crush"), a generalization of the foldl/foldr+  functions, that allows you to flexibly extract the elements of a polymorphic+  container. Now, you can do many of the operations with your container that+  were previously only available for lists.+  .+  Different generic functions work with different kinds of types as well. For+  example, @collect@ ("Generics.EMGM.Functions.Collect") works with any fully+  applied type while @bimap@ ("Generics.EMGM.Functions.Map") only works with+  bifunctor types such as @Either@ or @(,)@ (pairs).+  .+  * /Support for standard and user-defined datatypes./+  .+  EMGM provides full support for standard types such as @[]@ (lists), tuples,+  and @Maybe@ as well as many types you define in your own code. Using the+  Template Haskell functions provided in "Generics.EMGM.Derive", it is very+  simple to add support for using generic functions with your datatype+  .+  For more information on EMGM, see   <http://www.cs.uu.nl/wiki/GenericProgramming/EMGM>  category:               Generics-copyright:              (c) 2008 Universiteit Utrecht+copyright:              (c) 2008, 2009 Universiteit Utrecht license:                BSD3 license-file:           LICENSE author:                 Sean Leather,@@ -56,6 +64,7 @@                         tests/Crush.hs,                         tests/Derive.hs,                         tests/Enum.hs,+                        tests/Everywhere.hs,                         tests/Main.hs,                         tests/Map.hs,                         tests/ReadShow.hs,@@ -70,10 +79,6 @@  -------------------------------------------------------------------------------- -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.@@ -104,7 +109,6 @@                         Generics.EMGM.Common.Base                         Generics.EMGM.Common.Base2                         Generics.EMGM.Common.Base3-                        Generics.EMGM.Common.Derive                          -- Generic functions                         Generics.EMGM.Functions@@ -112,6 +116,7 @@                         Generics.EMGM.Functions.Compare                         Generics.EMGM.Functions.Crush                         Generics.EMGM.Functions.Enum+                        Generics.EMGM.Functions.Everywhere                         Generics.EMGM.Functions.Map                         Generics.EMGM.Functions.Read                         Generics.EMGM.Functions.Show@@ -119,7 +124,6 @@                         Generics.EMGM.Functions.UnzipWith                          -- Supported datatypes-                        Generics.EMGM.Data                         Generics.EMGM.Data.Bool                         Generics.EMGM.Data.Either                         Generics.EMGM.Data.List@@ -127,21 +131,18 @@                         Generics.EMGM.Data.Tuple                         Generics.EMGM.Data.TH -  other-modules:        Generics.EMGM.Common.Derive.Common-                        Generics.EMGM.Common.Derive.ConDescr-                        Generics.EMGM.Common.Derive.EP-                        Generics.EMGM.Common.Derive.Instance+                        -- Deriving+                        Generics.EMGM.Derive -  build-depends:        base >= 3.0 && < 4.0,-                        template-haskell < 2.4+  other-modules:        Generics.EMGM.Derive.Common+                        Generics.EMGM.Derive.ConDescr+                        Generics.EMGM.Derive.EP+                        Generics.EMGM.Derive.Functions+                        Generics.EMGM.Derive.Instance+                        Generics.EMGM.Derive.Internal -  -- 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+  build-depends:        base >= 3.0 && < 4.0,+                        template-haskell >= 2.2 && < 2.4    extensions:           CPP @@ -170,15 +171,7 @@   main-is:              Main.hs    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+                        template-haskell >= 2.2 && < 2.4    -- Only enable the build-depends here if configured with "-ftest". This   -- allows users to use EMGM without having to install QuickCheck.

@@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Ex00StartHere--- Copyright   :  (c) 2008 Universiteit Utrecht+-- Copyright   :  (c) 2008, 2009 Universiteit Utrecht -- License     :  BSD3 -- -- Maintainer  :  generics@haskell.org

@@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Ex01UsingFunctions--- Copyright   :  (c) 2008 Universiteit Utrecht+-- Copyright   :  (c) 2008, 2009 Universiteit Utrecht -- License     :  BSD3 -- -- Maintainer  :  generics@haskell.org

@@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Ex02AddingDatatypeSupport--- Copyright   :  (c) 2008 Universiteit Utrecht+-- Copyright   :  (c) 2008, 2009 Universiteit Utrecht -- License     :  BSD3 -- -- Maintainer  :  generics@haskell.org@@ -25,8 +25,7 @@  module Ex02AddingDatatypeSupport where -import Generics.EMGM.Common-import Generics.EMGM.Data()+import Generics.EMGM.Derive import qualified Generics.EMGM.Functions as G  -- Using generic functions on your own datatypes

@@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Ex03DefiningFunctions--- Copyright   :  (c) 2008 Universiteit Utrecht+-- Copyright   :  (c) 2008, 2009 Universiteit Utrecht -- License     :  BSD3 -- -- Maintainer  :  generics@haskell.org

@@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Generics.EMGM--- Copyright   :  (c) 2008 Universiteit Utrecht+-- Copyright   :  (c) 2008, 2009 Universiteit Utrecht -- License     :  BSD3 -- -- Maintainer  :  generics@haskell.org@@ -22,9 +22,9 @@ -- * "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.+--+-- * "Generics.EMGM.Derive" - Generating the EMGM representation for a datatype. -----------------------------------------------------------------------------  module Generics.EMGM (@@ -121,18 +121,13 @@    -- ** 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,+  -- | The necessary values and instances for using EMGM with a user-defined+  -- datatype can be generated automatically using Template Haskell. By+  -- necessity, there are a number of exported values for this process that are+  -- unrelated to other uses of the EMGM library. In order to not export these+  -- signatures more than necessary, you should import "Generics.EMGM.Derive"+  -- for deriving the representation. Note that "Generics.EMGM" does not export+  -- anything in "Generics.EMGM.Derive".    -- * Generic Functions   --@@ -144,9 +139,9 @@   --   -- More information for each of these is available in its respective module. -  -- ** Collect Functions+  -- ** Collect Function   ---  -- | Functions that collect values of one type from values of a possibly+  -- | Function that collects values of one type from values of a possibly   -- different type.   --   -- For more details, see "Generics.EMGM.Functions.Collect".@@ -227,10 +222,27 @@    empty, +  -- ** Everywhere Functions+  --+  -- | Functions that apply a transformation at every location of one type in a+  -- value of a possibly different type.+  --+  -- For more details, see "Generics.EMGM.Functions.Everywhere".++  Everywhere(..),++  everywhere,++  Everywhere'(..),++  everywhere',+   -- ** Map Functions   ---  -- | Functions that apply non-generic functions to every element in a-  -- polymorphic (functor or bifunctor) container.+  -- | Functions that translate values of one type to values of another. This+  -- includes map-like functions that apply non-generic functions to every+  -- element in a polymorphic (functor or bifunctor) container. It also includes+  -- 'cast', a configurable, type-safe casting function.   --   -- For more details, see "Generics.EMGM.Functions.Map". @@ -242,6 +254,8 @@    bimap, +  cast,+   -- ** Read Functions   --   -- | Functions similar to @deriving 'Prelude.Read'@ that parse a string and return a@@ -304,7 +318,10 @@ 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 ()+-- Export the instances from these+import Generics.EMGM.Data.Bool()+import Generics.EMGM.Data.Either()+import Generics.EMGM.Data.List()+import Generics.EMGM.Data.Maybe()+import Generics.EMGM.Data.Tuple() 

@@ -1,7 +1,7 @@ -----------------------------------------------------------------------------
 -- |
 -- Module      :  Generics.EMGM.Common
--- Copyright   :  (c) 2008 Universiteit Utrecht
+-- Copyright   :  (c) 2008, 2009 Universiteit Utrecht
 -- License     :  BSD3
 --
 -- Maintainer  :  generics@haskell.org
@@ -17,7 +17,6 @@   module Generics.EMGM.Common.Base,
   module Generics.EMGM.Common.Base2,
   module Generics.EMGM.Common.Base3,
-  module Generics.EMGM.Common.Derive,
 
 ) where
 
@@ -25,5 +24,4 @@ import Generics.EMGM.Common.Base
 import Generics.EMGM.Common.Base2
 import Generics.EMGM.Common.Base3
-import Generics.EMGM.Common.Derive
 

@@ -6,7 +6,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Generics.EMGM.Common.Base--- Copyright   :  (c) 2008 Universiteit Utrecht+-- Copyright   :  (c) 2008, 2009 Universiteit Utrecht -- License     :  BSD3 -- -- Maintainer  :  generics@haskell.org

@@ -4,7 +4,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Generics.EMGM.Common.Base2--- Copyright   :  (c) 2008 Universiteit Utrecht+-- Copyright   :  (c) 2008, 2009 Universiteit Utrecht -- License     :  BSD3 -- -- Maintainer  :  generics@haskell.org

@@ -4,7 +4,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Generics.EMGM.Common.Base3--- Copyright   :  (c) 2008 Universiteit Utrecht+-- Copyright   :  (c) 2008, 2009 Universiteit Utrecht -- License     :  BSD3 -- -- Maintainer  :  generics@haskell.org

@@ -1,538 +0,0 @@-{-# 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-

@@ -1,147 +0,0 @@-{-# 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 ""-

@@ -1,113 +0,0 @@-{-# 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-

@@ -1,155 +0,0 @@-{-# 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-

@@ -1,295 +0,0 @@-{-# 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-

@@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Generics.EMGM.Common.Representation--- Copyright   :  (c) 2008 Universiteit Utrecht+-- Copyright   :  (c) 2008, 2009 Universiteit Utrecht -- License     :  BSD3 -- -- Maintainer  :  generics@haskell.org

@@ -1,31 +0,0 @@------------------------------------------------------------------------------
--- |
--- Module      :  Generics.EMGM.Data
--- Copyright   :  (c) 2008 Universiteit Utrecht
--- License     :  BSD3
---
--- Maintainer  :  generics@haskell.org
--- Stability   :  experimental
--- Portability :  non-portable
---
--- Exports all modules in Generics.EMGM.Data.* for convenience.
------------------------------------------------------------------------------
-
-module Generics.EMGM.Data (
-
-  module Generics.EMGM.Data.Bool,
-  module Generics.EMGM.Data.Either,
-  module Generics.EMGM.Data.List,
-  module Generics.EMGM.Data.Maybe,
-  module Generics.EMGM.Data.Tuple,
-  module Generics.EMGM.Data.TH,
-
-) where
-
-import Generics.EMGM.Data.Bool
-import Generics.EMGM.Data.Either
-import Generics.EMGM.Data.List
-import Generics.EMGM.Data.Maybe
-import Generics.EMGM.Data.Tuple
-import Generics.EMGM.Data.TH
-

@@ -11,7 +11,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Generics.EMGM.Data.Bool--- Copyright   :  (c) 2008 Universiteit Utrecht+-- Copyright   :  (c) 2008, 2009 Universiteit Utrecht -- License     :  BSD3 -- -- Maintainer  :  generics@haskell.org@@ -19,21 +19,20 @@ -- Portability :  non-portable -- -- Summary: Generic representation and instances for 'Bool'.------ 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 (   epBool,   conFalse,   conTrue,+  repBool,+  frepBool,+  frep2Bool,+  frep3Bool,+  bifrep2Bool, ) where -import Generics.EMGM.Common-import Generics.EMGM.Functions.Collect+import Generics.EMGM.Derive.Internal  #ifndef __HADDOCK__ @@ -55,7 +54,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 @@ -63,27 +62,60 @@ -- Representation values ----------------------------------------------------------------------------- --- | Constructor description for 'False'+-- | Constructor description for 'False'. conFalse :: ConDescr conFalse = ConDescr "False" 0 [] Nonfix --- | Constructor description for 'True'+-- | 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)+-- | Representation of 'Bool' for 'rep'.+repBool :: (Generic g) => g Bool+repBool =+  rtype+    epBool+    (rcon conFalse runit `rsum` rcon conTrue runit) +-- | Representation of 'Bool' for 'frep'.+frepBool :: (Generic g) => g Bool+frepBool =+  repBool++-- | Representation of 'Bool' for 'frep2'.+frep2Bool :: (Generic2 g) => g Bool Bool+frep2Bool =+  rtype2+    epBool epBool+    (rcon2 conFalse runit2 `rsum2` rcon2 conTrue runit2)++-- | Representation of 'Bool' for 'frep3'.+frep3Bool :: (Generic3 g) => g Bool Bool Bool+frep3Bool =+  rtype3+    epBool epBool epBool+    (rcon3 conFalse runit3 `rsum3` rcon3 conTrue runit3)++-- | Representation of 'Bool' for 'bifrep2'.+bifrep2Bool :: (Generic2 g) => g Bool Bool+bifrep2Bool =+  frep2Bool+ ----------------------------------------------------------------------------- -- Instance declarations -----------------------------------------------------------------------------  instance (Generic g) => Rep g Bool where-  rep = rBool+  rep = repBool  instance Rep (Collect Bool) Bool where   rep = Collect (:[])++instance Rep (Everywhere Bool) Bool where+  rep = Everywhere ($)++instance Rep (Everywhere' Bool) Bool where+  rep = Everywhere' ($)  #endif 

@@ -11,7 +11,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Generics.EMGM.Data.Either--- Copyright   :  (c) 2008 Universiteit Utrecht+-- Copyright   :  (c) 2008, 2009 Universiteit Utrecht -- License     :  BSD3 -- -- Maintainer  :  generics@haskell.org@@ -19,21 +19,20 @@ -- Portability :  non-portable -- -- Summary: Generic representation and instances for 'Either'.------ 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 (   epEither,   conLeft,   conRight,+  repEither,+  frepEither,+  frep2Either,+  frep3Either,+  bifrep2Either, ) where -import Generics.EMGM.Common-import Generics.EMGM.Functions.Collect+import Generics.EMGM.Derive.Internal  #ifndef __HADDOCK__ @@ -55,7 +54,7 @@ toEither (L a) = Left a toEither (R b) = Right b --- | Embedding-projection pair for 'Either'+-- | Embedding-projection pair for 'Either'. epEither :: EP (Either a b) (a :+: b) epEither = EP fromEither toEither @@ -63,32 +62,69 @@ -- Representation values ----------------------------------------------------------------------------- --- | Constructor description for 'Left'+-- | Constructor description for 'Left'. conLeft :: ConDescr conLeft = ConDescr "Left" 1 [] Nonfix --- | Constructor description for 'Right'+-- | Constructor description for 'Right'. conRight :: ConDescr conRight = ConDescr "Right" 1 [] Nonfix --- | Representation for @Either a b@ in 'Generic'-rEither :: (Generic g) => g a -> g b -> g (Either a b)-rEither ra rb = rtype epEither (rcon conLeft ra `rsum` rcon conRight rb)+-- | Representation of 'Either' for 'frep'.+frepEither :: (Generic g) => g a -> g b -> g (Either a b)+frepEither ra rb =+  rtype+    epEither+    (rcon conLeft ra `rsum` rcon conRight rb) +-- | Representation of 'Either' for 'rep'.+repEither :: (Generic g, Rep g a, Rep g b) => g (Either a b)+repEither =+  frepEither rep rep++-- | Representation of 'Either' for 'frep2'.+frep2Either :: (Generic2 g) => g a1 a2 -> g b1 b2 -> g (Either a1 b1) (Either a2 b2)+frep2Either ra rb =+  rtype2+    epEither epEither+    (rcon2 conLeft ra `rsum2` rcon2 conRight rb)++-- | Representation of 'Either' for 'bifrep2'.+bifrep2Either :: (Generic2 g) => g a1 a2 -> g b1 b2 -> g (Either a1 b1) (Either a2 b2)+bifrep2Either =+  frep2Either++-- | Representation of 'Either' for 'frep3'.+frep3Either :: (Generic3 g) => g a1 a2 a3 -> g b1 b2 b3 -> g (Either a1 b1) (Either a2 b2) (Either a3 b3)+frep3Either ra rb =+  rtype3+    epEither epEither epEither+    (rcon3 conLeft ra `rsum3` rcon3 conRight rb)+ ----------------------------------------------------------------------------- -- Instance declarations -----------------------------------------------------------------------------  instance (Generic g, Rep g a, Rep g b) => Rep g (Either a b) where-  rep = rEither rep rep+  rep = repEither  instance (Generic2 g) => BiFRep2 g Either where-  bifrep2 ra rb =-    rtype2 epEither epEither $-      rcon2 conLeft ra `rsum2` rcon2 conRight rb+  bifrep2 = bifrep2Either  instance Rep (Collect (Either a b)) (Either a b) where   rep = Collect (:[])++instance (Rep (Everywhere (Either a b)) a, Rep (Everywhere (Either a b)) b)+         => Rep (Everywhere (Either a b)) (Either a b) where+  rep = Everywhere app+    where+      app f x =+        case x of+          Left a  -> f (Left (selEverywhere rep f a))+          Right b -> f (Right (selEverywhere rep f b))++instance Rep (Everywhere' (Either a b)) (Either a b) where+  rep = Everywhere' ($)  #endif 

@@ -1,5 +1,6 @@ {-# LANGUAGE TypeOperators          #-} {-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE FlexibleContexts       #-} {-# LANGUAGE MultiParamTypeClasses  #-} {-# LANGUAGE OverlappingInstances   #-} {-# OPTIONS -fno-warn-orphans       #-}@@ -7,7 +8,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Generics.EMGM.Data.List--- Copyright   :  (c) 2008 Universiteit Utrecht+-- Copyright   :  (c) 2008, 2009 Universiteit Utrecht -- License     :  BSD3 -- -- Maintainer  :  generics@haskell.org@@ -15,21 +16,20 @@ -- Portability :  non-portable -- -- Summary: Generic representation and instances for lists.------ 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 (   epList,   conNil,   conCons,+  repList,+  frepList,+  frep2List,+  frep3List,+  bifrep2List, ) where -import Generics.EMGM.Common-import Generics.EMGM.Functions.Collect+import Generics.EMGM.Derive.Internal  ----------------------------------------------------------------------------- -- Embedding-projection pair@@ -43,7 +43,7 @@ toList (L Unit)        =  [] toList (R (a :*: as))  =  a : as --- | Embedding-projection pair for lists+-- | Embedding-projection pair for lists. epList :: EP [a] (Unit :+: (a :*: [a])) epList = EP fromList toList @@ -51,48 +51,72 @@ -- Representation values ----------------------------------------------------------------------------- --- | Constructor description for ''nil'': @[]@+-- | Constructor description for ''nil'': @[]@. conNil :: ConDescr conNil = ConDescr "[]" 0 [] Nonfix --- | Constructor description for ''cons'': @(:)@+-- | 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 of lists for 'frep'.+frepList :: (Generic g) => g a -> g [a]+frepList ra =+  rtype+    epList+    (rcon conNil runit `rsum` rcon conCons (ra `rprod` frepList ra)) --- | 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 of lists for 'rep'.+repList :: (Generic g, Rep g a) => g [a]+repList =+  frepList rep --- | Representation for lists in 'Generic3'-rList3 :: (Generic3 g) => g a b c -> g [a] [b] [c]-rList3 ra =-  rtype3 epList epList epList-    (rcon3 conNil runit3 `rsum3` rcon3 conCons (ra `rprod3` rList3 ra))+-- | Representation of lists for 'frep2'.+frep2List :: (Generic2 g) => g a b -> g [a] [b]+frep2List ra =+  rtype2+    epList epList+    (rcon2 conNil runit2 `rsum2` rcon2 conCons (ra `rprod2` frep2List ra)) +-- | Representation of lists for 'bifrep2'.+bifrep2List :: (Generic2 g) => g a b -> g [a] [b]+bifrep2List =+  frep2List++-- | Representation of lists for 'frep3'.+frep3List :: (Generic3 g) => g a b c -> g [a] [b] [c]+frep3List ra =+  rtype3+    epList epList epList+    (rcon3 conNil runit3 `rsum3` rcon3 conCons (ra `rprod3` frep3List ra))+ ----------------------------------------------------------------------------- -- Instance declarations -----------------------------------------------------------------------------  instance (Generic g, Rep g a) => Rep g [a] where-  rep = rList rep+  rep = repList  instance (Generic g) => FRep g [] where-  frep = rList+  frep = frepList  instance (Generic2 g) => FRep2 g [] where-  frep2 = rList2+  frep2 = frep2List  instance (Generic3 g) => FRep3 g [] where-  frep3 = rList3+  frep3 = frep3List  instance Rep (Collect [a]) [a] where   rep = Collect (:[])++instance (Rep (Everywhere [a]) a) => Rep (Everywhere [a]) [a] where+  rep = Everywhere app+    where+      app f x =+        case x of+          []   -> f []+          a:as -> f (selEverywhere rep f a : selEverywhere rep f as)++instance Rep (Everywhere' [a]) [a] where+  rep = Everywhere' ($) 

@@ -11,7 +11,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Generics.EMGM.Data.Maybe--- Copyright   :  (c) 2008 Universiteit Utrecht+-- Copyright   :  (c) 2008, 2009 Universiteit Utrecht -- License     :  BSD3 -- -- Maintainer  :  generics@haskell.org@@ -19,21 +19,20 @@ -- Portability :  non-portable -- -- 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 (   epMaybe,   conNothing,   conJust,+  repMaybe,+  frepMaybe,+  frep2Maybe,+  frep3Maybe,+  bifrep2Maybe, ) where -import Generics.EMGM.Common-import Generics.EMGM.Functions.Collect+import Generics.EMGM.Derive.Internal  #ifndef __HADDOCK__ @@ -55,7 +54,7 @@ toMaybe (L Unit)  =  Nothing toMaybe (R a)     =  Just a --- | Embedding-projection pair for 'Maybe'+-- | Embedding-projection pair for 'Maybe'. epMaybe :: EP (Maybe a) (Unit :+: a) epMaybe = EP fromMaybe toMaybe @@ -63,30 +62,43 @@ -- Representation values ----------------------------------------------------------------------------- --- | Constructor description for 'Nothing'+-- | Constructor description for 'Nothing'. conNothing :: ConDescr conNothing = ConDescr "Nothing" 0 [] Nonfix --- | Constructor description for 'Just'+-- | 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 =-  rtype epMaybe+-- | Representation of 'Maybe' for 'frep'.+frepMaybe :: (Generic g) => g a -> g (Maybe a)+frepMaybe ra =+  rtype+    epMaybe     (rcon conNothing runit `rsum` rcon conJust ra) --- | Representation for @Maybe a@ in 'Generic2'-rMaybe2 :: (Generic2 g) => g a b -> g (Maybe a) (Maybe b)-rMaybe2 ra =-  rtype2 epMaybe epMaybe+-- | Representation of 'Maybe' for 'rep'.+repMaybe :: (Generic g, Rep g a) => g (Maybe a)+repMaybe =+  frepMaybe rep++-- | Representation of 'Maybe' for 'frep2'.+frep2Maybe :: (Generic2 g) => g a b -> g (Maybe a) (Maybe b)+frep2Maybe ra =+  rtype2+    epMaybe epMaybe     (rcon2 conNothing runit2 `rsum2` rcon2 conJust ra) --- | Representation for @Maybe a@ in 'Generic3'-rMaybe3 :: (Generic3 g) => g a b c -> g (Maybe a) (Maybe b) (Maybe c)-rMaybe3 ra =-  rtype3 epMaybe epMaybe epMaybe+-- | Representation of 'Maybe' for 'bifrep2'.+bifrep2Maybe :: (Generic2 g) => g a b -> g (Maybe a) (Maybe b)+bifrep2Maybe =+  frep2Maybe++-- | Representation of 'Maybe' for 'frep3'.+frep3Maybe :: (Generic3 g) => g a b c -> g (Maybe a) (Maybe b) (Maybe c)+frep3Maybe ra =+  rtype3+    epMaybe epMaybe epMaybe     (rcon3 conNothing runit3 `rsum3` rcon3 conJust ra)  -----------------------------------------------------------------------------@@ -94,19 +106,30 @@ -----------------------------------------------------------------------------  instance (Generic g, Rep g a) => Rep g (Maybe a) where-  rep = rMaybe rep+  rep = repMaybe  instance (Generic g) => FRep g Maybe where-  frep = rMaybe+  frep = frepMaybe  instance (Generic2 g) => FRep2 g Maybe where-  frep2 = rMaybe2+  frep2 = frep2Maybe  instance (Generic3 g) => FRep3 g Maybe where-  frep3 = rMaybe3+  frep3 = frep3Maybe  instance Rep (Collect (Maybe a)) (Maybe a) where   rep = Collect (:[])++instance (Rep (Everywhere (Maybe a)) a) => Rep (Everywhere (Maybe a)) (Maybe a) where+  rep = Everywhere app+    where+      app f x =+        case x of+          Nothing -> f Nothing+          Just v1 -> f (Just (selEverywhere rep f v1))++instance Rep (Everywhere' (Maybe a)) (Maybe a) where+  rep = Everywhere' ($)  #endif 

@@ -12,7 +12,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Generics.EMGM.Data.TH--- Copyright   :  (c) 2008 Universiteit Utrecht+-- Copyright   :  (c) 2008, 2009 Universiteit Utrecht -- License     :  BSD3 -- -- Maintainer  :  generics@haskell.org@@ -33,39 +33,39 @@  module Generics.EMGM.Data.TH where -import Generics.EMGM.Common hiding (Fixity, ConDescr(..))+import Generics.EMGM.Derive.Internal hiding (conName, conFixity, Fixity) 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)+$(deriveMono ''Name)+$(deriveMono ''Dec)+$(deriveMono ''Exp)+$(deriveMono ''Con)+$(deriveMono ''Type)+$(deriveMono ''Match)+$(deriveMono ''Clause)+$(deriveMono ''Body)+$(deriveMono ''Guard)+$(deriveMono ''Stmt)+$(deriveMono ''Range)+$(deriveMono ''Lit)+$(deriveMono ''Pat)+$(deriveMono ''Strict)+$(deriveMono ''Foreign)+$(deriveMono ''Callconv)+$(deriveMono ''Safety)+$(deriveMono ''FunDep)+$(deriveMono ''Info)  #ifdef TH_LOC_DERIVEREP -- This type is only provided in template-haskell-2.3 (included with GHC 6.10) -- and up.-$(derive ''Loc)+$(deriveMono ''Loc) #endif -$(derive ''Fixity)-$(derive ''FixityDirection)+$(deriveMono ''Fixity)+$(deriveMono ''FixityDirection)  #endif 

@@ -1,5 +1,6 @@ {-# LANGUAGE TypeOperators          #-} {-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE FlexibleContexts       #-} {-# LANGUAGE MultiParamTypeClasses  #-} {-# LANGUAGE OverlappingInstances   #-} {-# OPTIONS -fno-warn-orphans       #-}@@ -7,7 +8,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Generics.EMGM.Data.Tuple--- Copyright   :  (c) 2008 Universiteit Utrecht+-- Copyright   :  (c) 2008, 2009 Universiteit Utrecht -- License     :  BSD3 -- -- Maintainer  :  generics@haskell.org@@ -16,11 +17,6 @@ -- -- Summary: Generic representation and instances for tuples of arity 0 -- (''unit'') and 2 to 7.------ 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 (@@ -28,203 +24,406 @@   -- * Unit: @()@   epTuple0,   conTuple0,+  repTuple0,+  frepTuple0,+  frep2Tuple0,+  frep3Tuple0,+  bifrep2Tuple0,    -- * Pair: @(a,b)@   epTuple2,   conTuple2,+  repTuple2,+  frepTuple2,+  frep2Tuple2,+  frep3Tuple2,+  bifrep2Tuple2,    -- * Triple: @(a,b,c)@   epTuple3,   conTuple3,+  repTuple3,+  frepTuple3,+  frep2Tuple3,+  frep3Tuple3,+  bifrep2Tuple3,    -- * Quadruple: @(a,b,c,d)@   epTuple4,   conTuple4,+  repTuple4,+  frepTuple4,+  frep2Tuple4,+  frep3Tuple4,+  bifrep2Tuple4,    -- * Quintuple: @(a,b,c,d,e)@   epTuple5,   conTuple5,+  repTuple5,+  frepTuple5,+  frep2Tuple5,+  frep3Tuple5,+  bifrep2Tuple5,    -- * Sextuple: @(a,b,c,d,e,f)@   epTuple6,   conTuple6,+  repTuple6,+  frepTuple6,+  frep2Tuple6,+  frep3Tuple6,+  bifrep2Tuple6,    -- * Septuple: @(a,b,c,d,e,f,h)@   epTuple7,   conTuple7,+  repTuple7,+  frepTuple7,+  frep2Tuple7,+  frep3Tuple7,+  bifrep2Tuple7,  ) where -import Generics.EMGM.Common-import Generics.EMGM.Functions.Collect+import Generics.EMGM.Derive.Internal  ----------------------------------------------------------------------------- -- 0: () ----------------------------------------------------------------------------- --- | Embedding-projection pair for @()@+-- | Embedding-projection pair for @()@. epTuple0 :: EP () Unit epTuple0 = EP (\() -> Unit)               (\Unit -> ()) --- | Constructor description for @()@+-- | Constructor description for @()@. conTuple0 :: ConDescr conTuple0 = ConDescr "()" 0 [] Nonfix --- | Representation for @()@ in 'Generic'-rTuple0 :: (Generic g) => g ()-rTuple0 =-  rtype epTuple0 $-        rcon conTuple0 runit+-- | Representation of @()@ for 'rep'.+repTuple0 :: (Generic g) => g ()+repTuple0 =+  rtype+    epTuple0+    (rcon conTuple0 runit) +-- | Representation of @()@ for 'frep'.+frepTuple0 :: (Generic g) => g ()+frepTuple0 =+  repTuple0++-- | Representation of @()@ for 'frep2'.+frep2Tuple0 :: (Generic2 g) => g () ()+frep2Tuple0 =+  rtype2+    epTuple0 epTuple0+    (rcon2 conTuple0 runit2)++-- | Representation of @()@ for 'bifrep2'.+bifrep2Tuple0 :: (Generic2 g) => g () ()+bifrep2Tuple0 =+  frep2Tuple0++-- | Representation of @()@ for 'frep3'.+frep3Tuple0 :: (Generic3 g) => g () () ()+frep3Tuple0 =+  rtype3+    epTuple0 epTuple0 epTuple0+    (rcon3 conTuple0 runit3)+ ----------------------------------------------------------------------------- -- 2: (a,b) ----------------------------------------------------------------------------- --- | Embedding-projection pair for @(a,b)@+-- | Embedding-projection pair for @(,)@. epTuple2 :: EP (a,b) (a :*: b) epTuple2 = EP (\(a,b) -> a :*: b)               (\(a :*: b) -> (a,b)) --- | Constructor description for @(a,b)@+-- | Constructor description for @(,)@. conTuple2 :: ConDescr conTuple2 = ConDescr "(,)" 2 [] Nonfix --- | Representation for @(a,b)@ in 'Generic'-rTuple2 :: (Generic g) => g a -> g b -> g (a,b)-rTuple2 ra rb =-  rtype epTuple2 $-        rcon conTuple2 (ra `rprod` rb)+-- | Representation of @(,)@ for 'frep'.+frepTuple2 :: (Generic g) => g a -> g b -> g (a,b)+frepTuple2 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)+-- | Representation of @(,)@ for 'rep'.+repTuple2 :: (Generic g, Rep g a, Rep g b) => g (a,b)+repTuple2 =+  frepTuple2 rep rep +-- | Representation of @(,)@ for 'frep2'.+frep2Tuple2 :: (Generic2 g) => g a1 a2 -> g b1 b2 -> g (a1,b1) (a2,b2)+frep2Tuple2 ra rb =+  rtype2+    epTuple2 epTuple2+    (rcon2 conTuple2 (ra `rprod2` rb))++-- | Representation of @(,)@ for 'bifrep2'.+bifrep2Tuple2 :: (Generic2 g) => g a1 a2 -> g b1 b2 -> g (a1,b1) (a2,b2)+bifrep2Tuple2 =+  frep2Tuple2++-- | Representation of @(,)@ for 'frep3'.+frep3Tuple2 :: (Generic3 g) => g a1 a2 a3 -> g b1 b2 b3 -> g (a1,b1) (a2,b2) (a3,b3)+frep3Tuple2 ra rb =+  rtype3+    epTuple2 epTuple2 epTuple2+    (rcon3 conTuple2 (ra `rprod3` rb))+ ----------------------------------------------------------------------------- -- 3: (a,b,c) ----------------------------------------------------------------------------- --- | Embedding-projection pair for @(a,b,c)@+-- | Embedding-projection pair for @(,,)@. epTuple3 :: EP (a,b,c) (a :*: b :*: c) epTuple3 = EP (\(a,b,c) -> a :*: b :*: c)               (\(a :*: b :*: c) -> (a,b,c)) --- | Constructor description for @(a,b,c)@+-- | Constructor description for @(,,)@. conTuple3 :: ConDescr conTuple3 = ConDescr "(,,)" 3 [] Nonfix --- | Representation for @(a,b,c)@ in 'Generic'-rTuple3 :: (Generic g) => g a -> g b -> g c -> g (a,b,c)-rTuple3 ra rb rc =-  rtype epTuple3 $-        rcon conTuple3 (ra `rprod` rb `rprod` rc)+-- | Representation of @(,,)@ for 'frep'.+frepTuple3 :: (Generic g) => g a -> g b -> g c -> g (a,b,c)+frepTuple3 ra rb rc =+  rtype+    epTuple3+    (rcon conTuple3 (ra `rprod` rb `rprod` rc)) +-- | Representation of @(,,)@ for 'rep'.+repTuple3 :: (Generic g, Rep g a, Rep g b, Rep g c) => g (a,b,c)+repTuple3 =+  frepTuple3 rep rep rep++-- | Representation of @(,,)@ for 'frep2'.+frep2Tuple3 :: (Generic2 g) => g a1 a2 -> g b1 b2 -> g c1 c2 -> g (a1,b1,c1) (a2,b2,c2)+frep2Tuple3 ra rb rc =+  rtype2+    epTuple3 epTuple3+    (rcon2 conTuple3 (ra `rprod2` rb `rprod2` rc))++-- | Representation of @(,,)@ for 'bifrep2'.+bifrep2Tuple3 :: (Generic2 g) => g a1 a2 -> g b1 b2 -> g c1 c2 -> g (a1,b1,c1) (a2,b2,c2)+bifrep2Tuple3 =+  frep2Tuple3++-- | Representation of @(,,)@ for 'frep3'.+frep3Tuple3 :: (Generic3 g) => g a1 a2 a3 -> g b1 b2 b3 -> g c1 c2 c3 -> g (a1,b1,c1) (a2,b2,c2) (a3,b3,c3)+frep3Tuple3 ra rb rc =+  rtype3+    epTuple3 epTuple3 epTuple3+    (rcon3 conTuple3 (ra `rprod3` rb `rprod3` rc))+ ----------------------------------------------------------------------------- -- 4: (a,b,c,d) ----------------------------------------------------------------------------- --- | Embedding-projection pair for @(a,b,c,d)@+-- | Embedding-projection pair for @(,,,)@. epTuple4 :: EP (a,b,c,d) (a :*: b :*: c :*: d) epTuple4 = EP (\(a,b,c,d) -> a :*: b :*: c :*: d)               (\(a :*: b :*: c :*: d) -> (a,b,c,d)) --- | Constructor description for @(a,b,c,d)@+-- | Constructor description for @(,,,)@. conTuple4 :: ConDescr conTuple4 = ConDescr "(,,,)" 4 [] Nonfix --- | Representation for @(a,b,c,d)@ in 'Generic'-rTuple4 :: (Generic g) => g a -> g b -> g c -> g d -> g (a,b,c,d)-rTuple4 ra rb rc rd =-  rtype epTuple4 $-        rcon conTuple4 (ra `rprod` rb `rprod` rc `rprod` rd)+-- | Representation of @(,,,)@ for 'frep'.+frepTuple4 :: (Generic g) => g a -> g b -> g c -> g d -> g (a,b,c,d)+frepTuple4 ra rb rc rd =+  rtype+    epTuple4+    (rcon conTuple4 (ra `rprod` rb `rprod` rc `rprod` rd)) +-- | Representation of @(,,,)@ for 'rep'.+repTuple4 :: (Generic g, Rep g a, Rep g b, Rep g c, Rep g d) => g (a,b,c,d)+repTuple4 =+  frepTuple4 rep rep rep rep++-- | Representation of @(,,,)@ for 'frep2'.+frep2Tuple4 :: (Generic2 g) => g a1 a2 -> g b1 b2 -> g c1 c2 -> g d1 d2 -> g (a1,b1,c1,d1) (a2,b2,c2,d2)+frep2Tuple4 ra rb rc rd =+  rtype2+    epTuple4 epTuple4+    (rcon2 conTuple4 (ra `rprod2` rb `rprod2` rc `rprod2` rd))++-- | Representation of @(,,,)@ for 'bifrep2'.+bifrep2Tuple4 :: (Generic2 g) => g a1 a2 -> g b1 b2 -> g c1 c2 -> g d1 d2 -> g (a1,b1,c1,d1) (a2,b2,c2,d2)+bifrep2Tuple4 =+  frep2Tuple4++-- | Representation of @(,,,)@ for 'frep3'.+frep3Tuple4 :: (Generic3 g) => g a1 a2 a3 -> g b1 b2 b3 -> g c1 c2 c3 -> g d1 d2 d3 -> g (a1,b1,c1,d1) (a2,b2,c2,d2) (a3,b3,c3,d3)+frep3Tuple4 ra rb rc rd =+  rtype3+    epTuple4 epTuple4 epTuple4+    (rcon3 conTuple4 (ra `rprod3` rb `rprod3` rc `rprod3` rd))+ ----------------------------------------------------------------------------- -- 5: (a,b,c,d,e) ----------------------------------------------------------------------------- --- | Embedding-projection pair for @(a,b,c,d,e)@+-- | Embedding-projection pair for @(,,,,)@. epTuple5 :: EP (a,b,c,d,e) (a :*: b :*: c :*: d :*: e) epTuple5 = EP (\(a,b,c,d,e) -> a :*: b :*: c :*: d :*: e)               (\(a :*: b :*: c :*: d :*: e) -> (a,b,c,d,e)) --- | Constructor description for @(a,b,c,d,e)@+-- | Constructor description for @(,,,,)@. conTuple5 :: ConDescr conTuple5 = ConDescr "(,,,,)" 5 [] Nonfix --- | Representation for @(a,b,c,d,e)@ in 'Generic'-rTuple5 :: (Generic g) => g a -> g b -> g c -> g d -> g e -> g (a,b,c,d,e)-rTuple5 ra rb rc rd re =-  rtype epTuple5 $-        rcon conTuple5 (ra `rprod` rb `rprod` rc `rprod` rd `rprod` re)+-- | Representation of @(,,,,)@ for 'frep'.+frepTuple5 :: (Generic g) => g a -> g b -> g c -> g d -> g e -> g (a,b,c,d,e)+frepTuple5 ra rb rc rd re =+  rtype+    epTuple5+    (rcon conTuple5 (ra `rprod` rb `rprod` rc `rprod` rd `rprod` re)) +-- | Representation of @(,,,,)@ for 'rep'.+repTuple5 :: (Generic g, Rep g a, Rep g b, Rep g c, Rep g d, Rep g e) => g (a,b,c,d,e)+repTuple5 =+  frepTuple5 rep rep rep rep rep++-- | Representation of @(,,,,)@ for 'frep2'.+frep2Tuple5 :: (Generic2 g) => g a1 a2 -> g b1 b2 -> g c1 c2 -> g d1 d2 -> g e1 e2 -> g (a1,b1,c1,d1,e1) (a2,b2,c2,d2,e2)+frep2Tuple5 ra rb rc rd re =+  rtype2+    epTuple5 epTuple5+    (rcon2 conTuple5 (ra `rprod2` rb `rprod2` rc `rprod2` rd `rprod2` re))++-- | Representation of @(,,,,)@ for 'bfrep2'.+bifrep2Tuple5 :: (Generic2 g) => g a1 a2 -> g b1 b2 -> g c1 c2 -> g d1 d2 -> g e1 e2 -> g (a1,b1,c1,d1,e1) (a2,b2,c2,d2,e2)+bifrep2Tuple5 =+  frep2Tuple5++-- | Representation of @(,,,,)@ for 'frep3'.+frep3Tuple5 :: (Generic3 g) => g a1 a2 a3 -> g b1 b2 b3 -> g c1 c2 c3 -> g d1 d2 d3 -> g e1 e2 e3 -> g (a1,b1,c1,d1,e1) (a2,b2,c2,d2,e2) (a3,b3,c3,d3,e3)+frep3Tuple5 ra rb rc rd re =+  rtype3+    epTuple5 epTuple5 epTuple5+    (rcon3 conTuple5 (ra `rprod3` rb `rprod3` rc `rprod3` rd `rprod3` re))+ ----------------------------------------------------------------------------- -- 6: (a,b,c,d,e,f) ----------------------------------------------------------------------------- --- | Embedding-projection pair for @(a,b,c,d,e,f)@+-- | Embedding-projection pair for @(,,,,,)@. epTuple6 :: EP (a,b,c,d,e,f) (a :*: b :*: c :*: d :*: e :*: f) epTuple6 = EP (\(a,b,c,d,e,f) -> a :*: b :*: c :*: d :*: e :*: f)               (\(a :*: b :*: c :*: d :*: e :*: f) -> (a,b,c,d,e,f)) --- | Constructor description for @(a,b,c,d,e,f)@+-- | Constructor description for @(,,,,,)@. conTuple6 :: ConDescr conTuple6 = ConDescr "(,,,,,)" 6 [] Nonfix --- | Representation for @(a,b,c,d,e,f)@ in 'Generic'-rTuple6 :: (Generic g) => g a -> g b -> g c -> g d -> g e -> g f -> g (a,b,c,d,e,f)-rTuple6 ra rb rc rd re rf =-  rtype epTuple6 $-        rcon conTuple6 (ra `rprod` rb `rprod` rc `rprod` rd `rprod` re `rprod` rf)+-- | Representation of @(,,,,,)@ for 'frep'.+frepTuple6 :: (Generic g) => g a -> g b -> g c -> g d -> g e -> g f -> g (a,b,c,d,e,f)+frepTuple6 ra rb rc rd re rf =+  rtype+    epTuple6+    (rcon conTuple6 (ra `rprod` rb `rprod` rc `rprod` rd `rprod` re `rprod` rf)) +-- | Representation of @(,,,,,)@ for 'rep'.+repTuple6 :: (Generic g, Rep g a, Rep g b, Rep g c, Rep g d, Rep g e, Rep g f) => g (a,b,c,d,e,f)+repTuple6 =+  frepTuple6 rep rep rep rep rep rep +-- | Representation of @(,,,,,)@ for 'frep2'.+frep2Tuple6 :: (Generic2 g) => g a1 a2 -> g b1 b2 -> g c1 c2 -> g d1 d2 -> g e1 e2 -> g f1 f2 -> g (a1,b1,c1,d1,e1,f1) (a2,b2,c2,d2,e2,f2)+frep2Tuple6 ra rb rc rd re rf =+  rtype2+    epTuple6 epTuple6+    (rcon2 conTuple6 (ra `rprod2` rb `rprod2` rc `rprod2` rd `rprod2` re `rprod2` rf))++-- | Representation of @(,,,,,)@ for 'bifrep2'.+bifrep2Tuple6 :: (Generic2 g) => g a1 a2 -> g b1 b2 -> g c1 c2 -> g d1 d2 -> g e1 e2 -> g f1 f2 -> g (a1,b1,c1,d1,e1,f1) (a2,b2,c2,d2,e2,f2)+bifrep2Tuple6 =+  frep2Tuple6++-- | Representation of @(,,,,,)@ for 'frep3'.+frep3Tuple6 :: (Generic3 g) => g a1 a2 a3 -> g b1 b2 b3 -> g c1 c2 c3 -> g d1 d2 d3 -> g e1 e2 e3 -> g f1 f2 f3 -> g (a1,b1,c1,d1,e1,f1) (a2,b2,c2,d2,e2,f2) (a3,b3,c3,d3,e3,f3)+frep3Tuple6 ra rb rc rd re rf =+  rtype3+    epTuple6 epTuple6 epTuple6+    (rcon3 conTuple6 (ra `rprod3` rb `rprod3` rc `rprod3` rd `rprod3` re `rprod3` rf))++ ----------------------------------------------------------------------------- -- 7: (a,b,c,d,e,f,h) ----------------------------------------------------------------------------- --- | Embedding-projection pair for @(a,b,c,d,e,f,h)@+-- | Embedding-projection pair for @(,,,,,,)@. epTuple7 :: EP (a,b,c,d,e,f,h) (a :*: b :*: c :*: d :*: e :*: f :*: h) 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)@+-- | Constructor description for @(,,,,,,)@. conTuple7 :: ConDescr conTuple7 = ConDescr "(,,,,,)" 7 [] Nonfix --- | Representation for @(a,b,c,d,e,f,h)@ in 'Generic'-rTuple7 :: (Generic g) => g a -> g b -> g c -> g d -> g e -> g f -> g h -> g (a,b,c,d,e,f,h)-rTuple7 ra rb rc rd re rf rh =-  rtype epTuple7 $-        rcon conTuple7 (ra `rprod` rb `rprod` rc `rprod` rd `rprod` re `rprod` rf `rprod` rh)+-- | Representation of @(,,,,,,)@ for 'frep'.+frepTuple7 :: (Generic g) => g a -> g b -> g c -> g d -> g e -> g f -> g h -> g (a,b,c,d,e,f,h)+frepTuple7 ra rb rc rd re rf rh =+  rtype+    epTuple7+    (rcon conTuple7 (ra `rprod` rb `rprod` rc `rprod` rd `rprod` re `rprod` rf `rprod` rh)) +-- | Representation of @(,,,,,,)@ for 'rep'.+repTuple7 :: (Generic g, Rep g a, Rep g b, Rep g c, Rep g d, Rep g e, Rep g f, Rep g h) => g (a,b,c,d,e,f,h)+repTuple7 =+  frepTuple7 rep rep rep rep rep rep rep++-- | Representation of @(,,,,,,)@ for 'frep2'.+frep2Tuple7 :: (Generic2 g) => g a1 a2 -> g b1 b2 -> g c1 c2 -> g d1 d2 -> g e1 e2 -> g f1 f2 -> g h1 h2 -> g (a1,b1,c1,d1,e1,f1,h1) (a2,b2,c2,d2,e2,f2,h2)+frep2Tuple7 ra rb rc rd re rf rh =+  rtype2+    epTuple7 epTuple7+    (rcon2 conTuple7 (ra `rprod2` rb `rprod2` rc `rprod2` rd `rprod2` re `rprod2` rf `rprod2` rh))++-- | Representation of @(,,,,,,)@ for 'bifrep2'.+bifrep2Tuple7 :: (Generic2 g) => g a1 a2 -> g b1 b2 -> g c1 c2 -> g d1 d2 -> g e1 e2 -> g f1 f2 -> g h1 h2 -> g (a1,b1,c1,d1,e1,f1,h1) (a2,b2,c2,d2,e2,f2,h2)+bifrep2Tuple7 =+  frep2Tuple7++-- | Representation of @(,,,,,,)@ for 'frep3'.+frep3Tuple7 :: (Generic3 g) => g a1 a2 a3 -> g b1 b2 b3 -> g c1 c2 c3 -> g d1 d2 d3 -> g e1 e2 e3 -> g f1 f2 f3 -> g h1 h2 h3 -> g (a1,b1,c1,d1,e1,f1,h1) (a2,b2,c2,d2,e2,f2,h2) (a3,b3,c3,d3,e3,f3,h3)+frep3Tuple7 ra rb rc rd re rf rh =+  rtype3+    epTuple7 epTuple7 epTuple7+    (rcon3 conTuple7 (ra `rprod3` rb `rprod3` rc `rprod3` rd `rprod3` re `rprod3` rf `rprod3` rh))+ ----------------------------------------------------------------------------- -- Instance declarations -----------------------------------------------------------------------------  instance (Generic g) => Rep g () where-  rep = rTuple0+  rep = repTuple0  instance (Generic g, Rep g a, Rep g b) => Rep g (a,b) where-  rep = rTuple2 rep rep+  rep = repTuple2  instance (Generic g, Rep g a, Rep g b, Rep g c) => Rep g (a,b,c) where-  rep = rTuple3 rep rep rep+  rep = repTuple3  instance (Generic g, Rep g a, Rep g b, Rep g c, Rep g d) => Rep g (a,b,c,d) where-  rep = rTuple4 rep rep rep rep+  rep = repTuple4  instance (Generic g, Rep g a, Rep g b, Rep g c, Rep g d, Rep g e) => Rep g (a,b,c,d,e) where-  rep = rTuple5 rep rep rep rep rep+  rep = repTuple5  instance (Generic g, Rep g a, Rep g b, Rep g c, Rep g d, Rep g e, Rep g f) => Rep g (a,b,c,d,e,f) where-  rep = rTuple6 rep rep rep rep rep rep+  rep = repTuple6  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+  rep = repTuple7  instance (Generic2 g) => BiFRep2 g (,) where-  bifrep2 = rTuple2_2+  bifrep2 = frep2Tuple2  instance Rep (Collect ()) () where   rep = Collect (:[])@@ -246,4 +445,124 @@  instance Rep (Collect (a,b,c,d,e,f,h)) (a,b,c,d,e,f,h) where   rep = Collect (:[])++instance Rep (Everywhere' ()) () where+  rep = Everywhere' ($)++instance Rep (Everywhere' (a,b)) (a,b) where+  rep = Everywhere' ($)++instance Rep (Everywhere' (a,b,c)) (a,b,c) where+  rep = Everywhere' ($)++instance Rep (Everywhere' (a,b,c,d)) (a,b,c,d) where+  rep = Everywhere' ($)++instance Rep (Everywhere' (a,b,c,d,e)) (a,b,c,d,e) where+  rep = Everywhere' ($)++instance Rep (Everywhere' (a,b,c,d,e,f)) (a,b,c,d,e,f) where+  rep = Everywhere' ($)++instance Rep (Everywhere' (a,b,c,d,e,f,h)) (a,b,c,d,e,f,h) where+  rep = Everywhere' ($)++instance Rep (Everywhere ()) () where+  rep = Everywhere ($)++instance+  ( Rep (Everywhere (a,b)) a+  , Rep (Everywhere (a,b)) b+  ) => Rep (Everywhere (a,b)) (a,b) where+  rep = Everywhere+    (\z (a,b) -> z+      ( selEverywhere rep z a+      , selEverywhere rep z b+      )+    )++instance+  ( Rep (Everywhere (a,b,c)) a+  , Rep (Everywhere (a,b,c)) b+  , Rep (Everywhere (a,b,c)) c+  ) => Rep (Everywhere (a,b,c)) (a,b,c) where+  rep = Everywhere+    (\z (a,b,c) -> z+      ( selEverywhere rep z a+      , selEverywhere rep z b+      , selEverywhere rep z c+      )+    )++instance+  ( Rep (Everywhere (a,b,c,d)) a+  , Rep (Everywhere (a,b,c,d)) b+  , Rep (Everywhere (a,b,c,d)) c+  , Rep (Everywhere (a,b,c,d)) d+  ) => Rep (Everywhere (a,b,c,d)) (a,b,c,d) where+  rep = Everywhere+    (\z (a,b,c,d) -> z+      ( selEverywhere rep z a+      , selEverywhere rep z b+      , selEverywhere rep z c+      , selEverywhere rep z d+      )+    )++instance+  ( Rep (Everywhere (a,b,c,d,e)) a+  , Rep (Everywhere (a,b,c,d,e)) b+  , Rep (Everywhere (a,b,c,d,e)) c+  , Rep (Everywhere (a,b,c,d,e)) d+  , Rep (Everywhere (a,b,c,d,e)) e+  ) => Rep (Everywhere (a,b,c,d,e)) (a,b,c,d,e) where+  rep = Everywhere+    (\z (a,b,c,d,e) -> z+      ( selEverywhere rep z a+      , selEverywhere rep z b+      , selEverywhere rep z c+      , selEverywhere rep z d+      , selEverywhere rep z e+      )+    )++instance+  ( Rep (Everywhere (a,b,c,d,e,f)) a+  , Rep (Everywhere (a,b,c,d,e,f)) b+  , Rep (Everywhere (a,b,c,d,e,f)) c+  , Rep (Everywhere (a,b,c,d,e,f)) d+  , Rep (Everywhere (a,b,c,d,e,f)) e+  , Rep (Everywhere (a,b,c,d,e,f)) f+  ) => Rep (Everywhere (a,b,c,d,e,f)) (a,b,c,d,e,f) where+  rep = Everywhere+    (\z (a,b,c,d,e,f) -> z+      ( selEverywhere rep z a+      , selEverywhere rep z b+      , selEverywhere rep z c+      , selEverywhere rep z d+      , selEverywhere rep z e+      , selEverywhere rep z f+      )+    )++instance+  ( Rep (Everywhere (a,b,c,d,e,f,h)) a+  , Rep (Everywhere (a,b,c,d,e,f,h)) b+  , Rep (Everywhere (a,b,c,d,e,f,h)) c+  , Rep (Everywhere (a,b,c,d,e,f,h)) d+  , Rep (Everywhere (a,b,c,d,e,f,h)) e+  , Rep (Everywhere (a,b,c,d,e,f,h)) f+  , Rep (Everywhere (a,b,c,d,e,f,h)) h+  ) => Rep (Everywhere (a,b,c,d,e,f,h)) (a,b,c,d,e,f,h) where+  rep = Everywhere+    (\z (a,b,c,d,e,f,h) -> z+      ( selEverywhere rep z a+      , selEverywhere rep z b+      , selEverywhere rep z c+      , selEverywhere rep z d+      , selEverywhere rep z e+      , selEverywhere rep z f+      , selEverywhere rep z h+      )+    ) 

@@ -0,0 +1,311 @@+{-# LANGUAGE CPP                    #-}+{-# LANGUAGE TemplateHaskell        #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Generics.EMGM.Derive+-- Copyright   :  (c) 2008, 2009 Universiteit Utrecht+-- License     :  BSD3+--+-- Maintainer  :  generics@haskell.org+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Summary: Functions for generating the representation for using a datatype+-- with EMGM.+--+-- The simplest way to get a representation for a datatype is using 'derive' in+-- a Template Haskell declaration, e.g. @$('derive' ''MyType)@. This generates+-- all of the appropriate instances, e.g. 'Rep', 'FRep', etc., for the type+-- @MyType@.+--+-- Generating datatype support can be done in a fully automatic way using+-- 'derive' or 'deriveWith', or it can be done piecemeal using a number of other+-- functions. For most needs, the automatic approach is fine. But if you find+-- you need more control, use the manual deriving approach.+--+-- Naming conventions:+--+-- * @derive@ - Template Haskell function that generates instance declarations+-- (and possibly also value declarations).+--+-- * @declare@ - Template Haskell function that generates only value+-- declarations.+--+-- * @ep@ - Embedding-project pair.+--+-- * @con@ - Constructor description.+--+-- * @rep@ - Value representation meant for 'rep'.+--+-- * @frep@ - Value representation meant for 'frep'.+--+-- * @frep2@ - Value representation meant for 'frep2'.+--+-- * @frep3@ - Value representation meant for 'frep3'.+--+-- * @bifrep2@ - Value representation meant for 'bifrep2'.+-----------------------------------------------------------------------------++module Generics.EMGM.Derive (++  -- * Automatic Instance Deriving+  --+  -- | The functions 'derive' and 'deriveWith' determine which representations+  -- can be supported by your datatype. The indications are as follows for each+  -- class:+  --+  -- ['Rep'] This instance will be generated for every type.+  --+  -- ['FRep', 'FRep2', 'FRep3'] These instances will only be generated for+  -- functor types (kind @* -> *@).+  --+  -- ['BiFRep2'] This instance will only be generated for bifunctor types (kind+  -- @* -> * -> *@).++  derive,+  deriveWith,+  Modifier(..),+  Modifiers,++  deriveMono,+  deriveMonoWith,++  -- * Manual Instance Deriving+  --+  -- | Use the functions in this section for more control over the declarations+  -- and instances that are generated.+  --+  -- Since each function here generates one component needed for the entire+  -- datatype representation, you will most likely need to use multiple TH+  -- declarations. To get the equivalent of the resulting code described in+  -- 'derive', you will need the following:+  --+  -- >   {-# LANGUAGE TemplateHaskell        #-}+  -- >   {-# LANGUAGE MultiParamTypeClasses  #-}+  -- >   {-# LANGUAGE FlexibleContexts       #-}+  -- >   {-# LANGUAGE FlexibleInstances      #-}+  -- >   {-# LANGUAGE OverlappingInstances   #-}+  -- >   {-# LANGUAGE UndecidableInstances   #-}+  --+  -- @+  --   module Example where+  --   import Generics.EMGM.Derive+  --   data T a = C a Int+  -- @+  --+  -- @+  --   $(declareConDescrs ''T)+  --   $(declareEP ''T)+  --   $(declareRepValues ''T)+  --   $(deriveRep ''T)+  --   $(deriveFRep ''T)+  --   $(deriveCollect ''T)+  --   $(deriveEverywhere ''T)+  --   $(deriveEverywhere' ''T)+  -- @++  -- ** Constructor Description Declaration+  --+  -- | Use the following to generate only the 'ConDescr' declarations.++  declareConDescrs,+  declareConDescrsWith,++  -- ** Embedding-Project Pair Declaration+  --+  -- | Use the following to generate only the 'EP' declarations.++  declareEP,+  declareEPWith,++  -- ** Representation Value Declaration+  --+  -- | Use the following to generate only the representation values that are+  -- used in the instances for 'rep', 'frep', etc.++  declareRepValues,+  declareRepValuesWith,++  declareMonoRep,+  declareMonoRepWith,++  -- ** Rep Instance Deriving+  --+  -- | Use the following to generate only the 'Rep' instances.++  deriveRep,+  deriveRepWith,++  -- ** FRep Instance Deriving+  --+  -- | Use the following to generate only the 'FRep', 'FRep2', and 'FRep3'+  -- instances.++  deriveFRep,+  deriveFRepWith,++  -- ** BiFRep Instance Deriving+  --+  -- | Use the following to generate only the 'BiFRep2' instances.++  deriveBiFRep,+  deriveBiFRepWith,++  -- ** Function-Specific Instance Deriving+  --+  -- | Use the following to generate instances specific to certain functions.++  deriveCollect,+  deriveEverywhere,+  deriveEverywhere',++  -- * Datatype Representations+  --+  -- | This is the collection of representation values for datatypes included+  -- with EMGM.++  -- ** 'Bool'++  epBool,+  conFalse,+  conTrue,+  repBool,+  frepBool,+  frep2Bool,+  frep3Bool,+  bifrep2Bool,++  -- ** 'Either'++  epEither,+  conLeft,+  conRight,+  repEither,+  frepEither,+  frep2Either,+  frep3Either,+  bifrep2Either,++  -- ** List++  epList,+  conNil,+  conCons,+  repList,+  frepList,+  frep2List,+  frep3List,+  bifrep2List,++  -- ** 'Maybe'++  epMaybe,+  conNothing,+  conJust,+  repMaybe,+  frepMaybe,+  frep2Maybe,+  frep3Maybe,+  bifrep2Maybe,++  -- ** Tuples++  -- *** Unit: @()@+  epTuple0,+  conTuple0,+  repTuple0,+  frepTuple0,+  frep2Tuple0,+  frep3Tuple0,+  bifrep2Tuple0,++  -- *** Pair: @(a,b)@+  epTuple2,+  conTuple2,+  repTuple2,+  frepTuple2,+  frep2Tuple2,+  frep3Tuple2,+  bifrep2Tuple2,++  -- *** Triple: @(a,b,c)@+  epTuple3,+  conTuple3,+  repTuple3,+  frepTuple3,+  frep2Tuple3,+  frep3Tuple3,+  bifrep2Tuple3,++  -- *** Quadruple: @(a,b,c,d)@+  epTuple4,+  conTuple4,+  repTuple4,+  frepTuple4,+  frep2Tuple4,+  frep3Tuple4,+  bifrep2Tuple4,++  -- *** Quintuple: @(a,b,c,d,e)@+  epTuple5,+  conTuple5,+  repTuple5,+  frepTuple5,+  frep2Tuple5,+  frep3Tuple5,+  bifrep2Tuple5,++  -- *** Sextuple: @(a,b,c,d,e,f)@+  epTuple6,+  conTuple6,+  repTuple6,+  frepTuple6,+  frep2Tuple6,+  frep3Tuple6,+  bifrep2Tuple6,++  -- *** Septuple: @(a,b,c,d,e,f,h)@+  epTuple7,+  conTuple7,+  repTuple7,+  frepTuple7,+  frep2Tuple7,+  frep3Tuple7,+  bifrep2Tuple7,++  -- ** Template Haskell+  --+  -- | For using the representation of Template Haskell, import+  -- "Generics.EMGM.Data.TH". We don't export it here, because it exports+  -- names that conflict with EMGM names.++  -- ** Derived Generic Functions+  --+  -- | These @newtype@s are exported for generating their 'Rep' instances.++  Collect(..),+  Everywhere(..),+  Everywhere'(..),++  -- * Exported Modules+  --+  -- | Re-export these modules for generated code.++  module Generics.EMGM.Common,++) where++-----------------------------------------------------------------------------+-- Imports+-----------------------------------------------------------------------------++import Generics.EMGM.Common+import Generics.EMGM.Derive.Internal++import Generics.EMGM.Data.Bool+import Generics.EMGM.Data.Either+import Generics.EMGM.Data.List+import Generics.EMGM.Data.Maybe+import Generics.EMGM.Data.Tuple+

@@ -0,0 +1,342 @@+{-# LANGUAGE CPP                    #-}+{-# LANGUAGE TemplateHaskell            #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Generics.EMGM.Derive+-- Copyright   :  (c) 2008, 2009 Universiteit Utrecht+-- License     :  BSD3+--+-- Maintainer  :  generics@haskell.org+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Summary: Common types and functions used in the deriving code.+-----------------------------------------------------------------------------++module Generics.EMGM.Derive.Common where++-----------------------------------------------------------------------------+-- Imports+-----------------------------------------------------------------------------++import Data.List (nub)++import Language.Haskell.TH+import Data.Maybe (fromMaybe)++import Generics.EMGM.Common.Representation+import Generics.EMGM.Common.Base+import Generics.EMGM.Common.Base2+import Generics.EMGM.Common.Base3++-----------------------------------------------------------------------------+-- Types+-----------------------------------------------------------------------------++-- | Normalized form of a datatype declaration (@data@ and @newtype@)+data DT+  = DT+  { tname :: Name       -- Type name+  , tvars :: [Name]     -- Type variables+  , dcons :: [Con]      -- Data constructors+  , ncons :: [NCon]     -- Normalized data constructors+  } deriving Show++-- | Normalized form of a constructor+data NCon+  = NCon+  { cname :: Name       -- Constructor name+  , cdescr :: Name      -- 'ConDescr' declaration name+  , cargtypes :: [Type] -- Constructor argument types+  , cvars :: [Name]     -- Generated constructor variable names+  } deriving Show++--------------------------------------------------------------------------------++-- | Modify the action taken for a given name.+data Modifier+  = ChangeTo String     -- ^ Change the syntactic name (of a type or+                        --   constructor) to the argument in the generated 'EP'+                        --   or 'ConDescr' value. This results in a value named+                        --   @epX@ or @conX@ if the argument is @\"X\"@.+  | DefinedAs String    -- ^ Use this for the name of a user-defined constructor+                        --   description instead of a generated one. The+                        --   generated code assumes the existance of @conX ::+                        --   'ConDescr'@ (in scope) if the argument is @\"X\"@.+  deriving Eq++instance Show Modifier where+  show (DefinedAs s) = s+  show (ChangeTo s)  = s++-- | List of pairs mapping a (type or constructor) name to a modifier action.+type Modifiers = [(String, Modifier)]++--------------------------------------------------------------------------------++data RepOpt = OptRep | OptFRep | OptFRep2 | OptFRep3 | OptBiFRep2+  deriving (Eq, Show)++data RepNames+  = RepNames+  { genericCN'  :: Name -- ^ One of the 'Generic' classes+  , rintN'      :: Name -- ^ Method from 'Generic'+  , rintegerN'  :: Name -- ^ Method from 'Generic'+  , rfloatN'    :: Name -- ^ Method from 'Generic'+  , rdoubleN'   :: Name -- ^ Method from 'Generic'+  , rcharN'     :: Name -- ^ Method from 'Generic'+  , runitN'     :: Name -- ^ Method from 'Generic'+  , rsumN'      :: Name -- ^ Method from 'Generic'+  , rprodN'     :: Name -- ^ Method from 'Generic'+  , rconN'      :: Name -- ^ Method from 'Generic'+  , rtypeN'     :: Name -- ^ Method from 'Generic'+  , repCN'      :: Name -- ^ One of the 'Rep' classes+  , repN'       :: Name -- ^ Method from 'Rep'+  }++data RepFunNames+  = RepFunNames+  { repFunN     :: Name+  , frepFunN    :: Name+  , frep2FunN   :: Name+  , frep3FunN   :: Name+  , bifrep2FunN :: Name+  }++-----------------------------------------------------------------------------+-- General functions+-----------------------------------------------------------------------------++toMaybeString :: Maybe Modifier -> Maybe String+toMaybeString mm = mm >>= return . show++-- | Select the i-th field in an n-tuple+sel :: Int -> Int -> Q Exp+sel i _ | i < 0  = reportError $ "sel: Error! i (= " ++ show i ++ ") is not >= 0."+sel i n | i >= n = reportError $ "sel: Error! i (= " ++ show i ++ ") is not < n (= " ++ show n ++ ")."+sel i n          =+  do x <- newName "x"+     let firsts = replicate i wildP+         lasts = replicate (n - i - 1) wildP+         vars = firsts ++ varP x : lasts+         pats = [tupP vars]+         body = varE x+     lamE pats body++--------------------------------------------------------------------------------++-- | i: initial type, f: final type, s: sum element, p: product element+mkSop+  :: (i -> [s])+  -> (s -> [p])+  -> (p -> f)+  -> f+  -> (f -> f -> f)+  -> (f -> f -> f)+  -> (s -> f -> f)+  -> i+  -> f+mkSop toSumList toProdList inject unit mkSum mkProd wrapProd =+  listCase3 (error "zero") id more . map toProd . toSumList+  where+    more = foldNested mkSum+    toProd x = wrapProd x . productize unit inject mkProd $ toProdList x++mkSopDT+  :: (Type -> f)+  -> f+  -> (f -> f -> f)+  -> (f -> f -> f)+  -> (NCon -> f -> f)+  -> DT+  -> f+mkSopDT = mkSop ncons cargtypes++foldNested :: (a -> a -> a) -> a -> [a] -> a+foldNested f = go+  where+    go b []     = b+    go b (x:xs) = f b (go x xs)++-- | Apply a function to each of 3 cases of a list: 0, 1, or > 1 elements+listCase3 :: b -> (a -> b) -> (a -> [a] -> b) -> [a] -> b+listCase3 zero one more ls =+  case ls of+    []   -> zero        -- 0 elements+    [x]  -> one x       -- 1 element+    x:xs -> more x xs   -- > 1 element++-- | Given a unit value, an injection function, and a product operator, create a+-- product form out of a list.+productize :: b -> (a -> b) -> (b -> b -> b) -> [a] -> b+productize unit inj prod = go+  where+    go = listCase3 unit inj more+    more x xs = prod (inj x) (go xs)++--------------------------------------------------------------------------------++-- | Given a prefix string, a possible string for the type name, a name, and a+-- suffix string, create a function that appends either the type string name (if+-- it exists) or the base of the type name to the prefix.+mkFunName :: String -> Maybe String -> Name -> String -> Name+mkFunName prefix maybeMiddle name suffix = result+  where+    middle = fromMaybe (nameBase name) maybeMiddle+    result = mkName $ showString prefix . showString middle $ suffix++-- | Report an error message and fail+reportError :: String -> Q a+reportError msg = report True msg >> fail ""++--------------------------------------------------------------------------------++-- | Case the representation on the kind of the type.+caseKind :: RepOpt -> a -> a -> a -> a+caseKind opt k0 k1 k2 =+  case opt of+    OptRep     -> k0+    OptFRep    -> k1+    OptFRep2   -> k1+    OptFRep3   -> k1+    OptBiFRep2 -> k2++-- | Case the representation on the 'Generic' class it relies on.+caseGen :: RepOpt -> a -> a -> a -> a+caseGen opt g g2 g3 =+  case opt of+    OptRep     -> g+    OptFRep    -> g+    OptFRep2   -> g2+    OptFRep3   -> g3+    OptBiFRep2 -> g2++-- | Case the 'Rep' option or the others.+caseRep :: RepOpt -> a -> a -> a+caseRep opt r o =+  case opt of+    OptRep -> r+    _      -> o++-- | Get the collection of names for a certain option. This allows the code to+-- be generic across different instance definitions. For example, we use the+-- same code to write the instances of 'Rep' as we do for 'BiFRep2'. Some of the+-- differences are these names.+repNames :: RepOpt -> RepNames+repNames OptRep      = RepNames ''Generic  'rep   'rep       'rep     'rep      'rep    'runit  'rsum  'rprod  'rcon  'rtype  ''Rep     'rep+repNames OptFRep     = RepNames ''Generic  'rint  'rinteger  'rfloat  'rdouble  'rchar  'runit  'rsum  'rprod  'rcon  'rtype  ''FRep    'frep+repNames OptFRep2    = RepNames ''Generic2 'rint2 'rinteger2 'rfloat2 'rdouble2 'rchar2 'runit2 'rsum2 'rprod2 'rcon2 'rtype2 ''FRep2   'frep2+repNames OptFRep3    = RepNames ''Generic3 'rint3 'rinteger3 'rfloat3 'rdouble3 'rchar3 'runit3 'rsum3 'rprod3 'rcon3 'rtype3 ''FRep3   'frep3+repNames OptBiFRep2  = RepNames ''Generic2 'rint2 'rinteger2 'rfloat2 'rdouble2 'rchar2 'runit2 'rsum2 'rprod2 'rcon2 'rtype2 ''BiFRep2 'bifrep2++funName :: RepOpt -> RepFunNames -> Name+funName OptRep      = repFunN+funName OptFRep     = frepFunN+funName OptFRep2    = frep2FunN+funName OptFRep3    = frep3FunN+funName OptBiFRep2  = bifrep2FunN++-- | Get the actual name that is analogous to each of these function names. This+-- allows the code to be generic across different instance definitions.+genericCN, rintN, rintegerN, rfloatN, rdoubleN, rcharN, runitN, rsumN, rprodN, rconN, rtypeN, repCN, repN :: RepOpt -> Name+genericCN = genericCN' . repNames+rintN     = rintN'     . repNames+rintegerN = rintegerN' . repNames+rfloatN   = rfloatN'   . repNames+rdoubleN  = rdoubleN'  . repNames+rcharN    = rcharN'    . repNames+runitN    = runitN'    . repNames+rsumN     = rsumN'     . repNames+rprodN    = rprodN'    . repNames+rconN     = rconN'     . repNames+rtypeN    = rtypeN'    . repNames+repCN     = repCN'     . repNames+repN      = repN'      . repNames++--------------------------------------------------------------------------------++-- | Make a type as applied to its type variables from the type name and list of+-- parameters.+mkAppliedType' :: Name -> [Name] -> Q Type+mkAppliedType' typ vars =+  foldl appT (conT typ) (map varT vars)++-- | Make a type as applied to its type variables (if any) from a DT+mkAppliedType :: RepOpt -> DT -> Q Type+mkAppliedType opt dt =+  appTypeCon varTypes+  where+    varTypes = map varT (tvars dt)+    appTypeCon = foldl appT (conT (tname dt)) . dropLast arity+    len = length varTypes+    dropLast n xs = if len > n then take (len - n) xs else []+    arity = caseKind opt 0 1 2++mkAppliedFun :: Name -> [Name] -> Q Exp+mkAppliedFun fun vars =+  foldl appE (varE fun) (map varE vars)++--------------------------------------------------------------------------------++mkRepT :: RepOpt -> Q Type -> Q Type -> Q Type+mkRepT opt funType = appT (appT (conT (repCN opt)) funType)++mkGenericT :: RepOpt -> Q Type -> Q Type+mkGenericT opt = appT (conT (genericCN opt))++-- | Make the rep instance context+mkRepInstCxt :: RepOpt -> Q Type -> DT -> Q Cxt+mkRepInstCxt opt funType dt = do++  -- Build a list of the 'Rep' class constraints+  repConstraints <-+    case opt of+      OptRep -> do+        -- List of types from all the fields of the all the constructors+        let fieldTypes = concatMap cargtypes (ncons dt)+        fieldConstraints <- mapM (mkRepT opt funType . return) fieldTypes+        -- List of type variables+        varConstraints <- mapM (mkRepT opt funType . varT) (tvars dt)+        -- Final list of 'Rep' constraints with duplicates removed+        return $ nub (varConstraints ++ fieldConstraints)+      _ ->+        return []++  -- Build the 'Generic' class constraint+  genConstraint <- mkGenericT opt funType++  -- Combine the 'Generic' and 'Rep' constraints+  return (genConstraint : repConstraints)++-- | Make the rep instance type+mkRepInstT :: RepOpt -> DT -> Q Type -> Q Type+mkRepInstT opt dt funType = mkRepT opt funType (mkAppliedType opt dt)++--------------------------------------------------------------------------------++unitE :: Exp+unitE = ConE 'Unit++prodE :: Exp -> Exp -> Exp+prodE a b = (InfixE (Just a) (ConE '(:*:)) (Just b))++sumE :: Name -> Exp -> Exp+sumE name x = AppE (ConE name) x++unitP :: Pat+unitP = ConP 'Unit []++prodP :: Pat -> Pat -> Pat+prodP a b = (InfixP a '(:*:) b)++sumP :: Name -> Pat -> Pat+sumP name x = ConP name [x]++dataE :: (Exp -> Exp) -> NCon -> Exp+dataE f (NCon name _ _ vars) =+  foldl (\e -> AppE e . f . VarE) (ConE name) vars++dataP :: NCon -> Pat+dataP (NCon name _ _ vars) = ConP name (map VarP vars)+

@@ -0,0 +1,113 @@+{-# LANGUAGE CPP                    #-}+{-# LANGUAGE TemplateHaskell        #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Generics.EMGM.Derive.ConDescr+-- Copyright   :  (c) 2008, 2009 Universiteit Utrecht+-- License     :  BSD3+--+-- Maintainer  :  generics@haskell.org+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Summary: Code for generating a value of 'ConDescr' in TH.+-----------------------------------------------------------------------------++module Generics.EMGM.Derive.ConDescr (+#ifndef __HADDOCK__+  mkConDescr,+#endif+) where++#ifndef __HADDOCK__++-----------------------------------------------------------------------------+-- Imports+-----------------------------------------------------------------------------++import Language.Haskell.TH++import qualified Generics.EMGM.Common.Representation as ER -- EMGM Rep+import Generics.EMGM.Derive.Common++-----------------------------------------------------------------------------+-- General functions+-----------------------------------------------------------------------------++conFixity :: Name -> Q Fixity+conFixity name =+  do info <- reify name+     case info of+       DataConI _ _ _ fixity ->+         return fixity+       _ ->+         reportError $ showString "Unexpected name \""+                     . showString (nameBase name)+                     $ "\" when looking for an infix data constructor."+++-- | Build an expression for a value of EMGM's Fixity type+fixityE :: Maybe Fixity -> Exp+fixityE Nothing             = ConE 'ER.Nonfix+fixityE (Just (Fixity p d)) =+  case d of+    InfixL -> mkE 'ER.Infixl+    InfixR -> mkE 'ER.Infixr+    InfixN -> mkE 'ER.Infix+  where+    mkE :: Name -> Exp+    mkE name = AppE (ConE name) (LitE (IntegerL $ fromIntegral p))++-- | Build a 'ConDescr' expression+mkConDescrE :: String -> Int -> [String] -> Maybe Fixity -> Exp+mkConDescrE name arity labels fixity =+  foldl AppE (ConE 'ER.ConDescr)+    [ LitE (StringL name)+    , LitE (IntegerL $ fromIntegral arity)+    , ListE $ map (LitE . StringL) labels+    , fixityE fixity ]++-- | Make a 'ConDescr' expression and return a pair of the stringified+-- constructor name and AST expression value.+conDescrE :: Con -> Q (String,Exp)+conDescrE c =+  case c of+    NormalC name args ->+      do let nb = nameBase name+         return (nb, mkConDescrE nb (length args) [] Nothing)+    RecC name args ->+      do let nb = nameBase name+             labels = map (nameBase . $(sel 0 3)) args+         return (nb, mkConDescrE nb (length args) labels Nothing)+    InfixC _ name _ ->+      do let nb = nameBase name+         fixity <- conFixity name+         return (nb, mkConDescrE nb 2 [] (Just fixity))+    other ->+      -- Should never reach+      reportError $ "conDescrE: Unsupported constructor: '" ++ show other ++ "'"++cdDecs :: Name -> Exp -> [Dec]+cdDecs n e = [SigD n (ConT ''ER.ConDescr), ValD (VarP n) (NormalB e) []]++-- | Make a 'ConDescr' declaration and return a pair of the declaration name+-- and AST value.+mkConDescr :: Maybe Modifier -> Con -> Q (Name, Maybe [Dec])+mkConDescr maybeCdName c =+  do (cstr, e) <- conDescrE c+     let mkPair s isDeclared =+           let name = mkName ("con" ++ s)+               dec = if isDeclared then Just (cdDecs name e) else Nothing+           in (name, dec)+     let pair =+           case maybeCdName of+             Nothing  -> mkPair cstr True+             Just m   ->+               case m of+                 DefinedAs s -> mkPair s False+                 ChangeTo s  -> mkPair s True+     return pair++#endif+

@@ -0,0 +1,125 @@+{-# LANGUAGE CPP                    #-}+{-# LANGUAGE TemplateHaskell        #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Generics.EMGM.Derive.EP+-- Copyright   :  (c) 2008, 2009 Universiteit Utrecht+-- License     :  BSD3+--+-- Maintainer  :  generics@haskell.org+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Summary: Code for generating the 'EP' value in TH.+-----------------------------------------------------------------------------++module Generics.EMGM.Derive.EP (+#ifndef __HADDOCK__+  mkEP,+#endif+) where++#ifndef __HADDOCK__++-----------------------------------------------------------------------------+-- Imports+-----------------------------------------------------------------------------++import Language.Haskell.TH++-- TODO: List imports++import Generics.EMGM.Common.Representation+import Generics.EMGM.Derive.Common++-----------------------------------------------------------------------------+-- General functions+-----------------------------------------------------------------------------++-- | Apply an inductive function @fn@ recursively @n@ times. Then, apply a base+-- function @fz@. Restriction: @n >= 0@.+appN :: (a -> b) -> (b -> b) -> Int -> a -> b+appN fz _  0 x = fz x+appN fz fn n x = fn (appN fz fn (n - 1) x)++--------------------------------------------------------------------------------++-- | Create a product representation from a single constructor+conProd :: a -> (a -> a -> a) -> (Name -> a) -> NCon -> a+conProd unit prod var = namesRep . cvars+  where+    namesRep = productize unit id prod . map var++-- | Change a list of product representations to a list of sums of products.+-- For example, the list of reps  A, B, and C becomes L A, R (L B), and R (R C).+repsSums :: (Name -> a -> a) -> [a] -> [a]+repsSums mkSum = listCase3 [] (:[]) more+  where+    inL = mkSum 'L+    inR = mkSum 'R++    -- Apply inR and inL the appropriate number of times to inject the product+    -- rep into the correct sum rep value.+    more x xs = inL x : appLR 1 xs++    appLR n (y:[]) = [appN inR inR (n - 1) y]+    appLR n (y:ys) = appN inL inR n y : appLR (n + 1) ys+    appLR _ _      = error "repsSums: Should not be here!"++-- | Translate constructors to syntax elements for sum-of-product representation+consReps :: a -> (a -> a -> a) -> (Name -> a) -> (Name -> a -> a) -> [NCon] -> [a]+consReps unit prod var sum_ = repsSums sum_ . prods+  where+    prods = map (conProd unit prod var)++--------------------------------------------------------------------------------++-- | Create a list of clauses from a list of constructors+consClauses :: (a -> [Pat]) -> (a -> [Exp]) -> a -> [Clause]+consClauses mkPats mkExps cons = zipWith mkClause (mkPats cons) (mkExps cons)+  where+    mkClause p e = Clause [p] (NormalB e) []++-- | Given the constructors of a datatype, create a pair of the direction and+-- the clause for each component of the embedding-projection pair.+fromClauses, toClauses :: [NCon] -> [Clause]+fromClauses = consClauses (map dataP) (consReps unitE prodE VarE sumE)+toClauses   = consClauses (consReps unitP prodP VarP sumP) (map (dataE id))++-- | Given a function that translates constructors to clause (plus direction), a+-- possible type string name, and a type name, make a function declaration.+mkFunD :: ([NCon] -> [Clause]) -> DT -> Name -> Dec+mkFunD mkClauses dt funNm = FunD funNm (mkClauses (ncons dt))++--------------------------------------------------------------------------------++mkEpSig :: DT -> Name -> Dec+mkEpSig dt ep = SigD ep typ+  where+    vars = tvars dt+    typ = ForallT vars [] (AppT (AppT (ConT ''EP) rtyp) styp)+    rtyp = foldl AppT (ConT (tname dt)) . map VarT $ vars+    mkSum = AppT . AppT (ConT ''(:+:))+    mkProd = AppT . AppT (ConT ''(:*:))+    unit = ConT ''Unit+    styp = mkSopDT id unit mkSum mkProd (flip const) dt++--------------------------------------------------------------------------------++-- | Given a possible type string name and a type name, declare the+-- embedding-projection pair for a datatype.+mkEP :: Modifiers -> DT -> Name -> Name -> (Name, [Dec])+mkEP mods dt fromName toName = (epName, [epSig, epDec])+  where+    typeName = tname dt+    maybeTypeStr = toMaybeString $ lookup (nameBase typeName) mods+    epName = mkFunName "ep" maybeTypeStr typeName ""+    fromDec = mkFunD fromClauses dt fromName+    toDec = mkFunD toClauses dt toName+    body = AppE (AppE (ConE 'EP) (VarE fromName)) (VarE toName)+    epSig = mkEpSig dt epName+    epDec = ValD (VarP epName) (NormalB body) [fromDec, toDec]++#endif+

@@ -0,0 +1,92 @@+{-# LANGUAGE CPP                    #-}+{-# LANGUAGE TemplateHaskell        #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Generics.EMGM.Derive.Functions+-- Copyright   :  (c) 2008, 2009 Universiteit Utrecht+-- License     :  BSD3+--+-- Maintainer  :  generics@haskell.org+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Summary: Code for generating function-specific instances in TH.+-----------------------------------------------------------------------------++module Generics.EMGM.Derive.Functions (+#ifndef __HADDOCK__+  mkRepCollectInst,+  mkRepEverywhereInst,+  mkRepEverywhereInst',+#endif+) where++#ifndef __HADDOCK__++-----------------------------------------------------------------------------+-- Imports+-----------------------------------------------------------------------------++import Language.Haskell.TH++import Generics.EMGM.Common.Base+import Generics.EMGM.Derive.Common++import Generics.EMGM.Functions.Collect+import Generics.EMGM.Functions.Everywhere++--------------------------------------------------------------------------------++-- | Make the instance for a function-specific Rep instance+mkRepFunctionInst :: DT -> Name -> Q Cxt -> Q Exp -> Q Dec+mkRepFunctionInst dt newtypeName ctx bodyExp = do+  let t = mkAppliedType OptRep dt+  let typ = mkRepInstT OptRep dt (appT (conT newtypeName) t)+  let dec = valD (varP 'rep) (normalB bodyExp) []+  instanceD ctx typ [dec]++--------------------------------------------------------------------------------++-- | Make the instance for a Rep Collect T (where T is the type)+mkRepCollectInst :: DT -> Q Dec+mkRepCollectInst dt = do+  mkRepFunctionInst dt ''Collect (return []) [|Collect (\x -> [x])|]++--------------------------------------------------------------------------------++mkEverywhereFunE :: DT -> Q Exp+mkEverywhereFunE dt = lamE [fpat, xpat] caseExp+  where+    f = mkName "f"+    x = mkName "x"+    xpat = varP x+    fpat = varP f+    appSel = AppE (AppE (AppE (VarE 'selEverywhere) (VarE 'rep)) (VarE f))+    appF = appE (varE f)+    caseExp = caseE (varE x) matches+    matches = zipWith mkMatch pats exps+    mkMatch p e = match (return p) (normalB (appF (return e))) []+    ncs = ncons dt+    pats = map dataP ncs+    exps = map (dataE appSel) ncs++-- | Make the instance for a Rep Everywhere T (where T is the type)+mkRepEverywhereInst :: DT -> Q Dec+mkRepEverywhereInst dt = do+  let dtyp = mkAppliedType OptRep dt+  let typ = appT (conT ''Everywhere) dtyp+  let bodyExp = appE (conE 'Everywhere) (mkEverywhereFunE dt)+  repCtx <- mkRepInstCxt OptRep typ dt+  let ctx = return (tail repCtx)+  mkRepFunctionInst dt ''Everywhere ctx bodyExp++--------------------------------------------------------------------------------++-- | Make the instance for a Rep Everywhere' T (where T is the type)+mkRepEverywhereInst' :: DT -> Q Dec+mkRepEverywhereInst' dt =+  mkRepFunctionInst dt ''Everywhere' (return []) [|Everywhere' (\f x -> f x)|]++#endif+

@@ -0,0 +1,266 @@+{-# LANGUAGE CPP                        #-}+{-# LANGUAGE TemplateHaskell            #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE MultiParamTypeClasses      #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Generics.EMGM.Derive+-- Copyright   :  (c) 2008, 2009 Universiteit Utrecht+-- License     :  BSD3+--+-- Maintainer  :  generics@haskell.org+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Summary: Code for generating the representation dispatcher class instances in+-- TH.+-----------------------------------------------------------------------------++module Generics.EMGM.Derive.Instance (+#ifndef __HADDOCK__+  RepOpt(..),+  RepFunNames(..),+  mkRepFun,+  mkRepInst,+#endif+) where++#ifndef __HADDOCK__++-----------------------------------------------------------------------------+-- Imports+-----------------------------------------------------------------------------++import Data.List (transpose)++import Language.Haskell.TH++import Generics.EMGM.Derive.Common++-----------------------------------------------------------------------------+-- Types+-----------------------------------------------------------------------------++-----------------------------------------------------------------------------+-- General functions+-----------------------------------------------------------------------------++repStr :: RepOpt -> String+repStr OptRep      = "rep"+repStr OptFRep     = "frep"+repStr OptFRep2    = "frep2"+repStr OptFRep3    = "frep3"+repStr OptBiFRep2  = "bifrep2"++-- | Handle the renaming of the functions for the built-in symbol types.+symbolMods :: Modifiers+symbolMods =+  [ ("[]",ChangeTo "List")+  , ("()",ChangeTo "Tuple0")+  , ("(,)",ChangeTo "Tuple2")+  , ("(,,)",ChangeTo "Tuple3")+  , ("(,,,)",ChangeTo "Tuple4")+  , ("(,,,,)",ChangeTo "Tuple5")+  , ("(,,,,,)",ChangeTo "Tuple6")+  , ("(,,,,,,)",ChangeTo "Tuple7")+  ]++toFunName :: Modifiers -> RepOpt -> Name -> Name+toFunName mods opt nm =+  mkName (repStr opt ++ result)+  where+    str = nameBase nm+    result =+      case toMaybeString (lookup str (mods ++ symbolMods)) of+        Nothing     -> str+        Just newStr -> newStr++primRepName :: Name -> RepOpt -> Maybe Name+primRepName typ opt =+  case nameBase typ of+    "Int"     -> Just (rintN opt)+    "Integer" -> Just (rintegerN opt)+    "Float"   -> Just (rfloatN opt)+    "Double"  -> Just (rdoubleN opt)+    "Char"    -> Just (rcharN opt)+    _         -> Nothing++typSyn :: Name -> Q (Maybe Type)+typSyn typ = do+  info <- reify typ+  case info of+    TyConI dec ->+      case dec of+        TySynD _ _ unSynTyp ->+          return (Just unSynTyp)+        _ ->+          return Nothing+    _ ->+      return Nothing++typeUnknownError :: Int -> RepOpt -> Type -> Q a+typeUnknownError i opt t = do+  error $ "Error #" ++ show i ++ ": Unsupported type for " ++ show opt ++ ": " ++ show t++-- | Produce the variable expression for the appropriate 'rep', 'frep', etc.+varRepExp :: Modifiers -> RepOpt -> DT -> Type -> Q Exp+varRepExp mods opt dt =+  caseRep opt (varE (repN opt)) . go+  where+    typE nm = varE (toFunName mods opt nm)++    appFun t = foldl appE (typE t) . map go++    go t =+      case t of++        VarT v ->+          if v `elem` tvars dt then varE v else typeUnknownError 34 opt t++        ConT typ ->+          case primRepName typ opt of+            Just nm ->+              varE nm+            Nothing -> do+              mts <- typSyn typ+              case mts of+                Just ts  -> go ts+                Nothing -> varE (toFunName mods opt typ)++        AppT (ConT typ) a ->+          appFun typ [a]++        AppT (AppT (ConT typ) a1) a2 ->+          appFun typ [a1,a2]++        AppT (AppT (AppT (ConT typ) a1) a2) a3 ->+          appFun typ [a1,a2,a3]++        AppT (AppT (AppT (AppT (ConT typ) a1) a2) a3) a4 ->+          appFun typ [a1,a2,a3,a4]++        AppT (AppT (AppT (AppT (AppT (ConT typ) a1) a2) a3) a4) a5 ->+          appFun typ [a1,a2,a3,a4,a5]++        AppT (AppT (AppT (AppT (AppT (AppT (ConT typ) a1) a2) a3) a4) a5) a6 ->+          appFun typ [a1,a2,a3,a4,a5,a6]++        AppT (AppT (AppT (AppT (AppT (AppT (AppT (ConT typ) a1) a2) a3) a4) a5) a6) a7 ->+          appFun typ [a1,a2,a3,a4,a5,a6,a7]++        _ ->+          typeUnknownError 50 opt t++-- | Construct the expression for the appropriate 'rtype', 'rtype2', etc.+rtypeE :: RepOpt -> Name -> Q Exp -> Q Exp+rtypeE opt epName sopE =+  caseGen opt (appToSop ep1) (appToSop ep2) (appToSop ep3)+  where+    appToEp e = appE e (varE epName)+    appToSop eps = appE eps sopE+    ep1 = appToEp (varE (rtypeN opt))+    ep2 = appToEp ep1+    ep3 = appToEp ep2++--------------------------------------------------------------------------------++-- | Construct the sum-of-product expression for the appropriate 'rep', 'frep',+-- 'frep2', etc.+repSopE :: Modifiers -> RepOpt -> DT -> Q Exp+repSopE mods opt dt =+  mkSopDT inject unit mkSum mkProd wrapProd dt+  where+    inject = varRepExp mods opt dt+    mkSum = appE . appE (varE (rsumN opt))+    mkProd = appE . appE (varE (rprodN opt))+    unit = varE (runitN opt)+    wrapProd ncon = appE (appE (varE (rconN opt)) (varE (cdescr ncon)))++-- | The number of generic type variables in the representation.+genTypeVars :: RepOpt -> Int+genTypeVars opt = caseGen opt 1 2 3++-- | Make the signature return type given a @g@ type variable, a type name, and+-- a list of list of parameters. The list of parameters is arranged in the order+-- for the function arguments, so it must be transposed.+mkSigReturnT :: RepOpt -> Q Type -> Name -> [[Name]] -> Q Type+mkSigReturnT opt gvar typ =+  foldl appT gvar . map (mkAppliedType' typ) . fillNil . transpose+  where+    fillNil [] = replicate (genTypeVars opt) []+    fillNil xs = xs++-- | Make the representation function signature.+mkRepFunSigT :: RepOpt -> DT -> Q Type+mkRepFunSigT opt dt = do+  -- The Generic class parameter+  let gname = mkName "g"+  let gvar = varT gname++  -- Build a list of lists of type variable names. Each sublist is the set of+  -- parameters to each 'g' type in the function arguments. For 'rep', we keep+  -- the original type variable list, because it's also used in the context.+  let mkVarNameList _ c = map (\i -> mkName (c:show i)) [1..genTypeVars opt]+  let varNameLists =+        caseRep opt+          (map (:[]) (tvars dt))+          (zipWith mkVarNameList (tvars dt) ['a'..])++  -- Type variables for this function signature+  let vars = gname : concat varNameLists++  -- Build a list of argument types using the variable name list of lists from+  -- above.+  let mkArrArgs as = appT arrowT (foldl appT gvar (map varT as))+  let args = caseRep opt [] (map mkArrArgs varNameLists)++  -- The return type+  let retTyp = mkSigReturnT opt gvar (tname dt) varNameLists++  -- Combine the return type with the argument types to get the final signature.+  let typ = foldr appT retTyp args++  -- Context with class constraints+  let ctx = mkRepInstCxt opt gvar dt++  -- Done!+  forallT vars ctx typ++-- | Make the representation functions, e.g. 'repMaybe', 'frepMaybe',+-- 'frep2Maybe', 'frep3Maybe', and 'bifrep2Maybe'+mkRepFun :: Modifiers -> RepOpt -> DT -> Name -> Q (Name, [Dec])+mkRepFun mods opt dt ep = do++  -- Name of function+  let nm = toFunName mods opt (tname dt)++  -- Signature of function+  sig <- sigD nm (mkRepFunSigT opt dt)++  -- Value of function+  let bodyExp = rtypeE opt ep (repSopE mods opt dt)+  let args = caseRep opt [] (map varP (tvars dt))+  fun <- funD nm [clause args (normalB bodyExp) []]++  return (nm, [sig, fun])+  --return (nm, [])++-----------------------------------------------------------------------------+-- Exported Functions+-----------------------------------------------------------------------------++-- | Make the instance for a representation type class+mkRepInst :: RepOpt -> RepFunNames -> Name -> DT -> Q [Dec]+mkRepInst opt funs g dt = do+  let body = varE (funName opt funs)+  let dec = valD (varP (repN opt)) (normalB body) []+  let gvar = varT g+  let ctx = mkRepInstCxt opt gvar dt+  let typ = mkRepInstT opt dt gvar+  inst <- instanceD ctx typ [dec]+  return [inst]++#endif+

@@ -0,0 +1,675 @@+{-# LANGUAGE CPP                    #-}+{-# LANGUAGE TemplateHaskell        #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Generics.EMGM.Derive.Internal+-- Copyright   :  (c) 2008, 2009 Universiteit Utrecht+-- License     :  BSD3+--+-- Maintainer  :  generics@haskell.org+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Summary: Internal module with implementation of deriving code. Other EMGM+-- modules should import this instead of the higher-level Derive modules.+-----------------------------------------------------------------------------++module Generics.EMGM.Derive.Internal (++  derive,+  deriveWith,+  Modifier(..),+  Modifiers,++  deriveMono,+  deriveMonoWith,++  declareConDescrs,+  declareConDescrsWith,++  declareEP,+  declareEPWith,++  declareRepValues,+  declareRepValuesWith,++  declareMonoRep,+  declareMonoRepWith,++  deriveRep,+  deriveRepWith,++  deriveFRep,+  deriveFRepWith,++  deriveBiFRep,+  deriveBiFRepWith,++  deriveCollect,+  deriveEverywhere,+  deriveEverywhere',++  module Generics.EMGM.Common,+  module Generics.EMGM.Functions.Collect,+  module Generics.EMGM.Functions.Everywhere,++) where++-----------------------------------------------------------------------------+-- Imports+-----------------------------------------------------------------------------++import Prelude++import Language.Haskell.TH+import Data.Maybe (catMaybes)++import Generics.EMGM.Derive.Common+import Generics.EMGM.Derive.Functions++-- We ignore these imports for Haddock, because Haddock does not like Template+-- Haskell expressions in many places.+--+-- See http://code.google.com/p/emgm/issues/detail?id=21+--+#ifndef __HADDOCK__+import Generics.EMGM.Derive.ConDescr (mkConDescr)+import Generics.EMGM.Derive.EP (mkEP)+import Generics.EMGM.Derive.Instance+#endif++import Generics.EMGM.Common++import Generics.EMGM.Functions.Collect+import Generics.EMGM.Functions.Everywhere++-----------------------------------------------------------------------------+-- General functions+-----------------------------------------------------------------------------++#ifndef __HADDOCK__++-- | Make the DT and constructor descriptions+declareConDescrsBase :: Modifiers -> Name -> Q (DT, [Dec])+declareConDescrsBase mods typeName = do+  info <- reify typeName+  case info of+    TyConI d ->+      case d of+        DataD    _ name vars cons _ -> mkDT name vars cons+        NewtypeD _ name vars con  _ -> mkDT name vars [con]+        _                             -> err+    _ -> err+  where+    mkDT name vars cons =+     do pairs <- mapM (normalizeCon mods) cons+        let (ncons', cdDecs) = unzip pairs+        return (DT name vars cons ncons', concat . catMaybes $ cdDecs)+    err = reportError $ showString "Unsupported name \""+                      . shows typeName+                      $ "\". Must be data or newtype."++-- | Normalize constructor variants+normalizeCon :: Modifiers -> Con -> Q (NCon, Maybe [Dec])+normalizeCon mods c =+  case c of+    NormalC name args     -> mkNCon name (map snd args)+    RecC name args        -> mkNCon name (map $(sel 2 3) args)+    InfixC argL name argR -> mkNCon name [snd argL, snd argR]+    ForallC _ _ con       ->+      -- It appears that this ForallC may never be reached, because non-Haskell-98+      -- constructors can't be reified according to an error received when trying.+      do (NCon name _ _ _, _) <- normalizeCon mods con+         reportError $ showString "Existential data constructors such as \""+                     . showString (nameBase name)+                     $ "\" are not supported."+  where+    mkNCon name args =+      do let maybeCdMod = lookup (nameBase name) mods+         (cdName, cdDecs) <- mkConDescr maybeCdMod c+         let names = newVarNames args+         return (NCon name cdName args names, cdDecs)++-- | For each element in a list, make a new variable name using the character+-- 'v' (arbitrary) and a number.+newVarNames :: [a] -> [Name]+newVarNames = map newVarName . zipWith const [1..]+  where+    newVarName :: Int -> Name+    newVarName = mkName . (:) 'v' . show++--------------------------------------------------------------------------------++declareEPBase :: Modifiers -> DT -> Q (Name, [Dec])+declareEPBase mods dt = do+  fromName <- newName "from"+  toName <- newName "to"+  return (mkEP mods dt fromName toName)++declareRepFunsBase :: Modifiers -> DT -> Name -> Q (RepFunNames, [Dec])+declareRepFunsBase mods dt ep = do+  (repFunName,     repFunDecs)     <- mkRepFun mods OptRep      dt ep+  (frepFunName,    frepFunDecs)    <- mkRepFun mods OptFRep     dt ep+  (frep2FunName,   frep2FunDecs)   <- mkRepFun mods OptFRep2    dt ep+  (frep3FunName,   frep3FunDecs)   <- mkRepFun mods OptFRep3    dt ep+  (bifrep2FunName, bifrep2FunDecs) <- mkRepFun mods OptBiFRep2  dt ep+  return+    ( RepFunNames repFunName frepFunName frep2FunName frep3FunName bifrep2FunName+    , repFunDecs ++ frepFunDecs ++ frep2FunDecs ++ frep3FunDecs ++ bifrep2FunDecs+    )++deriveRepBase :: DT -> RepFunNames -> Name -> Q [Dec]+deriveRepBase dt funs g =+  mkRepInst OptRep funs g dt++deriveFRepBase :: DT -> RepFunNames -> Name -> Q [Dec]+deriveFRepBase dt funs g = do+  frepInstDec <- mkRepInst OptFRep funs g dt+  frep2InstDec <- mkRepInst OptFRep2 funs g dt+  frep3InstDec <- mkRepInst OptFRep3 funs g dt+  return (frepInstDec ++ frep2InstDec ++ frep3InstDec)++deriveBiFRepBase :: DT -> RepFunNames -> Name -> Q [Dec]+deriveBiFRepBase dt funs g =+  mkRepInst OptBiFRep2 funs g dt++#endif++-----------------------------------------------------------------------------+-- Exported functions+-----------------------------------------------------------------------------++-- | Same as 'derive' except that you can pass a list of name modifications to+-- the deriving mechanism.+--+-- Use @deriveWith@ if:+--+--  (1) You want to use the generated constructor descriptions or+--  embedding-projection pairs /and/ one of your constructors or types is an+--  infix symbol. In other words, if you have a constructor @:*@, you cannot+--  refer to the (invalid) generated name for its description, @con:*@. It+--  appears that GHC has no problem with that name internally, so this is only+--  if you want access to it.+--+--  (2) You want to define your own constructor description. This allows you to+--  give a precise implementation different from the one generated for you.+--+-- For option 1, use 'ChangeTo' as in this example:+--+-- @+--   data U = Int :* Char+--   $(deriveWith [(\":*\", ChangeTo \"Star\")] ''U)+--   x = ... conStar ...+-- @+--+-- For option 2, use 'DefinedAs' as in this example:+--+-- @+--   data V = (:=) { i :: Int, j :: Char }+--   $(deriveWith [(\":=\", DefinedAs \"Equals\")] ''V)+--   conEquals = 'ConDescr' \":=\" 2 [] ('Infix' 4)+-- @+--+-- Using the example for option 2 with "Generics.EMGM.Functions.Show" will print+-- values of @V@ as infix instead of the default record syntax.+--+-- Note that only the first pair with its first field matching the type or+-- constructor name in the 'Modifiers' list will be used. Any other matches will+-- be ignored.+deriveWith :: Modifiers -> Name -> Q [Dec]++#ifndef __HADDOCK__++deriveWith mods typeName = do+  (dt, conDescrDecs) <- declareConDescrsBase mods typeName+  (epName, epDecs) <- declareEPBase mods dt+  (funNames, funDecs) <- declareRepFunsBase mods dt epName++  g <- newName "g"+  repInstDecs <- deriveRepBase dt funNames g++  higherOrderRepInstDecs <-+    case length (tvars dt) of+      1 -> deriveFRepBase dt funNames g+      2 -> deriveBiFRepBase dt funNames g+      _ -> return []++  collectInstDec <- mkRepCollectInst dt+  everywhereInstDec <- mkRepEverywhereInst dt+  everywhereInstDec' <- mkRepEverywhereInst' dt++  return $+    conDescrDecs           +++    epDecs                 +++    funDecs                +++    repInstDecs            +++    higherOrderRepInstDecs +++    [collectInstDec+    ,everywhereInstDec+    ,everywhereInstDec'+    ]++#else++deriveWith = undefined++#endif++-- | Derive all appropriate instances for using EMGM with a datatype.+--+-- Here is an example module that shows how to use @derive@:+--+-- >   {-# LANGUAGE TemplateHaskell       #-}+-- >   {-# LANGUAGE MultiParamTypeClasses #-}+-- >   {-# LANGUAGE FlexibleContexts      #-}+-- >   {-# LANGUAGE FlexibleInstances     #-}+-- >   {-# LANGUAGE OverlappingInstances  #-}+-- >   {-# LANGUAGE UndecidableInstances  #-}+--+-- @+--   module Example where+--   import "Generics.EMGM.Derive"+--   data T a = C a 'Int'+-- @+--+-- @+--   $(derive ''T)+-- @+--+-- The Template Haskell @derive@ declaration in the above example generates the+-- following (annotated) code:+--+-- @+--   -- (1) Constructor description declarations+-- @+--+-- @+--   conC :: 'ConDescr'+--   conC = 'ConDescr' \"C\" 2 [] 'Nonfix'+-- @+--+-- @+--   -- (2) Embedding-projection pair declaration+-- @+--+-- @+--   epT :: 'EP' (T a) (a :*: 'Int')+--   epT = 'EP' fromT toT+--     where fromT (C v1 v2) = v1 :*: v2+--           toT (v1 :*: v2) = C v1 v2+-- @+--+-- @+--   -- (3) Representation values+-- @+--+-- @+--   repT :: ('Generic' g, 'Rep' g a, 'Rep' g 'Int') => g (T a)+--   repT = 'rtype' epT ('rcon' conC ('rprod' 'rep' 'rep'))+-- @+--+-- @+--   frepT :: ('Generic' g) => g a1 -> g (T a1)+--   frepT a = 'rtype' epT ('rcon' conC ('rprod' a 'rint'))+-- @+--+-- @+--   frep2T :: ('Generic2' g) => g a1 a2 -> g (T a1) (T a2)+--   frep2T a = 'rtype2' epT epT ('rcon2' conC ('rprod2' a 'rint2'))+-- @+--+-- @+--   frep3T :: ('Generic3' g) => g a1 a2 a3 -> g (T a1) (T a2) (T a3)+--   frep3T a = 'rtype3' epT epT epT ('rcon3' conC ('rprod3' a 'rint3'))+-- @+--+-- @+--   bifrep2T :: ('Generic2' g) => g a1 a2 -> g (T a1) (T a2)+--   bifrep2T a = 'rtype2' epT epT ('rcon2' conC ('rprod2' a 'rint2'))+-- @+--+-- @+--   -- (4) Representation instances+-- @+--+-- @+--   instance ('Generic' g, 'Rep' g a, 'Rep' g 'Int') => 'Rep' g (T a) where+--     'rep' = repT+-- @+--+-- @+--   instance ('Generic' g) => 'FRep' g T where+--     'frep' = frepT+-- @+--+-- @+--   instance ('Generic2' g) => 'FRep2' g T where+--     'frep2' = frep2T+-- @+--+-- @+--   instance ('Generic3' g) => 'FRep3' g T where+--     'frep3' = frep3T+-- @+--+-- @+--   -- In this case, no instances for 'BiFRep2' is generated, because T is not+--   -- a bifunctor type; however, the bifrep2T value is always generated in+--   -- case T is used in a bifunctor type.+-- @+--+-- @+--   -- (5) Generic function-specific instances+-- @+--+-- @+--   instance 'Rep' ('Collect' (T a)) (T a) where+--     'rep' = 'Collect' (\\x -> [x])+-- @+--+-- @+--   instance ('Rep' ('Everywhere' (T a)) a, 'Rep' ('Everywhere' (T a)) 'Int')+--            => 'Rep' ('Everywhere' (T a)) (T a) where+--     'rep' = 'Everywhere' (\\f x ->+--       case x of+--         C v1 v2 -> f (C ('selEverywhere' 'rep' f v1) ('selEverywhere' 'rep' f v2))+-- @+--+-- @+--   instance 'Rep' ('Everywhere'' (T a)) (T a) where+--     'rep' = 'Everywhere'' (\\f x -> f x)+-- @+--+-- Note that all the values are top-level. This allows them to be shared between+-- multiple instances. For example, if you have two mutually recursive functor+-- datatypes, you may need to have each other's derived code in scope.++derive :: Name -> Q [Dec]+derive = deriveWith []++--------------------------------------------------------------------------------++-- | Same as 'declareConDescrs' except that you can pass a list of name+-- modifications to the deriving mechanism. See 'deriveWith' for an example.+declareConDescrsWith :: Modifiers -> Name -> Q [Dec]++#ifndef __HADDOCK__++declareConDescrsWith mods typeName = do+  (_, conDescrDecs) <- declareConDescrsBase mods typeName+  return conDescrDecs++#else++declareConDescrsWith = undefined++#endif++-- | Generate declarations of 'ConDescr' values for all constructors in a type.+-- See 'derive' for an example.+declareConDescrs :: Name -> Q [Dec]+declareConDescrs = declareConDescrsWith []++--------------------------------------------------------------------------------++-- | Same as 'declareEP' except that you can pass a list of name modifications+-- to the deriving mechanism. See 'deriveWith' for an example.+declareEPWith :: Modifiers -> Name -> Q [Dec]++#ifndef __HADDOCK__++declareEPWith mods typeName = do+  (dt, _) <- declareConDescrsBase mods typeName+  (_, epDecs) <- declareEPBase mods dt+  return epDecs++#else++declareEPWith = undefined++#endif++-- | Generate declarations of 'EP' values for a type. See 'derive' for an+-- example.+declareEP :: Name -> Q [Dec]+declareEP = declareEPWith []++--------------------------------------------------------------------------------++-- | Same as 'declareMonoRep' except that you can pass a list of name+-- modifications to the deriving mechanism. See 'deriveWith' for an example.+declareMonoRepWith :: Modifiers -> Name -> Q [Dec]++#ifndef __HADDOCK__++declareMonoRepWith mods typeName = do+  (dt, _) <- declareConDescrsBase mods typeName+  (ep, _) <- declareEPBase mods dt+  (_, repFunDecs) <- mkRepFun mods OptRep dt ep+  return repFunDecs++#else++declareMonoRepWith = undefined++#endif++-- | Generate the declaration of a monomorphic representation value for a type.+-- This is the value used for 'rep' in an instance of 'Rep'. The difference with+-- 'declareRepValues' is that 'declareRepValues' generates generates all+-- representation values (including 'frep', 'frep2', etc.). See 'derive' for an+-- example.+declareMonoRep :: Name -> Q [Dec]+declareMonoRep = declareMonoRepWith []++--------------------------------------------------------------------------------++-- | Same as 'declareRepValues' except that you can pass a list of name+-- modifications to the deriving mechanism. See 'deriveWith' for an example.+declareRepValuesWith :: Modifiers -> Name -> Q [Dec]++#ifndef __HADDOCK__++declareRepValuesWith mods typeName = do+  (dt, _) <- declareConDescrsBase mods typeName+  (ep, _) <- declareEPBase mods dt+  (_, funDecs) <- declareRepFunsBase mods dt ep+  return funDecs++#else++declareRepValuesWith = undefined++#endif++-- | Generate declarations of all representation values for a type. These+-- functions are used in 'rep', 'frep', ..., 'bifrep2'.+declareRepValues :: Name -> Q [Dec]+declareRepValues = declareRepValuesWith []++--------------------------------------------------------------------------------++-- | Same as 'deriveRep' except that you can pass a list of name modifications+-- to the deriving mechanism. See 'deriveWith' for an example.+deriveRepWith :: Modifiers -> Name -> Q [Dec]++#ifndef __HADDOCK__++deriveRepWith mods typeName = do+  (dt, _) <- declareConDescrsBase mods typeName+  (ep, _) <- declareEPBase mods dt+  (funNames, _) <- declareRepFunsBase mods dt ep+  g <- newName "g"+  repInstDecs <- deriveRepBase dt funNames g+  return repInstDecs++#else++deriveRepWith = undefined++#endif++-- | Generate 'Rep' instance declarations for a type. See 'derive' for an+-- example.+deriveRep :: Name -> Q [Dec]+deriveRep = deriveRepWith []++--------------------------------------------------------------------------------++-- | Same as 'deriveMono' except that you can pass a list of name+-- modifications to the deriving mechanism. See 'deriveWith' for an example.+deriveMonoWith :: Modifiers -> Name -> Q [Dec]++#ifndef __HADDOCK__++deriveMonoWith mods typeName = do+  (dt, conDescrDecs) <- declareConDescrsBase mods typeName+  (epName, epDecs) <- declareEPBase mods dt+  (repFunName, repFunDecs) <- mkRepFun mods OptRep dt epName+  let funNames = RepFunNames repFunName undefined undefined undefined undefined++  g <- newName "g"+  repInstDecs <- deriveRepBase dt funNames g++  collectInstDec <- mkRepCollectInst dt++  return $+    conDescrDecs           +++    epDecs                 +++    repFunDecs             +++    repInstDecs            +++    [collectInstDec]++#else++deriveMonoWith = undefined++#endif++-- | Same as 'derive' except that only the monomorphic 'Rep' representation+-- value and instance are generated. This is a convenience function that can be+-- used instead of the following declarations:+--+-- @+--   $(declareConDescrs ''T)+--   $(declareEP ''T)+--   $(declareMonoRep ''T)+--   $(deriveRep ''T)+--   $(deriveFRep ''T)+--   $(deriveCollect ''T)+-- @+deriveMono :: Name -> Q [Dec]+deriveMono = deriveMonoWith []++--------------------------------------------------------------------------------+++-- | Same as 'deriveFRep' except that you can pass a list of name modifications+-- to the deriving mechanism. See 'deriveWith' for an example.+deriveFRepWith :: Modifiers -> Name -> Q [Dec]++#ifndef __HADDOCK__++deriveFRepWith mods typeName = do+  (dt, _) <- declareConDescrsBase mods typeName+  (epName, _) <- declareEPBase mods dt+  (funNames, _) <- declareRepFunsBase mods dt epName+  g <- newName "g"+  frepInstDecs <- deriveFRepBase dt funNames g+  return frepInstDecs++#else++deriveFRepWith = undefined++#endif++-- | Generate 'FRep', 'FRep2', and 'FRep3' instance declarations for a type. See+-- 'derive' for an example.+deriveFRep :: Name -> Q [Dec]+deriveFRep = deriveFRepWith []++--------------------------------------------------------------------------------++-- | Same as 'deriveBiFRep' except that you can pass a list of name+-- modifications to the deriving mechanism. See 'deriveWith' for an example.+deriveBiFRepWith :: Modifiers -> Name -> Q [Dec]++#ifndef __HADDOCK__++deriveBiFRepWith mods typeName = do+  (dt, _) <- declareConDescrsBase mods typeName+  (epName, _) <- declareEPBase mods dt+  (funNames, _) <- declareRepFunsBase mods dt epName+  g <- newName "g"+  bifrepInstDecs <- deriveBiFRepBase dt funNames g+  return bifrepInstDecs++#else++deriveBiFRepWith = undefined++#endif++-- | Generate 'BiFRep2' instance declarations for a type. See 'derive' for an+-- example.+deriveBiFRep :: Name -> Q [Dec]+deriveBiFRep = deriveBiFRepWith []++--------------------------------------------------------------------------------++-- | Generate a @'Rep' 'Collect' T@ instance declaration for a type @T@. See+-- 'derive' for an example.+deriveCollect :: Name -> Q [Dec]++#ifndef __HADDOCK__++deriveCollect typeName = do+  (dt, _) <- declareConDescrsBase [] typeName+  collectInstDec <- mkRepCollectInst dt+  return [collectInstDec]++#else++deriveCollect = undefined++#endif++--------------------------------------------------------------------------------++-- | Generate a @'Rep' 'Everywhere' T@ instance declaration for a type @T@. See+-- 'derive' for an example.+deriveEverywhere :: Name -> Q [Dec]++#ifndef __HADDOCK__++deriveEverywhere typeName = do+  (dt, _) <- declareConDescrsBase [] typeName+  everywhereInstDec <- mkRepEverywhereInst dt+  return [everywhereInstDec]++#else++deriveEverywhere = undefined++#endif++-- | Generate a @'Rep' 'Everywhere'' T@ instance declaration for a type @T@. See+-- 'derive' for an example.+deriveEverywhere' :: Name -> Q [Dec]++#ifndef __HADDOCK__++deriveEverywhere' typeName = do+  (dt, _) <- declareConDescrsBase [] typeName+  everywhereInstDec' <- mkRepEverywhereInst' dt+  return [everywhereInstDec']++#else++deriveEverywhere' = undefined++#endif++

@@ -1,7 +1,7 @@ -----------------------------------------------------------------------------
 -- |
 -- Module      :  Generics.EMGM.Functions
--- Copyright   :  (c) 2008 Universiteit Utrecht
+-- Copyright   :  (c) 2008, 2009 Universiteit Utrecht
 -- License     :  BSD3
 --
 -- Maintainer  :  generics@haskell.org
@@ -17,6 +17,7 @@   module Generics.EMGM.Functions.Compare,
   module Generics.EMGM.Functions.Crush,
   module Generics.EMGM.Functions.Enum,
+  module Generics.EMGM.Functions.Everywhere,
   module Generics.EMGM.Functions.Map,
   module Generics.EMGM.Functions.Read,
   module Generics.EMGM.Functions.Show,
@@ -29,6 +30,7 @@ import Generics.EMGM.Functions.Compare
 import Generics.EMGM.Functions.Crush
 import Generics.EMGM.Functions.Enum
+import Generics.EMGM.Functions.Everywhere
 import Generics.EMGM.Functions.Map
 import Generics.EMGM.Functions.Read
 import Generics.EMGM.Functions.Show

@@ -7,7 +7,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Generics.EMGM.Functions.Collect--- Copyright   :  (c) 2008 Universiteit Utrecht+-- Copyright   :  (c) 2008, 2009 Universiteit Utrecht -- License     :  BSD3 -- -- Maintainer  :  generics@haskell.org@@ -35,18 +35,18 @@ -- list of values of another type. -- -- For datatypes to work with Collect, a special instance must be given. This--- instance is trivial to write. Given a type @D@, the 'Rep' instance looks like+-- instance is trivial to write. Given a type @T@, the 'Rep' instance looks like -- this: -- -- >  {-# LANGUAGE OverlappingInstances #-} -- >--- >  data D = ...+-- >  data T = ... -- >--- >  instance Rep (Collect D) D where+-- >  instance Rep (Collect T) T where -- >    rep = Collect (:[]) -- -- (Note the requirement of overlapping instances.) This instance triggers when--- the result type (the first @D@) matches some value type (the second @D@)+-- the result type (the first @T@) matches some value type (the second @T@) -- contained within the argument to 'collect'. See the source of this module for -- more examples. newtype Collect b a = Collect { selCollect :: a -> [b] }@@ -107,23 +107,23 @@ -- 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+-- the return type specified. Here are some examples using the same value with -- different return types: -- -- @---   ghci> let x = [Left 1, Right 'a', Left 2] :: [Either Int Char]---   ghci> collect x :: [Int]+--   ghci> let x = ['Left' 1, 'Right' \'a\', 'Left' 2] :: ['Either' 'Int' 'Char']+--   ghci> collect x :: ['Int'] --   [1,2]---   ghci> collect x :: [Char]+--   ghci> collect x :: ['Char'] --   \"a\" --   ghci> collect x == x---   True+--   '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.+-- 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'@.

@@ -4,7 +4,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Generics.EMGM.Functions.Compare--- Copyright   :  (c) 2008 Universiteit Utrecht+-- Copyright   :  (c) 2008, 2009 Universiteit Utrecht -- License     :  BSD3 -- -- Maintainer  :  generics@haskell.org

@@ -4,7 +4,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Generics.EMGM.Functions.Crush--- Copyright   :  (c) 2008 Universiteit Utrecht+-- Copyright   :  (c) 2008, 2009 Universiteit Utrecht -- License     :  BSD3 -- -- Maintainer  :  generics@haskell.org

@@ -4,7 +4,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Generics.EMGM.Functions.Enum--- Copyright   :  (c) 2008 Universiteit Utrecht+-- Copyright   :  (c) 2008, 2009 Universiteit Utrecht -- License     :  BSD3 -- -- Maintainer  :  generics@haskell.org

@@ -0,0 +1,266 @@+{-# LANGUAGE CPP                        #-}+{-# LANGUAGE TypeOperators              #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE OverlappingInstances       #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Generics.EMGM.Functions.Everywhere+-- Copyright   :  (c) 2008, 2009 Universiteit Utrecht+-- License     :  BSD3+--+-- Maintainer  :  generics@haskell.org+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Summary: Generic functions that apply a transformation at every location of+-- one type in a value of a possibly different type.+--+-- The functions 'everywhere' and 'everywhere'' have exactly the same type, but+-- they apply the transformation in different fashions. 'everywhere' uses+-- bottom-up application while 'everywhere'' uses a top-down approach. This may+-- make a difference if you have recursive datatypes or use nested pattern+-- matching in the higher-order function.+--+-- These functions are very similar to others with the same names in the \"Scrap+-- Your Boilerplate\" library (@syb@ package). The SYB functions use rank-2+-- types, while the EMGM functions use a single class constraint. Compare the+-- types of the following:+--+-- @+--   -- SYB+--   everywhere :: (forall a. 'Data' a => a -> a) -> forall a. 'Data' a => a -> a+-- @+--+-- @+--   -- EMGM+--   everywhere :: (Rep (Everywhere a) b) => (a -> a) -> b -> b+-- @+--------------------------------------------------------------------------------++module Generics.EMGM.Functions.Everywhere (+  Everywhere(..),+  everywhere,+  Everywhere'(..),+  everywhere',+) where++import Generics.EMGM.Common.Base+import Generics.EMGM.Common.Representation++#ifdef __HADDOCK__+import Data.Generics (Data)+#endif++--------------------------------------------------------------------------------+-- Types+--------------------------------------------------------------------------------++-- | The type of a generic function that takes a function of one type, a value+-- of another type, and returns a value of the value type.+--+-- For datatypes to work with Everywhere, a special instance must be given. This+-- instance is trivial to write. For a non-recursive type, the instance is the+-- same as described for 'Everywhere''. For a recursive type @T@, the 'Rep'+-- instance looks like this:+--+-- >   {-# LANGUAGE OverlappingInstances #-}+--+-- @+--   data T a = Val a | Rec (T a)+-- @+--+-- @+--   instance ('Rep' (Everywhere (T a)) (T a), 'Rep' (Everywhere (T a)) a) => 'Rep' (Everywhere (T a)) (T a) where+--     'rep' = Everywhere app+--       where+--         app f x =+--           case x of+--             Val v1 -> f (Val (selEverywhere 'rep' f v1))+--             Rec v1 -> f (Rec (selEverywhere 'rep' f v1))+-- @+--+-- Note the requirement of overlapping instances.+--+-- This instance is triggered when the function type (the first @T a@ in @'Rep'+-- (Everywhere (T a)) (T a)@) matches some value type (the second @T a@)+-- contained within the argument to 'everywhere'.+newtype Everywhere a b = Everywhere { selEverywhere :: (a -> a) -> b -> b }++--------------------------------------------------------------------------------+-- Generic instance declaration+--------------------------------------------------------------------------------++rconstantEverywhere :: (a -> a) -> b -> b+rconstantEverywhere _ = id++rsumEverywhere :: Everywhere a b1 -> Everywhere a b2 -> (a -> a) -> (b1 :+: b2) -> b1 :+: b2+rsumEverywhere ra _  f (L a) = L (selEverywhere ra f a)+rsumEverywhere _  rb f (R b) = R (selEverywhere rb f b)++rprodEverywhere :: Everywhere a b1 -> Everywhere a b2 -> (a -> a) -> (b1 :*: b2) -> b1 :*: b2+rprodEverywhere ra rb f (a :*: b) = selEverywhere ra f a :*: selEverywhere rb f b++rtypeEverywhere :: EP d b -> Everywhere a b -> (a -> a) -> d -> d+rtypeEverywhere ep ra f = to ep . selEverywhere ra f . from ep++instance Generic (Everywhere a) where+  rconstant      = Everywhere rconstantEverywhere+  rsum     ra rb = Everywhere (rsumEverywhere ra rb)+  rprod    ra rb = Everywhere (rprodEverywhere ra rb)+  rtype ep ra    = Everywhere (rtypeEverywhere ep ra)++--------------------------------------------------------------------------------+-- Rep instance declarations+--------------------------------------------------------------------------------++instance Rep (Everywhere Int) Int where+  rep = Everywhere ($)++instance Rep (Everywhere Integer) Integer where+  rep = Everywhere ($)++instance Rep (Everywhere Double) Double where+  rep = Everywhere ($)++instance Rep (Everywhere Float) Float where+  rep = Everywhere ($)++instance Rep (Everywhere Char) Char where+  rep = Everywhere ($)++--------------------------------------------------------------------------------+-- Exported functions+--------------------------------------------------------------------------------++-- | Apply a transformation @a -> a@ to values of type @a@ within the argument+-- of type @b@ in a bottom-up manner. Values that do not have type @a@ are+-- passed through 'id'.+--+-- @everywhere@ works by searching the datatype @b@ for values that are the same+-- type as the function argument type @a@. Here are some examples using the+-- datatype declared in the documentation for 'Everywhere'. +--+-- @+--   ghci> let f t = case t of { Val i -> Val (i+(1::'Int')); other -> other }+--   ghci> everywhere f (Val (1::'Int'))+--   Val 2+--   ghci> everywhere f (Rec (Rec (Val (1::'Int'))))+--   Rec (Rec (Val 2))+-- @+--+-- @+--   ghci> let x = ['Left' 1, 'Right' \'a\', 'Left' 2] :: ['Either' 'Int' 'Char']+--   ghci> everywhere (*(3::'Int')) x+--   ['Left' 3,'Right' \'a\','Left' 6]+--   ghci> everywhere (\\x -> x :: 'Float') x == x+--   'True'+-- @+--+-- Note the type annotations. Since numerical constants have the type @'Num' a+-- => a@, you may need to give explicit types. Also, the function @\\x -> x@ has+-- type @a -> a@, but we need to give it some non-polymorphic type here. By+-- design, there is no connection that can be inferred between the value type+-- and the function type.+--+-- @everywhere@ only works if there is an instance for the return type as+-- described in the @newtype 'Everywhere'@.+everywhere :: (Rep (Everywhere a) b) => (a -> a) -> b -> b+everywhere f = selEverywhere rep f+++--------------------------------------------------------------------------------+-- Types+--------------------------------------------------------------------------------++-- | This type servers the same purpose as 'Everywhere', except that 'Rep'+-- instances are designed to be top-down instead of bottom-up. That means, given+-- any type @U@ (recursive or not), the 'Rep' instance looks like this:+--+-- >   {-# LANGUAGE OverlappingInstances #-}+--+-- @+--   data U = ...+-- @+--+-- @+--   instance 'Rep' (Everywhere' U) U where+--     'rep' = Everywhere' ($)+-- @+--+-- Note the requirement of overlapping instances.+--+-- This instance is triggered when the function type (the first @U@ in @'Rep'+-- (Everywhere U) U@) matches some value type (the second @U@) contained within+-- the argument to 'everywhere''.+newtype Everywhere' a b = Everywhere' { selEverywhere' :: (a -> a) -> b -> b }++--------------------------------------------------------------------------------+-- Generic instance declaration+--------------------------------------------------------------------------------++rconstantEverywhere' :: (a -> a) -> b -> b+rconstantEverywhere' _ = id++rsumEverywhere' :: Everywhere' a b1 -> Everywhere' a b2 -> (a -> a) -> (b1 :+: b2) -> b1 :+: b2+rsumEverywhere' ra _  f (L a) = L (selEverywhere' ra f a)+rsumEverywhere' _  rb f (R b) = R (selEverywhere' rb f b)++rprodEverywhere' :: Everywhere' a b1 -> Everywhere' a b2 -> (a -> a) -> (b1 :*: b2) -> b1 :*: b2+rprodEverywhere' ra rb f (a :*: b) = selEverywhere' ra f a :*: selEverywhere' rb f b++rtypeEverywhere' :: EP d b -> Everywhere' a b -> (a -> a) -> d -> d+rtypeEverywhere' ep ra f = to ep . selEverywhere' ra f . from ep++instance Generic (Everywhere' a) where+  rconstant      = Everywhere' rconstantEverywhere'+  rsum     ra rb = Everywhere' (rsumEverywhere' ra rb)+  rprod    ra rb = Everywhere' (rprodEverywhere' ra rb)+  rtype ep ra    = Everywhere' (rtypeEverywhere' ep ra)++--------------------------------------------------------------------------------+-- Rep instance declarations+--------------------------------------------------------------------------------++instance Rep (Everywhere' Int) Int where+  rep = Everywhere' ($)++instance Rep (Everywhere' Integer) Integer where+  rep = Everywhere' ($)++instance Rep (Everywhere' Double) Double where+  rep = Everywhere' ($)++instance Rep (Everywhere' Float) Float where+  rep = Everywhere' ($)++instance Rep (Everywhere' Char) Char where+  rep = Everywhere' ($)++--------------------------------------------------------------------------------+-- Exported functions+--------------------------------------------------------------------------------++-- | Apply a transformation @a -> a@ to values of type @a@ within the argument+-- of type @b@ in a top-down manner. Values that do not have type @a@ are passed+-- through 'id'.+--+-- @everywhere'@ is the same as 'everywhere' with the exception of recursive+-- datatypes. For example, compare the example used in the documentation for+-- 'everywhere' with the following.+--+-- @+--   ghci> let f t = case t of { Val i -> Val (i+(1::'Int')); other -> other }+--   ghci> everywhere' f (Val (1::'Int'))+--   Val 2+--   ghci> everywhere' f (Rec (Rec (Val (1::'Int'))))+--   Rec (Rec (Val 1))+-- @+--+-- @everywhere'@ only works if there is an instance for the return type as+-- described in the @newtype 'Everywhere''@.+everywhere' :: (Rep (Everywhere' a) b) => (a -> a) -> b -> b+everywhere' f = selEverywhere' rep f+

@@ -4,19 +4,22 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Generics.EMGM.Functions.Map--- Copyright   :  (c) 2008 Universiteit Utrecht+-- Copyright   :  (c) 2008, 2009 Universiteit Utrecht -- License     :  BSD3 -- -- Maintainer  :  generics@haskell.org -- Stability   :  experimental -- Portability :  non-portable ----- Summary: Generic function that applies a (non-generic) function to all--- elements contained in a polymorphic datatype.+-- Summary: Generic functions that translate values of one type into values of+-- another. ----- 'map' is a generic version of the @Prelude@ @map@ function. It works on all--- supported container datatypes of kind @* -> *@. The 'map' function is+-- 'map' is a generic version of the @Prelude@ @map@ function. It works+-- on all supported container datatypes of kind @* -> *@. The 'map' function is -- equivalent to 'fmap' after @deriving 'Functor'@ if that were possible.+--+-- 'cast' is a generic and configurable function for converting a value of one+-- type into a value of another using instances provided by the programmer. -----------------------------------------------------------------------------  module Generics.EMGM.Functions.Map (@@ -24,6 +27,7 @@   map,   replace,   bimap,+  cast, ) where  import Prelude hiding (map)@@ -69,7 +73,8 @@ map :: (FRep2 Map f) => (a -> b) -> f a -> f b map = selMap . frep2 . Map --- | Replace all @a@-values in @as@ with @b@.+-- | Replace all @a@-values in @as@ with @b@. This is a convenience function for+-- the implementation @'map' ('const' b) as@. replace :: (FRep2 Map f) => f a -> b -> f b replace as b = map (const b) as @@ -77,5 +82,41 @@ -- 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)+bimap f g = selMap (bifrep2 (Map f) (Map g))++-- | Cast a value of one type into a value of another. This is a configurable+-- function that allows you to define your own type-safe conversions for a+-- variety of types.+--+-- @cast@ works with instances of @'Rep' ('Map' i) o@ in which you choose the+-- input type @i@ and the output type @o@ and implement the function of type @i+-- -> o@.+--+-- Here are some examples of instances (and flags you will need or want):+--+-- >   {-# LANGUAGE MultiParamTypeClasses  #-}+-- >   {-# LANGUAGE FlexibleContexts       #-}+-- >   {-# LANGUAGE FlexibleInstances      #-}+-- >   {-# OPTIONS_GHC -fno-warn-orphans   #-}+--+-- @+--   instance 'Rep' ('Map' 'Int') 'Char' where+--     'rep' = 'Map' 'chr'+-- @+--+-- @+--   instance 'Rep' ('Map' 'Float') 'Double' where+--     'rep' = 'Map' 'realToFrac'+-- @+--+-- @+--   instance 'Rep' ('Map' 'Integer') 'Integer' where+--     'rep' = 'Map' (+42)+-- @+--+-- There are no pre-defined instances, and a call to @cast@ will not compile if+-- no instances for the input and output type pair is found, so you must define+-- instances in order to use @cast@.+cast :: (Rep (Map a) b) => a -> b+cast = selMap rep 

@@ -8,7 +8,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Generics.EMGM.Functions.Read--- Copyright   :  (c) 2008 Universiteit Utrecht+-- Copyright   :  (c) 2008, 2009 Universiteit Utrecht -- License     :  BSD3 -- -- Maintainer  :  generics@haskell.org

@@ -8,7 +8,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Generics.EMGM.Functions.Show--- Copyright   :  (c) 2008 Universiteit Utrecht+-- Copyright   :  (c) 2008, 2009 Universiteit Utrecht -- License     :  BSD3 -- -- Maintainer  :  generics@haskell.org

@@ -4,7 +4,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Generics.EMGM.Functions.UnzipWith--- Copyright   :  (c) 2008 Universiteit Utrecht+-- Copyright   :  (c) 2008, 2009 Universiteit Utrecht -- License     :  BSD3 -- -- Maintainer  :  generics@haskell.org

@@ -4,7 +4,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Generics.EMGM.Functions.ZipWith--- Copyright   :  (c) 2008 Universiteit Utrecht+-- Copyright   :  (c) 2008, 2009 Universiteit Utrecht -- License     :  BSD3 -- -- Maintainer  :  generics@haskell.org

@@ -1,6 +1,15 @@ {-# LANGUAGE TypeOperators    #-} {-# OPTIONS -fno-warn-orphans #-} +-----------------------------------------------------------------------------+-- |+-- Module      :  Base+-- Copyright   :  (c) 2008, 2009 Universiteit Utrecht+-- License     :  BSD3+--+-- Maintainer  :  generics@haskell.org+-----------------------------------------------------------------------------+ module Base where  import Generics.EMGM

@@ -5,6 +5,15 @@ {-# LANGUAGE Rank2Types                 #-} {-# OPTIONS_GHC -fno-warn-unused-binds  #-} +-----------------------------------------------------------------------------+-- |+-- Module      :  Bimap+-- Copyright   :  (c) 2008, 2009 Universiteit Utrecht+-- License     :  BSD3+--+-- Maintainer  :  generics@haskell.org+-----------------------------------------------------------------------------+ module Bimap (tests) where  import Test.HUnit ((~:))@@ -12,6 +21,7 @@  import Base ((~|:)) import Generics.EMGM hiding (Show)+import Generics.EMGM.Derive  -------------------------------------------------------------------------------- -- Fixed-point stuff

@@ -1,4 +1,13 @@ +-----------------------------------------------------------------------------+-- |+-- Module      :  Collect+-- Copyright   :  (c) 2008, 2009 Universiteit Utrecht+-- License     :  BSD3+--+-- Maintainer  :  generics@haskell.org+-----------------------------------------------------------------------------+ module Collect (tests) where  import Test.HUnit

@@ -1,5 +1,14 @@ {-# LANGUAGE FlexibleContexts #-} +-----------------------------------------------------------------------------+-- |+-- Module      :  Compare+-- Copyright   :  (c) 2008, 2009 Universiteit Utrecht+-- License     :  BSD3+--+-- Maintainer  :  generics@haskell.org+-----------------------------------------------------------------------------+ module Compare where  import Prelude hiding (Show, show, compare, min, max)

@@ -1,5 +1,14 @@ {-# LANGUAGE FlexibleContexts #-} +-----------------------------------------------------------------------------+-- |+-- Module      :  Crush+-- Copyright   :  (c) 2008, 2009 Universiteit Utrecht+-- License     :  BSD3+--+-- Maintainer  :  generics@haskell.org+-----------------------------------------------------------------------------+ module Crush (tests) where  import Prelude as P

@@ -2,24 +2,33 @@ {-# LANGUAGE TemplateHaskell            #-} {-# LANGUAGE TypeOperators              #-} {-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE FlexibleContexts           #-} {-# LANGUAGE MultiParamTypeClasses      #-} {-# LANGUAGE OverlappingInstances       #-} {-# LANGUAGE UndecidableInstances       #-} {-# OPTIONS_GHC -fno-warn-unused-binds  #-} {-  OPTIONS_GHC -ddump-splices           -} +-----------------------------------------------------------------------------+-- |+-- Module      :  Derive+-- Copyright   :  (c) 2008, 2009 Universiteit Utrecht+-- License     :  BSD3+--+-- Maintainer  :  generics@haskell.org+-----------------------------------------------------------------------------+ module Derive (tests) where  -------------------------------------------------------------------------------- -- Imports -------------------------------------------------------------------------------- -import Data.Char (ord)+import Data.Char (ord, toUpper) import Test.HUnit  import Generics.EMGM as G-import Generics.EMGM.Data.Tuple (epTuple2, conTuple2)-import Generics.EMGM.Common.Derive+import Generics.EMGM.Derive  -------------------------------------------------------------------------------- -- Test deriving for functor type@@ -36,8 +45,8 @@   | B4 (B Double)   | B5 (Maybe a)   | B6 (A (Maybe [a]))---  | B7 (Int -> a)         -- UNSUPPORTED---  | B8 (a,a)              -- UNSUPPORTED+  | B7 (a,a)+--  | B_ (Int -> a)         -- UNSUPPORTED  -- We only support a functor type containing constant types or another functor -- type. In other words, we don't support higher arity type constructors (>1@@ -46,28 +55,24 @@ $(derive ''B)  ----------------------------------------------------------------------------------- Test for contained tuple+-- Test for other things -------------------------------------------------------------------------------- --- 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+  = C1 (a,Int) -- ^ odd tuple+  | C2 String  -- ^ type synonym+  | C3 (a,a,a) (a,a,a,a) (a,a,C a,a,a) (a,a,a,a,a,a) (a,a,a,a,a,a,a)+       -- ^ tuples and type constructor application up to arity 7.+  | C4 a -- ^ included so we don't get the warning about the repC function's+         -- argument being defined but not used.+  deriving (Eq, Prelude.Show) --- | 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)+$(derive ''C) --- 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_mapC = "map ord (C3 ...)" ~: G.map ord i ~?= o+  where+    i = C3 ('a','a','a') ('b','b','b','b') ('c','c',C2 "blah",'c','c') ('d','d','d','d','d','d') ('e','e','e','e','e','e','e')+    o = C3 (97,97,97) (98,98,98,98) (99,99,C2 "blah",99,99) (100,100,100,100,100,100) (101,101,101,101,101,101,101)  -------------------------------------------------------------------------------- -- Test for deriving bifunctor type@@ -80,7 +85,7 @@   | D4 (D a b) (D a b)   | D5 (D b a)   | D6 (Either a b) (b,a) (b,Int)---  | D6 [a]            -- UNSUPPORTED+  | D7 [a]  -- We only support a bifunctor type containing constant types or another -- bifunctor type. In other words, we don't support a bifunctor type containing@@ -129,9 +134,11 @@  $(declareConDescrs ''F) $(declareEP ''F)+$(declareRepValues ''F) $(deriveRep ''F) $(deriveFRep ''F) $(deriveCollect ''F)+$(deriveEverywhere ''F)  test_manual1 =   "show $ map ord (C 'a' 4)" ~:@@ -141,17 +148,23 @@   "collect (F (4::Integer) 3)" ~:     assert (collect (F (4::Integer) 3) `eq` ([F 4 3::F Integer])) +test_manual3 =+  "everywhere toUpper (F 'x' 3)" ~:+    assert (everywhere toUpper (F 'x' 3) `eq` F 'X' 3)+ -------------------------------------------------------------------------------- -- Test collection --------------------------------------------------------------------------------  tests =   "Derive" ~:-    [ test_ChangeTo1+    [ test_mapC+    , test_ChangeTo1     , test_ChangeTo2     , test_ChangeTo3     , test_DefinedAs1     , test_manual1     , test_manual2+    , test_manual3     ] 

@@ -1,5 +1,14 @@ {-# LANGUAGE FlexibleContexts #-} +-----------------------------------------------------------------------------+-- |+-- Module      :  Enum+-- Copyright   :  (c) 2008, 2009 Universiteit Utrecht+-- License     :  BSD3+--+-- Maintainer  :  generics@haskell.org+-----------------------------------------------------------------------------+ module Enum (tests) where  import Prelude hiding (Show, Enum)

@@ -0,0 +1,128 @@++-----------------------------------------------------------------------------+-- |+-- Module      :  Everywhere+-- Copyright   :  (c) 2008, 2009 Universiteit Utrecht+-- License     :  BSD3+--+-- Maintainer  :  generics@haskell.org+-----------------------------------------------------------------------------++module Everywhere (tests) where++import TTree+import Generics.EMGM as G++import Test.HUnit+import Data.Char (toUpper, toLower)++-----------------------------------------------------------------------------+-- Utility functions+-----------------------------------------------------------------------------++test_e  descr f_actual val f_expected = descr ~: (G.everywhere  f_actual val) ~?= f_expected val+test_e' descr f_actual val f_expected = descr ~: (G.everywhere' f_actual val) ~?= f_expected val++-----------------------------------------------------------------------------+-- Test functions and values+-----------------------------------------------------------------------------++f_int :: Int -> Int+f_int i = i * 4++f_integer :: Integer -> Integer+f_integer i = i * 4++f_float :: Float -> Float+f_float i = i * 4++f_double :: Double -> Double+f_double i = i * 4++f_char :: Char -> Char+f_char c = toUpper c++f_either_int_char :: Either Int Char -> Either Int Char+f_either_int_char (Left i) = Left (f_int i)+f_either_int_char (Right c) = Right (f_char c)++f_maybe_double :: Maybe Double -> Maybe Double+f_maybe_double Nothing = Just 5.0+f_maybe_double (Just d) = Just (d / 20.8)++f_list_char1 :: String -> String+f_list_char1 = G.map toLower++f_list_char2 :: String -> String+f_list_char2 (_:_) = []+f_list_char2 []    = []++f_unit :: () -> ()+f_unit = id++f_ttree1 :: TTree Int -> TTree Int+f_ttree1 (L1 4)         = L1 7+f_ttree1 (L2 5 (L1 4))  = L1 9+f_ttree1 x              = x++-----------------------------------------------------------------------------+-- Test collection+-----------------------------------------------------------------------------++tests =+  "" ~:++    [ "Everywhere" ~:+       [ test_e "Int" f_int (5::Int) f_int+       , test_e "Integer" f_integer (999::Integer) f_integer+       , test_e "Float" f_float (0.9::Float) f_float+       , test_e "Double" f_double ((-2e10)::Double) f_double+       , test_e "Char" f_char ('z'::Char) f_char+       , test_e "Either Int Char(Char)" f_char (Left 4::Either Int Char) id+       , test_e "Either Int Char(Int)" f_int (Left 4::Either Int Char) (G.bimap f_int id)+       , test_e "Either Int Char(Either Int Char)" f_either_int_char (Right 'x'::Either Int Char) (G.bimap id f_char)+       , test_e "Maybe Double(Double)" f_double (Just (-2e10)::Maybe Double) (G.map f_double)+       , test_e "Maybe Double(Maybe Double)" f_maybe_double (Just (-2e10)::Maybe Double) f_maybe_double+       , test_e "[Char](Char)" f_char "emgm" (G.map f_char)+       , test_e "cons to nil" f_list_char1 "EMGM" f_list_char1+       , test_e "[Char]([Char])" f_list_char2 "EMGM" (const [])+       , test_e "()" f_unit () id+       , test_e "(Int,Float)" f_float (42::Int,1.5::Float) (G.bimap id f_float)+       , test_e "(,)" f_unit ((),()) id+       , test_e "(,,)" f_unit ((),(),()) id+       , test_e "(,,,)" f_unit ((),(),(),()) id+       , test_e "(,,,,)" f_unit ((),(),(),(),()) id+       , test_e "(,,,,,)" f_unit ((),(),(),(),(),()) id+       , test_e "(,,,,,,)" f_unit ((),(),(),(),(),(),()) id+       , test_e "TTree1" f_ttree1 (L1 4) f_ttree1+       , test_e "TTree2" f_ttree1 (L2 (5::Int) (L1 4)) (const (L2 5 (L1 7)))+       ]++    , "Everywhere'" ~:+       [ test_e' "Int" f_int (5::Int) f_int+       , test_e' "Integer" f_integer (999::Integer) f_integer+       , test_e' "Float" f_float (0.9::Float) f_float+       , test_e' "Double" f_double ((-2e10)::Double) f_double+       , test_e' "Char" f_char ('z'::Char) f_char+       , test_e' "Either Int Char(Char)" f_char (Left 4::Either Int Char) id+       , test_e' "Either Int Char(Int)" f_int (Left 4::Either Int Char) (G.bimap f_int id)+       , test_e' "Either Int Char(Either Int Char)" f_either_int_char (Right 'x'::Either Int Char) (G.bimap id f_char)+       , test_e' "Maybe Double(Double)" f_double (Just (-2e10)::Maybe Double) (G.map f_double)+       , test_e' "Maybe Double(Maybe Double)" f_maybe_double (Just (-2e10)::Maybe Double) f_maybe_double+       , test_e' "[Char](Char)" f_char "emgm" (G.map f_char)+       , test_e' "[Char]([Char])" f_list_char1 "EMGM" f_list_char1+       , test_e' "[Char]([Char])" f_list_char2 "EMGM" (const [])+       , test_e' "()" f_unit () id+       , test_e' "(Int,Float)" f_float (42::Int,1.5::Float) (G.bimap id f_float)+       , test_e' "(,)" f_unit ((),()) id+       , test_e' "(,,)" f_unit ((),(),()) id+       , test_e' "(,,,)" f_unit ((),(),(),()) id+       , test_e' "(,,,,)" f_unit ((),(),(),(),()) id+       , test_e' "(,,,,,)" f_unit ((),(),(),(),(),()) id+       , test_e' "(,,,,,,)" f_unit ((),(),(),(),(),(),()) id+       , test_e' "TTree1" f_ttree1 (L1 4) f_ttree1+       , test_e' "TTree2" f_ttree1 (L2 (5::Int) (L1 4)) (const (L1 9))+       ]++    ]+

@@ -1,4 +1,13 @@ +-----------------------------------------------------------------------------+-- |+-- Module      :  Main+-- Copyright   :  (c) 2008, 2009 Universiteit Utrecht+-- License     :  BSD3+--+-- Maintainer  :  generics@haskell.org+-----------------------------------------------------------------------------+ module Main where  import Test.HUnit@@ -8,6 +17,7 @@ import qualified Compare        (tests) import qualified Collect        (tests) import qualified Enum           (tests)+import qualified Everywhere     (tests) import qualified ZipWith        (tests) import qualified UnzipWith      (tests) import qualified Map            (tests)@@ -23,6 +33,7 @@            , Compare.tests            , Collect.tests            , Enum.tests+           , Everywhere.tests            , ZipWith.tests            , UnzipWith.tests            , Map.tests

@@ -1,13 +1,25 @@-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# OPTIONS_GHC -fno-warn-orphans       #-} +-----------------------------------------------------------------------------+-- |+-- Module      :  Map+-- Copyright   :  (c) 2008, 2009 Universiteit Utrecht+-- License     :  BSD3+--+-- Maintainer  :  generics@haskell.org+-----------------------------------------------------------------------------+ module Map (tests) where  import Prelude hiding (map) import qualified Prelude as P (map)-import Data.Char (ord)+import Data.Char (ord, chr) import Test.HUnit -import Generics.EMGM+import Generics.EMGM as G  ----------------------------------------------------------------------------- -- Utility functions@@ -25,6 +37,23 @@   "replace [Float] [[Double]]" ~:     replace [0.1,0.2,0.3::Float] ([]::[Double]) ~?= [[],[],[]] +instance Rep (Map Int) Char where+  rep = Map chr++instance Rep (Map Int) Int where+  rep = Map (+5)++instance Rep (Map Float) Double where+  rep = Map realToFrac++instance Rep (Map String) (Maybe Integer) where+  rep = Map G.read++test_cast1 = "cast (65::Int) :: Char" ~: cast (65::Int) ~?= 'A'+test_cast2 = "cast (-5::Int) :: Int" ~: (cast (-5::Int) :: Int) ~?= 0+test_cast3 = "cast (1::Float) :: Double" ~: (cast (1::Float) :: Double) ~?= 1+test_cast4 = "cast \"37\" :: Maybe Integer" ~: (cast "37" :: Maybe Integer) ~?= Just 37+ ----------------------------------------------------------------------------- -- Test collection -----------------------------------------------------------------------------@@ -34,5 +63,9 @@           , test_map2           , test_map3           , test_replace1+          , test_cast1+          , test_cast2+          , test_cast3+          , test_cast4           ] 

@@ -1,6 +1,15 @@ {-# LANGUAGE FlexibleContexts      #-} {-# LANGUAGE FlexibleInstances     #-} +-----------------------------------------------------------------------------+-- |+-- Module      :  ReadShow+-- Copyright   :  (c) 2008, 2009 Universiteit Utrecht+-- License     :  BSD3+--+-- Maintainer  :  generics@haskell.org+-----------------------------------------------------------------------------+ module ReadShow (tests) where  import Prelude hiding (Read, Show, readsPrec, reads, read, show)

@@ -1,17 +1,28 @@ {-# LANGUAGE TemplateHaskell          #-} {-# LANGUAGE FlexibleInstances        #-}+{-# LANGUAGE FlexibleContexts         #-} {-# LANGUAGE MultiParamTypeClasses    #-} {-# LANGUAGE DeriveDataTypeable       #-}+{-# LANGUAGE OverlappingInstances     #-} {-# LANGUAGE UndecidableInstances     #-} {-  OPTIONS -ddump-splices             -} +-----------------------------------------------------------------------------+-- |+-- Module      :  TTree+-- Copyright   :  (c) 2008, 2009 Universiteit Utrecht+-- License     :  BSD3+--+-- Maintainer  :  generics@haskell.org+-----------------------------------------------------------------------------+ module TTree where  import Prelude hiding (Read, Show) import qualified Prelude as P (Read, Show) import Data.Generics (Data, Typeable) -import Generics.EMGM+import Generics.EMGM.Derive  infixr 6 :^: infixl 5 :<>:@@ -28,89 +39,4 @@  $(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---} 

@@ -1,5 +1,14 @@ {-# LANGUAGE FlexibleContexts #-} +-----------------------------------------------------------------------------+-- |+-- Module      :  UnzipWith+-- Copyright   :  (c) 2008, 2009 Universiteit Utrecht+-- License     :  BSD3+--+-- Maintainer  :  generics@haskell.org+-----------------------------------------------------------------------------+ module UnzipWith (tests) where  import Prelude hiding (unzip)

@@ -1,5 +1,14 @@ {-# LANGUAGE FlexibleContexts #-} +-----------------------------------------------------------------------------+-- |+-- Module      :  ZipWith+-- Copyright   :  (c) 2008, 2009 Universiteit Utrecht+-- License     :  BSD3+--+-- Maintainer  :  generics@haskell.org+-----------------------------------------------------------------------------+ module ZipWith (tests) where  import Prelude hiding (zipWith, zip)

@@ -2,6 +2,15 @@  \begin{code} +-----------------------------------------------------------------------------+-- |+-- Module      :  Main+-- Copyright   :  (c) 2008, 2009 Universiteit Utrecht+-- License     :  BSD3+--+-- Maintainer  :  generics@haskell.org+-----------------------------------------------------------------------------+ module Main (main) where  import System.Cmd (system)