diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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, diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -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} diff --git a/emgm.cabal b/emgm.cabal --- a/emgm.cabal +++ b/emgm.cabal @@ -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 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. diff --git a/examples/Ex00StartHere.hs b/examples/Ex00StartHere.hs --- a/examples/Ex00StartHere.hs +++ b/examples/Ex00StartHere.hs @@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Ex00StartHere --- Copyright : (c) 2008 Universiteit Utrecht +-- Copyright : (c) 2008, 2009 Universiteit Utrecht -- License : BSD3 -- -- Maintainer : generics@haskell.org diff --git a/examples/Ex01UsingFunctions.hs b/examples/Ex01UsingFunctions.hs --- a/examples/Ex01UsingFunctions.hs +++ b/examples/Ex01UsingFunctions.hs @@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Ex01UsingFunctions --- Copyright : (c) 2008 Universiteit Utrecht +-- Copyright : (c) 2008, 2009 Universiteit Utrecht -- License : BSD3 -- -- Maintainer : generics@haskell.org diff --git a/examples/Ex02AddingDatatypeSupport.hs b/examples/Ex02AddingDatatypeSupport.hs --- a/examples/Ex02AddingDatatypeSupport.hs +++ b/examples/Ex02AddingDatatypeSupport.hs @@ -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 diff --git a/examples/Ex03DefiningFunctions.hs b/examples/Ex03DefiningFunctions.hs --- a/examples/Ex03DefiningFunctions.hs +++ b/examples/Ex03DefiningFunctions.hs @@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Ex03DefiningFunctions --- Copyright : (c) 2008 Universiteit Utrecht +-- Copyright : (c) 2008, 2009 Universiteit Utrecht -- License : BSD3 -- -- Maintainer : generics@haskell.org diff --git a/src/Generics/EMGM.hs b/src/Generics/EMGM.hs --- a/src/Generics/EMGM.hs +++ b/src/Generics/EMGM.hs @@ -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() diff --git a/src/Generics/EMGM/Common.hs b/src/Generics/EMGM/Common.hs --- a/src/Generics/EMGM/Common.hs +++ b/src/Generics/EMGM/Common.hs @@ -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 diff --git a/src/Generics/EMGM/Common/Base.hs b/src/Generics/EMGM/Common/Base.hs --- a/src/Generics/EMGM/Common/Base.hs +++ b/src/Generics/EMGM/Common/Base.hs @@ -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 diff --git a/src/Generics/EMGM/Common/Base2.hs b/src/Generics/EMGM/Common/Base2.hs --- a/src/Generics/EMGM/Common/Base2.hs +++ b/src/Generics/EMGM/Common/Base2.hs @@ -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 diff --git a/src/Generics/EMGM/Common/Base3.hs b/src/Generics/EMGM/Common/Base3.hs --- a/src/Generics/EMGM/Common/Base3.hs +++ b/src/Generics/EMGM/Common/Base3.hs @@ -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 diff --git a/src/Generics/EMGM/Common/Derive.hs b/src/Generics/EMGM/Common/Derive.hs deleted file mode 100644 --- a/src/Generics/EMGM/Common/Derive.hs +++ /dev/null @@ -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 - diff --git a/src/Generics/EMGM/Common/Derive/Common.hs b/src/Generics/EMGM/Common/Derive/Common.hs deleted file mode 100644 --- a/src/Generics/EMGM/Common/Derive/Common.hs +++ /dev/null @@ -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 "" - diff --git a/src/Generics/EMGM/Common/Derive/ConDescr.hs b/src/Generics/EMGM/Common/Derive/ConDescr.hs deleted file mode 100644 --- a/src/Generics/EMGM/Common/Derive/ConDescr.hs +++ /dev/null @@ -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 - diff --git a/src/Generics/EMGM/Common/Derive/EP.hs b/src/Generics/EMGM/Common/Derive/EP.hs deleted file mode 100644 --- a/src/Generics/EMGM/Common/Derive/EP.hs +++ /dev/null @@ -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 - diff --git a/src/Generics/EMGM/Common/Derive/Instance.hs b/src/Generics/EMGM/Common/Derive/Instance.hs deleted file mode 100644 --- a/src/Generics/EMGM/Common/Derive/Instance.hs +++ /dev/null @@ -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 - diff --git a/src/Generics/EMGM/Common/Representation.hs b/src/Generics/EMGM/Common/Representation.hs --- a/src/Generics/EMGM/Common/Representation.hs +++ b/src/Generics/EMGM/Common/Representation.hs @@ -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 diff --git a/src/Generics/EMGM/Data.hs b/src/Generics/EMGM/Data.hs deleted file mode 100644 --- a/src/Generics/EMGM/Data.hs +++ /dev/null @@ -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 - diff --git a/src/Generics/EMGM/Data/Bool.hs b/src/Generics/EMGM/Data/Bool.hs --- a/src/Generics/EMGM/Data/Bool.hs +++ b/src/Generics/EMGM/Data/Bool.hs @@ -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 diff --git a/src/Generics/EMGM/Data/Either.hs b/src/Generics/EMGM/Data/Either.hs --- a/src/Generics/EMGM/Data/Either.hs +++ b/src/Generics/EMGM/Data/Either.hs @@ -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 diff --git a/src/Generics/EMGM/Data/List.hs b/src/Generics/EMGM/Data/List.hs --- a/src/Generics/EMGM/Data/List.hs +++ b/src/Generics/EMGM/Data/List.hs @@ -1,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' ($) diff --git a/src/Generics/EMGM/Data/Maybe.hs b/src/Generics/EMGM/Data/Maybe.hs --- a/src/Generics/EMGM/Data/Maybe.hs +++ b/src/Generics/EMGM/Data/Maybe.hs @@ -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 diff --git a/src/Generics/EMGM/Data/TH.hs b/src/Generics/EMGM/Data/TH.hs --- a/src/Generics/EMGM/Data/TH.hs +++ b/src/Generics/EMGM/Data/TH.hs @@ -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 diff --git a/src/Generics/EMGM/Data/Tuple.hs b/src/Generics/EMGM/Data/Tuple.hs --- a/src/Generics/EMGM/Data/Tuple.hs +++ b/src/Generics/EMGM/Data/Tuple.hs @@ -1,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 + ) + ) diff --git a/src/Generics/EMGM/Derive.hs b/src/Generics/EMGM/Derive.hs new file mode 100644 --- /dev/null +++ b/src/Generics/EMGM/Derive.hs @@ -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 + diff --git a/src/Generics/EMGM/Derive/Common.hs b/src/Generics/EMGM/Derive/Common.hs new file mode 100644 --- /dev/null +++ b/src/Generics/EMGM/Derive/Common.hs @@ -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) + diff --git a/src/Generics/EMGM/Derive/ConDescr.hs b/src/Generics/EMGM/Derive/ConDescr.hs new file mode 100644 --- /dev/null +++ b/src/Generics/EMGM/Derive/ConDescr.hs @@ -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 + diff --git a/src/Generics/EMGM/Derive/EP.hs b/src/Generics/EMGM/Derive/EP.hs new file mode 100644 --- /dev/null +++ b/src/Generics/EMGM/Derive/EP.hs @@ -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 + diff --git a/src/Generics/EMGM/Derive/Functions.hs b/src/Generics/EMGM/Derive/Functions.hs new file mode 100644 --- /dev/null +++ b/src/Generics/EMGM/Derive/Functions.hs @@ -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 + diff --git a/src/Generics/EMGM/Derive/Instance.hs b/src/Generics/EMGM/Derive/Instance.hs new file mode 100644 --- /dev/null +++ b/src/Generics/EMGM/Derive/Instance.hs @@ -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 + diff --git a/src/Generics/EMGM/Derive/Internal.hs b/src/Generics/EMGM/Derive/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Generics/EMGM/Derive/Internal.hs @@ -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 + + diff --git a/src/Generics/EMGM/Functions.hs b/src/Generics/EMGM/Functions.hs --- a/src/Generics/EMGM/Functions.hs +++ b/src/Generics/EMGM/Functions.hs @@ -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 diff --git a/src/Generics/EMGM/Functions/Collect.hs b/src/Generics/EMGM/Functions/Collect.hs --- a/src/Generics/EMGM/Functions/Collect.hs +++ b/src/Generics/EMGM/Functions/Collect.hs @@ -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'@. diff --git a/src/Generics/EMGM/Functions/Compare.hs b/src/Generics/EMGM/Functions/Compare.hs --- a/src/Generics/EMGM/Functions/Compare.hs +++ b/src/Generics/EMGM/Functions/Compare.hs @@ -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 diff --git a/src/Generics/EMGM/Functions/Crush.hs b/src/Generics/EMGM/Functions/Crush.hs --- a/src/Generics/EMGM/Functions/Crush.hs +++ b/src/Generics/EMGM/Functions/Crush.hs @@ -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 diff --git a/src/Generics/EMGM/Functions/Enum.hs b/src/Generics/EMGM/Functions/Enum.hs --- a/src/Generics/EMGM/Functions/Enum.hs +++ b/src/Generics/EMGM/Functions/Enum.hs @@ -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 diff --git a/src/Generics/EMGM/Functions/Everywhere.hs b/src/Generics/EMGM/Functions/Everywhere.hs new file mode 100644 --- /dev/null +++ b/src/Generics/EMGM/Functions/Everywhere.hs @@ -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 + diff --git a/src/Generics/EMGM/Functions/Map.hs b/src/Generics/EMGM/Functions/Map.hs --- a/src/Generics/EMGM/Functions/Map.hs +++ b/src/Generics/EMGM/Functions/Map.hs @@ -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 diff --git a/src/Generics/EMGM/Functions/Read.hs b/src/Generics/EMGM/Functions/Read.hs --- a/src/Generics/EMGM/Functions/Read.hs +++ b/src/Generics/EMGM/Functions/Read.hs @@ -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 diff --git a/src/Generics/EMGM/Functions/Show.hs b/src/Generics/EMGM/Functions/Show.hs --- a/src/Generics/EMGM/Functions/Show.hs +++ b/src/Generics/EMGM/Functions/Show.hs @@ -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 diff --git a/src/Generics/EMGM/Functions/UnzipWith.hs b/src/Generics/EMGM/Functions/UnzipWith.hs --- a/src/Generics/EMGM/Functions/UnzipWith.hs +++ b/src/Generics/EMGM/Functions/UnzipWith.hs @@ -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 diff --git a/src/Generics/EMGM/Functions/ZipWith.hs b/src/Generics/EMGM/Functions/ZipWith.hs --- a/src/Generics/EMGM/Functions/ZipWith.hs +++ b/src/Generics/EMGM/Functions/ZipWith.hs @@ -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 diff --git a/tests/Base.hs b/tests/Base.hs --- a/tests/Base.hs +++ b/tests/Base.hs @@ -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 diff --git a/tests/Bimap.hs b/tests/Bimap.hs --- a/tests/Bimap.hs +++ b/tests/Bimap.hs @@ -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 diff --git a/tests/Collect.hs b/tests/Collect.hs --- a/tests/Collect.hs +++ b/tests/Collect.hs @@ -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 diff --git a/tests/Compare.hs b/tests/Compare.hs --- a/tests/Compare.hs +++ b/tests/Compare.hs @@ -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) diff --git a/tests/Crush.hs b/tests/Crush.hs --- a/tests/Crush.hs +++ b/tests/Crush.hs @@ -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 diff --git a/tests/Derive.hs b/tests/Derive.hs --- a/tests/Derive.hs +++ b/tests/Derive.hs @@ -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 ] diff --git a/tests/Enum.hs b/tests/Enum.hs --- a/tests/Enum.hs +++ b/tests/Enum.hs @@ -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) diff --git a/tests/Everywhere.hs b/tests/Everywhere.hs new file mode 100644 --- /dev/null +++ b/tests/Everywhere.hs @@ -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)) + ] + + ] + diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -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 diff --git a/tests/Map.hs b/tests/Map.hs --- a/tests/Map.hs +++ b/tests/Map.hs @@ -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 ] diff --git a/tests/ReadShow.hs b/tests/ReadShow.hs --- a/tests/ReadShow.hs +++ b/tests/ReadShow.hs @@ -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) diff --git a/tests/TTree.hs b/tests/TTree.hs --- a/tests/TTree.hs +++ b/tests/TTree.hs @@ -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 - --} diff --git a/tests/UnzipWith.hs b/tests/UnzipWith.hs --- a/tests/UnzipWith.hs +++ b/tests/UnzipWith.hs @@ -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) diff --git a/tests/ZipWith.hs b/tests/ZipWith.hs --- a/tests/ZipWith.hs +++ b/tests/ZipWith.hs @@ -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) diff --git a/util/hpc.lhs b/util/hpc.lhs --- a/util/hpc.lhs +++ b/util/hpc.lhs @@ -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)