diff --git a/LICENSE b/LICENSE
--- a/LICENSE
+++ b/LICENSE
@@ -1,28 +1,28 @@
-Copyright (c) 2010 Universiteit Utrecht
-All rights reserved.
-
-Redistribution and use in source and binary forms, with or without modification,
-are permitted provided that the following conditions are met:
-
-1. Redistributions of source code must retain the above copyright notice, this
- list of conditions and the following disclaimer.
-
-2. Redistributions in binary form must reproduce the above copyright notice,
- this list of conditions and the following disclaimer in the documentation
- and/or other materials provided with the distribution.
-
-3. Neither the name of Universiteit Utrecht nor the names of its contributors
- may be used to endorse or promote products derived from this software without
- specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
-ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
-WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR
-ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
-(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
-LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
-ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
-SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
+Copyright (c) 2010 Universiteit Utrecht
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without modification,
+are permitted provided that the following conditions are met:
+
+1. Redistributions of source code must retain the above copyright notice, this
+ list of conditions and the following disclaimer.
+
+2. Redistributions in binary form must reproduce the above copyright notice,
+ this list of conditions and the following disclaimer in the documentation
+ and/or other materials provided with the distribution.
+
+3. Neither the name of Universiteit Utrecht nor the names of its contributors
+ may be used to endorse or promote products derived from this software without
+ specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR
+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
+ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
diff --git a/Setup.hs b/Setup.hs
--- a/Setup.hs
+++ b/Setup.hs
@@ -1,3 +1,3 @@
-import Distribution.Simple
-
-main = defaultMain
+import Distribution.Simple
+
+main = defaultMain
diff --git a/examples/GMapAssoc.hs b/examples/GMapAssoc.hs
--- a/examples/GMapAssoc.hs
+++ b/examples/GMapAssoc.hs
@@ -1,87 +1,87 @@
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE FlexibleInstances #-}
-
-module Main where
-
-import Prelude hiding (lookup)
-import Char (ord)
-import qualified Data.Map as Map
-import Control.Monad ((>=>))
-import Generics.Instant
-
--- Generalized tries, as from http://www.haskell.org/haskellwiki/GHC/Type_families#An_associated_data_type_example
-
-class Representable k => GMapKey k where
- data GMap k :: * -> *
- empty :: GMap k v
- lookup :: k -> GMap k v -> Maybe v
- insert :: k -> v -> GMap k v -> GMap k v
-
-instance GMapKey Int where
- data GMap Int v = GMapInt (Map.Map Int v)
- empty = GMapInt Map.empty
- lookup k (GMapInt m) = Map.lookup k m
- insert k v (GMapInt m) = GMapInt (Map.insert k v m)
-
-instance GMapKey Char where
- data GMap Char v = GMapChar (GMap Int v)
- empty = GMapChar empty
- lookup k (GMapChar m) = lookup (ord k) m
- insert k v (GMapChar m) = GMapChar (insert (ord k) v m)
-
-instance GMapKey U where
- data GMap U v = GMapUnit (Maybe v)
- empty = GMapUnit Nothing
- lookup U (GMapUnit v) = v
- insert U v (GMapUnit _) = GMapUnit $ Just v
-
-instance (GMapKey a, GMapKey b) => GMapKey (a :*: b) where
- data GMap (a :*: b) v = GMapProd (GMap a (GMap b v))
- empty = GMapProd empty
- lookup (a :*: b) (GMapProd gm) = lookup a gm >>= lookup b
- insert (a :*: b) v (GMapProd gm) =
- GMapProd $ case lookup a gm of
- Nothing -> insert a (insert b v empty) gm
- Just gm2 -> insert a (insert b v gm2 ) gm
-
-instance (GMapKey a, GMapKey b) => GMapKey (a :+: b) where
- data GMap (a :+: b) v = GMapSum (GMap a v) (GMap b v)
- empty = GMapSum empty empty
- lookup (L a) (GMapSum gm1 _gm2) = lookup a gm1
- lookup (R b) (GMapSum _gm1 gm2 ) = lookup b gm2
- insert (L a) v (GMapSum gm1 gm2) = GMapSum (insert a v gm1) gm2
- insert (R a) v (GMapSum gm1 gm2) = GMapSum gm1 (insert a v gm2)
-
--- Uninteresting cases, but necessary
-instance (GMapKey a) => GMapKey (CEq c p q a) where
- data GMap (CEq c p q a) v = GMapCon (GMap a v)
- empty = GMapCon empty
- lookup (C c) (GMapCon m) = lookup c m
- insert (C c) v (GMapCon m) = GMapCon (insert c v m)
-
-instance (GMapKey a) => GMapKey (Var a) where
- data GMap (Var a) v = GMapVar (GMap a v)
- empty = GMapVar empty
- lookup (Var x) (GMapVar m) = lookup x m
- insert (Var x) v (GMapVar m) = GMapVar (insert x v m)
-
-instance (GMapKey a) => GMapKey (Rec a) where
- data GMap (Rec a) v = GMapRec (GMap a v)
- empty = GMapRec empty
- lookup (Rec x) (GMapRec m) = lookup x m
- insert (Rec x) v (GMapRec m) = GMapRec (insert x v m)
-
--- Boilerplate code, but unavoidable (for now)
-instance GMapKey k => GMapKey [k] where
- data GMap [k] v = GMapList (GMap (Rep [k]) v)
-
- empty = GMapList empty
- lookup k (GMapList m) = lookup (from k) m
- insert k v (GMapList m) = GMapList (insert (from k) v m)
-
--- Example
-t1 :: Maybe String
-t1 = lookup [1,2,3] $ insert ([1..3] :: [Int]) "[1,2,3]" $ empty
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE FlexibleInstances #-}
+
+module Main where
+
+import Prelude hiding (lookup)
+import Char (ord)
+import qualified Data.Map as Map
+import Control.Monad ((>=>))
+import Generics.Instant
+
+-- Generalized tries, as from http://www.haskell.org/haskellwiki/GHC/Type_families#An_associated_data_type_example
+
+class Representable k => GMapKey k where
+ data GMap k :: * -> *
+ empty :: GMap k v
+ lookup :: k -> GMap k v -> Maybe v
+ insert :: k -> v -> GMap k v -> GMap k v
+
+instance GMapKey Int where
+ data GMap Int v = GMapInt (Map.Map Int v)
+ empty = GMapInt Map.empty
+ lookup k (GMapInt m) = Map.lookup k m
+ insert k v (GMapInt m) = GMapInt (Map.insert k v m)
+
+instance GMapKey Char where
+ data GMap Char v = GMapChar (GMap Int v)
+ empty = GMapChar empty
+ lookup k (GMapChar m) = lookup (ord k) m
+ insert k v (GMapChar m) = GMapChar (insert (ord k) v m)
+
+instance GMapKey U where
+ data GMap U v = GMapUnit (Maybe v)
+ empty = GMapUnit Nothing
+ lookup U (GMapUnit v) = v
+ insert U v (GMapUnit _) = GMapUnit $ Just v
+
+instance (GMapKey a, GMapKey b) => GMapKey (a :*: b) where
+ data GMap (a :*: b) v = GMapProd (GMap a (GMap b v))
+ empty = GMapProd empty
+ lookup (a :*: b) (GMapProd gm) = lookup a gm >>= lookup b
+ insert (a :*: b) v (GMapProd gm) =
+ GMapProd $ case lookup a gm of
+ Nothing -> insert a (insert b v empty) gm
+ Just gm2 -> insert a (insert b v gm2 ) gm
+
+instance (GMapKey a, GMapKey b) => GMapKey (a :+: b) where
+ data GMap (a :+: b) v = GMapSum (GMap a v) (GMap b v)
+ empty = GMapSum empty empty
+ lookup (L a) (GMapSum gm1 _gm2) = lookup a gm1
+ lookup (R b) (GMapSum _gm1 gm2 ) = lookup b gm2
+ insert (L a) v (GMapSum gm1 gm2) = GMapSum (insert a v gm1) gm2
+ insert (R a) v (GMapSum gm1 gm2) = GMapSum gm1 (insert a v gm2)
+
+-- Uninteresting cases, but necessary
+instance (GMapKey a) => GMapKey (CEq c p q a) where
+ data GMap (CEq c p q a) v = GMapCon (GMap a v)
+ empty = GMapCon empty
+ lookup (C c) (GMapCon m) = lookup c m
+ insert (C c) v (GMapCon m) = GMapCon (insert c v m)
+
+instance (GMapKey a) => GMapKey (Var a) where
+ data GMap (Var a) v = GMapVar (GMap a v)
+ empty = GMapVar empty
+ lookup (Var x) (GMapVar m) = lookup x m
+ insert (Var x) v (GMapVar m) = GMapVar (insert x v m)
+
+instance (GMapKey a) => GMapKey (Rec a) where
+ data GMap (Rec a) v = GMapRec (GMap a v)
+ empty = GMapRec empty
+ lookup (Rec x) (GMapRec m) = lookup x m
+ insert (Rec x) v (GMapRec m) = GMapRec (insert x v m)
+
+-- Boilerplate code, but unavoidable (for now)
+instance GMapKey k => GMapKey [k] where
+ data GMap [k] v = GMapList (GMap (Rep [k]) v)
+
+ empty = GMapList empty
+ lookup k (GMapList m) = lookup (from k) m
+ insert k v (GMapList m) = GMapList (insert (from k) v m)
+
+-- Example
+t1 :: Maybe String
+t1 = lookup [1,2,3] $ insert ([1..3] :: [Int]) "[1,2,3]" $ empty
diff --git a/instant-generics.cabal b/instant-generics.cabal
--- a/instant-generics.cabal
+++ b/instant-generics.cabal
@@ -1,46 +1,46 @@
-category: Generics
-copyright: (c) 2011 Universiteit Utrecht
-name: instant-generics
-version: 0.3.4
-license: BSD3
-license-file: LICENSE
-author: José Pedro Magalhães
-maintainer: generics@haskell.org
-synopsis: Generic programming library with a sum of products view
-description:
-
- This is a generic programming library based on type classes and type families
- first described by Chakravarty et al. (see
- ). The current release
- implements the extensions to support indexed datatypes described in:
- .
- * José Pedro Magalhães and Johan Jeuring.
- /Generic Programming for Indexed Datatypes./
- Draft version, 2011.
-
-
-stability: experimental
-build-type: Simple
-homepage: http://www.cs.uu.nl/wiki/GenericProgramming/InstantGenerics
-cabal-version: >= 1.6
-tested-with: GHC == 6.8.3, GHC == 6.10.4, GHC == 6.12.1, GHC == 7.0.2
-extra-source-files: examples/GMapAssoc.hs
- examples/Test.hs
-
-source-repository head
- type: svn
- location: https://subversion.cs.uu.nl/repos/project.dgp-haskell.libraries/Instant/trunk/
-
-library
- hs-source-dirs: src
- build-depends: base >= 3.0 && < 5, template-haskell >= 2.4 && < 3,
- containers < 0.5, syb < 0.4
- exposed-modules: Generics.Instant,
- Generics.Instant.Base,
- Generics.Instant.TH,
- Generics.Instant.Instances,
- Generics.Instant.Functions,
- Generics.Instant.Functions.Show,
- Generics.Instant.Functions.Empty,
- Generics.Instant.Functions.Eq
- ghc-options: -Wall
+category: Generics
+copyright: (c) 2011 Universiteit Utrecht, 2012 University of Oxford
+name: instant-generics
+version: 0.3.5
+license: BSD3
+license-file: LICENSE
+author: José Pedro Magalhães
+maintainer: generics@haskell.org
+synopsis: Generic programming library with a sum of products view
+description:
+
+ This is a generic programming library based on type classes and type families
+ first described by Chakravarty et al. (see
+ ). The current release
+ implements the extensions to support indexed datatypes described in:
+ .
+ * José Pedro Magalhães and Johan Jeuring.
+ /Generic Programming for Indexed Datatypes./
+ Draft version, 2011.
+
+
+stability: experimental
+build-type: Simple
+homepage: http://www.cs.uu.nl/wiki/GenericProgramming/InstantGenerics
+cabal-version: >= 1.6
+tested-with: GHC == 6.8.3, GHC == 6.10.4, GHC == 6.12.1, GHC == 7.0.2
+extra-source-files: examples/GMapAssoc.hs
+ examples/Test.hs
+
+source-repository head
+ type: git
+ location: https://github.com/dreixel/instant-generics
+
+library
+ hs-source-dirs: src
+ build-depends: base >= 3.0 && < 5, template-haskell >= 2.4 && < 3,
+ containers < 0.5, syb < 0.4
+ exposed-modules: Generics.Instant,
+ Generics.Instant.Base,
+ Generics.Instant.TH,
+ Generics.Instant.Instances,
+ Generics.Instant.Functions,
+ Generics.Instant.Functions.Show,
+ Generics.Instant.Functions.Empty,
+ Generics.Instant.Functions.Eq
+ ghc-options: -Wall
diff --git a/src/Generics/Instant/Functions.hs b/src/Generics/Instant/Functions.hs
--- a/src/Generics/Instant/Functions.hs
+++ b/src/Generics/Instant/Functions.hs
@@ -1,23 +1,23 @@
------------------------------------------------------------------------------
--- |
--- Module : Generics.Instant.Functions
--- Copyright : (c) 2010, Universiteit Utrecht
--- License : BSD3
---
--- Maintainer : generics@haskell.org
--- Stability : experimental
--- Portability : non-portable
---
--- This module simply reexports all the generic functions' modules.
---
------------------------------------------------------------------------------
-
-module Generics.Instant.Functions (
- module Generics.Instant.Functions.Empty,
- module Generics.Instant.Functions.Show,
- module Generics.Instant.Functions.Eq
- ) where
-
-import Generics.Instant.Functions.Empty
-import Generics.Instant.Functions.Show
-import Generics.Instant.Functions.Eq
+-----------------------------------------------------------------------------
+-- |
+-- Module : Generics.Instant.Functions
+-- Copyright : (c) 2010, Universiteit Utrecht
+-- License : BSD3
+--
+-- Maintainer : generics@haskell.org
+-- Stability : experimental
+-- Portability : non-portable
+--
+-- This module simply reexports all the generic functions' modules.
+--
+-----------------------------------------------------------------------------
+
+module Generics.Instant.Functions (
+ module Generics.Instant.Functions.Empty,
+ module Generics.Instant.Functions.Show,
+ module Generics.Instant.Functions.Eq
+ ) where
+
+import Generics.Instant.Functions.Empty
+import Generics.Instant.Functions.Show
+import Generics.Instant.Functions.Eq
diff --git a/src/Generics/Instant/TH.hs b/src/Generics/Instant/TH.hs
--- a/src/Generics/Instant/TH.hs
+++ b/src/Generics/Instant/TH.hs
@@ -1,585 +1,585 @@
-{-# LANGUAGE TemplateHaskell, CPP #-}
-{-# OPTIONS_GHC -w #-}
-
------------------------------------------------------------------------------
--- |
--- Module : Generics.Instant.TH
--- Copyright : (c) 2011 Universiteit Utrecht
--- License : BSD3
---
--- Maintainer : generics@haskell.org
--- Stability : experimental
--- Portability : non-portable
---
--- This module contains Template Haskell code that can be used to
--- automatically generate the boilerplate code for the generic deriving
--- library.
------------------------------------------------------------------------------
-
--- Adapted from Generics.Deriving.TH
-module Generics.Instant.TH (
- -- * Main generator
- deriveAll, deriveAllL
-
- -- * Individual generators
- , deriveConstructors
- , deriveRepresentable
- , deriveRep
-
- -- * Utilities
- , simplInstance, gadtInstance
- , genRepName, typeVariables, tyVarBndrToName
- ) where
-
-import Generics.Instant.Base
-import Generics.SYB (everywhere, mkT, everything, mkQ, gshow)
-
-import Language.Haskell.TH hiding (Fixity())
-import Language.Haskell.TH.Syntax (Lift(..), showName)
-
-import Data.List (intercalate, nub, elemIndex)
-import qualified Data.Map as M
-import Control.Monad
-import Control.Arrow ((&&&))
-
--- Used by gadtInstance
-data TypeArgsEqs = TypeArgsEqs { args :: [Type] -- ^ Constructor args
- , vars :: [Name] -- ^ Variables
- , teqs :: [(Type,Type)] -- ^ Type equalities
- } deriving Show
-
--- | Given the names of a generic class, a type to instantiate, a function in
--- the class and the default implementation, generates the code for a basic
--- generic instance.
-simplInstance :: Name -> Name -> Name -> Name -> Q [Dec]
-simplInstance cl ty fn df = do
- i <- reify ty
- let typ = return (foldl (\a -> AppT a . VarT . tyVarBndrToName)
- (ConT ty) (typeVariables i))
- fmap (: []) $ instanceD (cxt []) (conT cl `appT` typ)
- [funD fn [clause [] (normalB (varE df)) []]]
-
--- | Given the names of a generic class, a GADT type to instantiate, a function
--- in the class and the default implementation, generates the code for a basic
--- generic instance. This is tricky in general because we have to analyze the
--- return types of each of the GADT constructors and give instances accordingly.
-gadtInstance :: Name -> Name -> Name -> Name -> Q [Dec]
-gadtInstance cl ty fn df = do
- i <- reify ty
- let typ = (foldl (\a -> AppT a . VarT . tyVarBndrToName)
- (ConT ty) (typeVariables i))
-
- dt :: ([TyVarBndr],[Con])
- dt = case i of
- TyConI (DataD _ _ vs cs _) -> (vs, cs)
- _ -> error ("gadtInstance: " ++ show ty ++ "is not a valid type")
-
- -- List of index variable names
- idxs :: [Name]
- idxs = extractIndices (fst dt) (snd dt)
-
- -- Get all the arguments, variables, and type equalities introduced by the
- -- constructors
- eqs :: [Name] -> [Con] -> [TypeArgsEqs]
- eqs nms cs = map f cs where
- f :: Con -> TypeArgsEqs
- f (NormalC _ tys) = TypeArgsEqs (map snd tys) [] []
- f (RecC _ tys) = TypeArgsEqs (map (\(_,_,t) -> t) tys) [] []
- f (InfixC t1 _ t2) = TypeArgsEqs [snd t1, snd t2] [] []
- f (ForallC vs cxt c) = case f c of
- TypeArgsEqs ts vs' eqs' ->
- TypeArgsEqs ts (tyVarBndrsToNames vs ++ vs')
- ((concatMap g cxt) ++ eqs')
- g :: Pred -> [(Type,Type)]
- g (EqualP (VarT t1) t2) | t1 `elem` nms = [(VarT t1,t2)]
- | otherwise = []
- g _ = []
-
- subst :: [(Type,Type)] -> Type -> Type
- subst s = everywhere (mkT f) where
- f (VarT a) = case lookup (VarT a) s of
- Nothing -> VarT a
- Just t -> t
- f x = x
-
- mkInst :: TypeArgsEqs -> Dec
- mkInst t = InstanceD (map mkCxt (args t))
- (ConT cl `AppT` subst (teqs t) typ) instBody
-
- mkCxt :: Type -> Pred
- mkCxt = ClassP cl . (:[])
-
- -- The instance body is empty for regular cases
- instBody :: [Dec]
- instBody = [FunD fn [Clause [] (NormalB (VarE df)) []]]
-
- update :: TypeArgsEqs -> [TypeArgsEqs] -> [TypeArgsEqs]
- -- update True t1 [] = [t1]
- update _ [] = []
- update t1 (t2:ts) | teqs t1 == teqs t2 =
- t2 {args = nub (args t1 ++ args t2)} : ts
- | otherwise = t2 : update t1 ts
-
- -- Types without any type equalities (not real GADTs) need to be handled
- -- differently. Others are dealt with using filterMerge.
- handleADTs :: ([TypeArgsEqs] -> [TypeArgsEqs])
- -> [TypeArgsEqs] -> [TypeArgsEqs]
- handleADTs f ts | and (map (null . teqs) ts)
- = [TypeArgsEqs (concatMap args ts) [] []]
- | otherwise = f ts
-
- -- We need to
- -- 1) ignore constructors that don't introduce any type equalities
- -- 2) merge constructors with the same return type
- -- This code is terribly inefficient and could easily be improved, btw.
- filterMerge :: [TypeArgsEqs] -> [TypeArgsEqs]
- filterMerge (t0@(TypeArgsEqs ts vs eqs):t)
- | eqs == [] = update t0 (filterMerge t)
- | otherwise = case filterMerge t of
- l -> if or (concat
- [ [ typeMatch vs (vars t2) eq1 eq2
- | eq1 <- eqs, eq2 <- teqs t2 ] | t2 <- l ])
- then update t0 l
- else t0 : l
- filterMerge [] = []
-
- -- For (2) above, we need to consider type equality modulo
- -- quantified-variable names
- typeMatch :: [Name] -> [Name] -> (Type,Type) -> (Type,Type) -> Bool
- typeMatch vs1 vs2 eq1 eq2 | length vs1 /= length vs2 = False
- | otherwise
- = eq1 == everywhere (mkT f) eq2
- where f (VarT n) = case n `elemIndex` vs2 of
- -- is not a quantified variable
- Nothing -> VarT n
- -- it is, replace it with the equivalent var
- Just i -> VarT (vs1 !! i)
- f x = x
-
- allTypeArgsEqs = eqs idxs (snd dt)
-
- normInsts = map mkInst (handleADTs filterMerge allTypeArgsEqs)
-
- return $ normInsts
-
-
--- | Given the type and the name (as string) for the type to derive,
--- generate the 'Constructor' instances and the 'Representable' instance.
-deriveAll :: Name -> Q [Dec]
-deriveAll n =
- do a <- deriveConstructors n
- b <- deriveRepresentable n
- return (a ++ b)
-
--- | Same as 'deriveAll', but taking a list as input.
-deriveAllL :: [Name] -> Q [Dec]
-deriveAllL = fmap concat . mapM deriveAll
-
--- | Given a datatype name, derive datatypes and
--- instances of class 'Constructor'.
-deriveConstructors :: Name -> Q [Dec]
-deriveConstructors = constrInstance
-
--- | Given the type and the name (as string) for the Representable type
--- synonym to derive, generate the 'Representable' instance.
-deriveRepresentable :: Name -> Q [Dec]
-deriveRepresentable n = do
- rep <- deriveRep n
- inst <- deriveInst n
- return $ rep ++ inst
-
--- | Derive only the 'Rep' type synonym. Not needed if 'deriveRepresentable'
--- is used.
-deriveRep :: Name -> Q [Dec]
-deriveRep n = do
- i <- reify n
-
- let d = case i of
- TyConI dec -> dec
- _ -> error "unknown construct"
-
- exTyFamsInsts <- genExTyFamInsts d
- fmap (: exTyFamsInsts) $
- tySynD (genRepName n) (typeVariables i) (repType d (typeVariables i))
-
-deriveInst :: Name -> Q [Dec]
-deriveInst t = do
- i <- reify t
- let typ q = return $ foldl (\a -> AppT a . VarT . tyVarBndrToName) (ConT q)
- (typeVariables i)
- inlPrg = pragInlD t (inlineSpecPhase True False True 1)
- fcs <- mkFrom t 1 0 t
- tcs <- mkTo t 1 0 t
- liftM (:[]) $
- instanceD (cxt [])
- (conT ''Representable `appT` typ t)
- [ tySynInstD ''Rep [typ t] (typ (genRepName t))
- , {- inlPrg, -} funD 'from fcs, funD 'to tcs]
-
-constrInstance :: Name -> Q [Dec]
-constrInstance n = do
- i <- reify n
- case i of
- TyConI (DataD _ n _ cs _) -> mkInstance n cs
- TyConI (NewtypeD _ n _ c _) -> mkInstance n [c]
- _ -> return []
- where
- mkInstance n cs = do
- ds <- mapM (mkConstrData n) cs
- is <- mapM (mkConstrInstance n) cs
- return $ ds ++ is
-
-typeVariables :: Info -> [TyVarBndr]
-typeVariables (TyConI (DataD _ _ tv _ _)) = tv
-typeVariables (TyConI (NewtypeD _ _ tv _ _)) = tv
-typeVariables _ = []
-
-tyVarBndrsToNames :: [TyVarBndr] -> [Name]
-tyVarBndrsToNames = map tyVarBndrToName
-
-tyVarBndrToName :: TyVarBndr -> Name
-tyVarBndrToName (PlainTV name) = name
-tyVarBndrToName (KindedTV name _) = name
-
-stripRecordNames :: Con -> Con
-stripRecordNames (RecC n f) =
- NormalC n (map (\(_, s, t) -> (s, t)) f)
-stripRecordNames c = c
-
-genName :: [Name] -> Name
-genName = mkName . (++"_") . intercalate "_" . map nameBase
-
-genRepName :: Name -> Name
-genRepName = mkName . (++"_") . ("Rep" ++) . nameBase
-
-mkConstrData :: Name -> Con -> Q Dec
-mkConstrData dt (NormalC n _) =
- dataD (cxt []) (genName [dt, n]) [] [] []
-mkConstrData dt r@(RecC _ _) =
- mkConstrData dt (stripRecordNames r)
-mkConstrData dt (InfixC t1 n t2) =
- mkConstrData dt (NormalC n [t1,t2])
--- Contexts are ignored
-mkConstrData dt (ForallC _ _ c) = mkConstrData dt c
-
-instance Lift Fixity where
- lift Prefix = conE 'Prefix
- lift (Infix a n) = conE 'Infix `appE` [| a |] `appE` [| n |]
-
-instance Lift Associativity where
- lift LeftAssociative = conE 'LeftAssociative
- lift RightAssociative = conE 'RightAssociative
- lift NotAssociative = conE 'NotAssociative
-
-mkConstrInstance :: Name -> Con -> Q Dec
--- Contexts are ignored
-mkConstrInstance dt (ForallC _ _ c) = mkConstrInstance dt c
-mkConstrInstance dt (NormalC n _) = mkConstrInstanceWith dt n []
-mkConstrInstance dt (RecC n _) = mkConstrInstanceWith dt n
- [ funD 'conIsRecord [clause [wildP] (normalB (conE 'True)) []]]
-mkConstrInstance dt (InfixC t1 n t2) =
- do
- i <- reify n
- let fi = case i of
- DataConI _ _ _ f -> convertFixity f
- _ -> Prefix
- instanceD (cxt []) (appT (conT ''Constructor) (conT $ genName [dt, n]))
- [funD 'conName [clause [wildP] (normalB (stringE (nameBase n))) []],
- funD 'conFixity [clause [wildP] (normalB [| fi |]) []]]
- where
- convertFixity (Fixity n d) = Infix (convertDirection d) n
- convertDirection InfixL = LeftAssociative
- convertDirection InfixR = RightAssociative
- convertDirection InfixN = NotAssociative
-
-mkConstrInstanceWith :: Name -> Name -> [Q Dec] -> Q Dec
-mkConstrInstanceWith dt n extra =
- instanceD (cxt []) (appT (conT ''Constructor) (conT $ genName [dt, n]))
- (funD 'conName [clause [wildP] (normalB (stringE (nameBase n))) []] : extra)
-
-repType :: Dec -> [TyVarBndr] -> Q Type
-repType i repVs =
- do let sum :: Q Type -> Q Type -> Q Type
- sum a b = conT ''(:+:) `appT` a `appT` b
- case i of
- (DataD _ dt vs cs _) ->
- (foldBal' sum (error "Empty datatypes are not supported.")
- (map (repConGADT (dt, tyVarBndrsToNames vs) repVs
- (extractIndices vs cs)) cs))
- (NewtypeD _ dt vs c _) -> repConGADT (dt, tyVarBndrsToNames vs) repVs
- (extractIndices vs [c]) c
- (TySynD t _ _) -> error "type synonym?"
- _ -> error "unknown construct"
-
-
--- Given a datatype declaration, returns a list of its type variables which are
--- used as index and not as data
-extractIndices :: [TyVarBndr] -> [Con] -> [Name]
-extractIndices vs = nub . everything (++) ([] `mkQ` isIndexEq) where
- isIndexEq :: Pred -> [Name]
- isIndexEq (EqualP (VarT a) (VarT b)) = if a `elem` tyVarBndrsToNames vs
- then (a:)
- (if b `elem` tyVarBndrsToNames vs
- then [b] else []) else []
- isIndexEq (EqualP (VarT a) _) = if a `elem` tyVarBndrsToNames vs
- then [a] else []
- isIndexEq (EqualP _ (VarT a)) = if a `elem` tyVarBndrsToNames vs
- then [a] else []
- isIndexEq _ = []
-
-repConGADT :: (Name, [Name]) -> [TyVarBndr] -> [Name] -> Con -> Q Type
--- We only accept one index variable, for now
-repConGADT _ _ vs@(_:_:_) (ForallC _ _ _) =
- error ("Datatype indexed over >1 variable: " ++ show vs)
--- Handle type equality constraints
-repConGADT d@(dt, dtVs) repVs [indexVar] (ForallC vs ctx c) =
- do
- let
- genTypeEqs ((EqualP t1 t2):r) | otherwise = case genTypeEqs r of
- (t1s,t2s) -> ( ConT ''(:*:) `AppT` (substTyVar vsN t1) `AppT` t1s
- , ConT ''(:*:) `AppT` (substTyVar vsN t2) `AppT` t2s)
- genTypeEqs (_:r) = genTypeEqs r -- other constraints are ignored
- genTypeEqs [] = baseEqs
-
- substTyVar :: [Name] -> Type -> Type
- substTyVar ns = everywhere (mkT f) where
- f (VarT v) = case elemIndex v ns of
- Nothing -> VarT v
- Just i -> ConT ''X
- `AppT` ConT (genName [dt,getConName c])
- `AppT` int2TLNat i
- `AppT` VarT indexVar
- f x = x
-
- vsN :: [Name]
- vsN = tyVarBndrsToNames vs
-
- -- Go on with generating the representation type, taking the equalities
- repCon (dt, dtVs) (everywhere (mkT (substTyVar vsN)) c) (genTypeEqs ctx)
--- No constraints, go on as usual
-repConGADT d _repVs _ c = repCon d c baseEqs
-
--- Extract the constructor name
-getConName :: Con -> Name
-getConName (NormalC n _) = n
-getConName (RecC n _) = n
-getConName (InfixC _ n _) = n
-getConName (ForallC _ _ c) = getConName c
-
--- Generate a type-level natural from an Int
-int2TLNat :: Int -> Type
-int2TLNat 0 = ConT ''Ze
-int2TLNat n = ConT ''Su `AppT` int2TLNat (n-1)
-
--- Generate the mobility rules for the existential type families
-genExTyFamInsts :: Dec -> Q [Dec]
-genExTyFamInsts (DataD _ n _ cs _) = fmap concat $
- mapM (genExTyFamInsts' n) cs
-genExTyFamInsts (NewtypeD _ n _ c _) = genExTyFamInsts' n c
-
-genExTyFamInsts' :: Name -> Con -> Q [Dec]
-genExTyFamInsts' dt (ForallC vs cxt c) =
- do let mR = mobilityRules (tyVarBndrsToNames vs) cxt
- conName = ConT (genName [dt,getConName c])
- tySynInst ty n x = TySynInstD ''X [conName, int2TLNat n, ty] x
- return [ tySynInst ty n (VarT nm) | (n,(nm, ty)) <- zip [0..] mR ]
-genExTyFamInsts' _ _ = return []
-
--- Compute the shape of the mobility rules
-mobilityRules :: [Name] -> Cxt -> [(Name,Type)]
-mobilityRules [] _ = []
-mobilityRules vs cxt = concat [ mobilityRules' v p | v <- vs, p <- cxt ] where
- mobilityRules' :: Name -> Pred -> [(Name,Type)]
- mobilityRules' _ (EqualP (VarT _) (VarT _)) = []
- mobilityRules' v (EqualP (VarT a) x) | v `inComplex` x = [(v,x)]
- | otherwise = []
- mobilityRules' v (EqualP x (VarT a)) = mobilityRules' v (EqualP (VarT a) x)
- mobilityRules' v _ = []
-
- inComplex :: Name -> Type -> Bool
- inComplex v (VarT _) = False
- inComplex v x = everything (||) (False `mkQ` q) x where
- q (VarT x) | x == v = True
- q (VarT x) | otherwise = False
- q _ = False
-
-flattenEqs :: (Type, Type) -> Q Type
-flattenEqs (t1, t2) = return t1 `appT` return t2
-
--- () ~ ()
-baseEqs :: (Type, Type)
-baseEqs = (TupleT 0, TupleT 0)
-
-repCon :: (Name, [Name]) -> Con -> (Type,Type) -> Q Type
-repCon _ (ForallC _ _ _) _ = error "impossible"
-repCon (dt, vs) (NormalC n []) (t1,t2) =
- conT ''CEq `appT` (conT $ genName [dt, n]) `appT` return t1
- `appT` return t2 `appT` conT ''U
-repCon (dt, vs) (NormalC n fs) (t1,t2) =
- conT ''CEq `appT` (conT $ genName [dt, n]) `appT` return t1
- `appT` return t2 `appT`
- (foldBal prod (map (repField (dt, vs) . snd) fs)) where
- prod :: Q Type -> Q Type -> Q Type
- prod a b = conT ''(:*:) `appT` a `appT` b
-repCon (dt, vs) r@(RecC n []) (t1,t2) =
- conT ''CEq `appT` (conT $ genName [dt, n]) `appT` return t1
- `appT` return t2 `appT` conT ''U
-repCon (dt, vs) r@(RecC n fs) (t1,t2) =
- conT ''CEq `appT` (conT $ genName [dt, n]) `appT` return t1
- `appT` return t2 `appT`
- (foldBal prod (map (repField' (dt, vs) n) fs)) where
- prod :: Q Type -> Q Type -> Q Type
- prod a b = conT ''(:*:) `appT` a `appT` b
-repCon d (InfixC t1 n t2) eqs = repCon d (NormalC n [t1,t2]) eqs
-
---dataDeclToType :: (Name, [Name]) -> Type
---dataDeclToType (dt, vs) = foldl (\a b -> AppT a (VarT b)) (ConT dt) vs
-
-repField :: (Name, [Name]) -> Type -> Q Type
---repField d t | t == dataDeclToType d = conT ''I
-repField d t = conT ''Rec `appT` return t
-
-repField' :: (Name, [Name]) -> Name -> (Name, Strict, Type) -> Q Type
---repField' d ns (_, _, t) | t == dataDeclToType d = conT ''I
-repField' (dt, vs) ns (f, _, t) = conT ''Rec `appT` return t
--- Note: we should generate Var too, at some point
-
-
-mkFrom :: Name -> Int -> Int -> Name -> Q [Q Clause]
-mkFrom ns m i n =
- do
- -- runIO $ putStrLn $ "processing " ++ show n
- let wrapE e = e -- lrE m i e
- i <- reify n
- let b = case i of
- TyConI (DataD _ dt vs cs _) ->
- zipWith (fromCon wrapE ns (dt, map tyVarBndrToName vs)
- (length cs)) [1..] cs
- TyConI (NewtypeD _ dt vs c _) ->
- [fromCon wrapE ns (dt, map tyVarBndrToName vs) 1 0 c]
- TyConI (TySynD t _ _) -> error "type synonym?"
- -- [clause [varP (field 0)] (normalB (wrapE $ conE 'K1 `appE` varE (field 0))) []]
- _ -> error "unknown construct"
- return b
-
-mkTo :: Name -> Int -> Int -> Name -> Q [Q Clause]
-mkTo ns m i n =
- do
- -- runIO $ putStrLn $ "processing " ++ show n
- let wrapP p = p -- lrP m i p
- i <- reify n
- let b = case i of
- TyConI (DataD _ dt vs cs _) ->
- zipWith (toCon wrapP ns (dt, map tyVarBndrToName vs)
- (length cs)) [1..] cs
- TyConI (NewtypeD _ dt vs c _) ->
- [toCon wrapP ns (dt, map tyVarBndrToName vs) 1 0 c]
- TyConI (TySynD t _ _) -> error "type synonym?"
- -- [clause [wrapP $ conP 'K1 [varP (field 0)]] (normalB $ varE (field 0)) []]
- _ -> error "unknown construct"
- return b
-
-fromCon :: (Q Exp -> Q Exp) -> Name -> (Name, [Name]) -> Int -> Int -> Con -> Q Clause
--- Contexts are ignored
-fromCon wrap ns d m i (ForallC _ _ c) = fromCon wrap ns d m i c
-fromCon wrap ns (dt, vs) m i (NormalC cn []) =
- clause
- [conP cn []]
- (normalB $ wrap $ lrE m i $ appE (conE 'C) $ conE 'U) []
-fromCon wrap ns (dt, vs) m i (NormalC cn fs) =
- -- runIO (putStrLn ("constructor " ++ show ix)) >>
- clause
- [conP cn (map (varP . field) [0..length fs - 1])]
- (normalB $ wrap $ lrE m i $ conE 'C `appE`
- foldBal prod (zipWith (fromField (dt, vs)) [0..] (map snd fs))) []
- where prod x y = conE '(:*:) `appE` x `appE` y
-fromCon wrap ns (dt, vs) m i r@(RecC cn []) =
- clause
- [conP cn []]
- (normalB $ wrap $ lrE m i $ conE 'C `appE` (conE 'U)) []
-fromCon wrap ns (dt, vs) m i r@(RecC cn fs) =
- clause
- [conP cn (map (varP . field) [0..length fs - 1])]
- (normalB $ wrap $ lrE m i $ conE 'C `appE`
- foldBal prod (zipWith (fromField (dt, vs)) [0..] (map trd fs))) []
- where prod x y = conE '(:*:) `appE` x `appE` y
-fromCon wrap ns (dt, vs) m i (InfixC t1 cn t2) =
- fromCon wrap ns (dt, vs) m i (NormalC cn [t1,t2])
-
-fromField :: (Name, [Name]) -> Int -> Type -> Q Exp
---fromField (dt, vs) nr t | t == dataDeclToType (dt, vs) = conE 'I `appE` varE (field nr)
-fromField (dt, vs) nr t = conE 'Rec `appE` varE (field nr)
-
-toCon :: (Q Pat -> Q Pat) -> Name -> (Name, [Name]) -> Int -> Int -> Con -> Q Clause
--- Contexts are ignored
-toCon wrap ns d m i (ForallC _ _ c) = toCon wrap ns d m i c
-toCon wrap ns (dt, vs) m i (NormalC cn []) =
- clause
- [wrap $ lrP m i $ conP 'C [conP 'U []]]
- (normalB $ conE cn) []
-toCon wrap ns (dt, vs) m i (NormalC cn fs) =
- -- runIO (putStrLn ("constructor " ++ show ix)) >>
- clause
- [wrap $ lrP m i $ conP 'C
- [foldBal prod (zipWith (toField (dt, vs)) [0..] (map snd fs))]]
- (normalB $ foldl appE (conE cn) (map (varE . field) [0..length fs - 1])) []
- where prod x y = conP '(:*:) [x,y]
-toCon wrap ns (dt, vs) m i r@(RecC cn []) =
- clause
- [wrap $ lrP m i $ conP 'U []]
- (normalB $ conE cn) []
-toCon wrap ns (dt, vs) m i r@(RecC cn fs) =
- clause
- [wrap $ lrP m i $ conP 'C
- [foldBal prod (zipWith (toField (dt, vs)) [0..] (map trd fs))]]
- (normalB $ foldl appE (conE cn) (map (varE . field) [0..length fs - 1])) []
- where prod x y = conP '(:*:) [x,y]
-toCon wrap ns (dt, vs) m i (InfixC t1 cn t2) =
- toCon wrap ns (dt, vs) m i (NormalC cn [t1,t2])
-
-toField :: (Name, [Name]) -> Int -> Type -> Q Pat
---toField (dt, vs) nr t | t == dataDeclToType (dt, vs) = conP 'I [varP (field nr)]
-toField (dt, vs) nr t = conP 'Rec [varP (field nr)]
-
-
-field :: Int -> Name
-field n = mkName $ "f" ++ show n
-
-lrP :: Int -> Int -> (Q Pat -> Q Pat)
-{-
-lrP 1 0 p = p
-lrP m 0 p = conP 'L [p]
-lrP m i p = conP 'R [lrP (m-1) (i-1) p]
--}
-lrP m i p | m == 0 = error "1"
- | m == 1 = p
- | i <= div m 2 = conP 'L [lrP (div m 2) i p]
- | i > div m 2 = conP 'R [lrP (m - div m 2) (i - div m 2) p]
-
-lrE :: Int -> Int -> (Q Exp -> Q Exp)
-{-
-lrE 1 0 e = e
-lrE m 0 e = conE 'L `appE` e
-lrE m i e = conE 'R `appE` lrE (m-1) (i-1) e
--}
-lrE m i e | m == 0 = error "2"
- | m == 1 = e
- | i <= div m 2 = conE 'L `appE` lrE (div m 2) i e
- | i > div m 2 = conE 'R `appE` lrE (m - div m 2) (i - div m 2) e
-
-trd (_,_,c) = c
-
--- | Variant of foldr1 which returns a special element for empty lists
-foldr1' f x [] = x
-foldr1' _ _ [x] = x
-foldr1' f x (h:t) = f h (foldr1' f x t)
-
--- | Variant of foldr1 for producing balanced lists
-foldBal :: (a -> a -> a) -> [a] -> a
-foldBal op = foldBal' op (error "foldBal: empty list")
-
-foldBal' :: (a -> a -> a) -> a -> [a] -> a
-foldBal' _ x [] = x
-foldBal' _ _ [y] = y
-foldBal' op x l = let (a,b) = splitAt (length l `div` 2) l
- in foldBal' op x a `op` foldBal' op x b
+{-# LANGUAGE TemplateHaskell, CPP #-}
+{-# OPTIONS_GHC -w #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module : Generics.Instant.TH
+-- Copyright : (c) 2011 Universiteit Utrecht
+-- License : BSD3
+--
+-- Maintainer : generics@haskell.org
+-- Stability : experimental
+-- Portability : non-portable
+--
+-- This module contains Template Haskell code that can be used to
+-- automatically generate the boilerplate code for the generic deriving
+-- library.
+-----------------------------------------------------------------------------
+
+-- Adapted from Generics.Deriving.TH
+module Generics.Instant.TH (
+ -- * Main generator
+ deriveAll, deriveAllL
+
+ -- * Individual generators
+ , deriveConstructors
+ , deriveRepresentable
+ , deriveRep
+
+ -- * Utilities
+ , simplInstance, gadtInstance
+ , genRepName, typeVariables, tyVarBndrToName
+ ) where
+
+import Generics.Instant.Base
+import Generics.SYB (everywhere, mkT, everything, mkQ, gshow)
+
+import Language.Haskell.TH hiding (Fixity())
+import Language.Haskell.TH.Syntax (Lift(..), showName)
+
+import Data.List (intercalate, nub, elemIndex)
+import qualified Data.Map as M
+import Control.Monad
+import Control.Arrow ((&&&))
+
+-- Used by gadtInstance
+data TypeArgsEqs = TypeArgsEqs { args :: [Type] -- ^ Constructor args
+ , vars :: [Name] -- ^ Variables
+ , teqs :: [(Type,Type)] -- ^ Type equalities
+ } deriving Show
+
+-- | Given the names of a generic class, a type to instantiate, a function in
+-- the class and the default implementation, generates the code for a basic
+-- generic instance.
+simplInstance :: Name -> Name -> Name -> Name -> Q [Dec]
+simplInstance cl ty fn df = do
+ i <- reify ty
+ let typ = return (foldl (\a -> AppT a . VarT . tyVarBndrToName)
+ (ConT ty) (typeVariables i))
+ fmap (: []) $ instanceD (cxt []) (conT cl `appT` typ)
+ [funD fn [clause [] (normalB (varE df)) []]]
+
+-- | Given the names of a generic class, a GADT type to instantiate, a function
+-- in the class and the default implementation, generates the code for a basic
+-- generic instance. This is tricky in general because we have to analyze the
+-- return types of each of the GADT constructors and give instances accordingly.
+gadtInstance :: Name -> Name -> Name -> Name -> Q [Dec]
+gadtInstance cl ty fn df = do
+ i <- reify ty
+ let typ = (foldl (\a -> AppT a . VarT . tyVarBndrToName)
+ (ConT ty) (typeVariables i))
+
+ dt :: ([TyVarBndr],[Con])
+ dt = case i of
+ TyConI (DataD _ _ vs cs _) -> (vs, cs)
+ _ -> error ("gadtInstance: " ++ show ty ++ "is not a valid type")
+
+ -- List of index variable names
+ idxs :: [Name]
+ idxs = extractIndices (fst dt) (snd dt)
+
+ -- Get all the arguments, variables, and type equalities introduced by the
+ -- constructors
+ eqs :: [Name] -> [Con] -> [TypeArgsEqs]
+ eqs nms cs = map f cs where
+ f :: Con -> TypeArgsEqs
+ f (NormalC _ tys) = TypeArgsEqs (map snd tys) [] []
+ f (RecC _ tys) = TypeArgsEqs (map (\(_,_,t) -> t) tys) [] []
+ f (InfixC t1 _ t2) = TypeArgsEqs [snd t1, snd t2] [] []
+ f (ForallC vs cxt c) = case f c of
+ TypeArgsEqs ts vs' eqs' ->
+ TypeArgsEqs ts (tyVarBndrsToNames vs ++ vs')
+ ((concatMap g cxt) ++ eqs')
+ g :: Pred -> [(Type,Type)]
+ g (EqualP (VarT t1) t2) | t1 `elem` nms = [(VarT t1,t2)]
+ | otherwise = []
+ g _ = []
+
+ subst :: [(Type,Type)] -> Type -> Type
+ subst s = everywhere (mkT f) where
+ f (VarT a) = case lookup (VarT a) s of
+ Nothing -> VarT a
+ Just t -> t
+ f x = x
+
+ mkInst :: TypeArgsEqs -> Dec
+ mkInst t = InstanceD (map mkCxt (args t))
+ (ConT cl `AppT` subst (teqs t) typ) instBody
+
+ mkCxt :: Type -> Pred
+ mkCxt = ClassP cl . (:[])
+
+ -- The instance body is empty for regular cases
+ instBody :: [Dec]
+ instBody = [FunD fn [Clause [] (NormalB (VarE df)) []]]
+
+ update :: TypeArgsEqs -> [TypeArgsEqs] -> [TypeArgsEqs]
+ -- update True t1 [] = [t1]
+ update _ [] = []
+ update t1 (t2:ts) | teqs t1 == teqs t2 =
+ t2 {args = nub (args t1 ++ args t2)} : ts
+ | otherwise = t2 : update t1 ts
+
+ -- Types without any type equalities (not real GADTs) need to be handled
+ -- differently. Others are dealt with using filterMerge.
+ handleADTs :: ([TypeArgsEqs] -> [TypeArgsEqs])
+ -> [TypeArgsEqs] -> [TypeArgsEqs]
+ handleADTs f ts | and (map (null . teqs) ts)
+ = [TypeArgsEqs (concatMap args ts) [] []]
+ | otherwise = f ts
+
+ -- We need to
+ -- 1) ignore constructors that don't introduce any type equalities
+ -- 2) merge constructors with the same return type
+ -- This code is terribly inefficient and could easily be improved, btw.
+ filterMerge :: [TypeArgsEqs] -> [TypeArgsEqs]
+ filterMerge (t0@(TypeArgsEqs ts vs eqs):t)
+ | eqs == [] = update t0 (filterMerge t)
+ | otherwise = case filterMerge t of
+ l -> if or (concat
+ [ [ typeMatch vs (vars t2) eq1 eq2
+ | eq1 <- eqs, eq2 <- teqs t2 ] | t2 <- l ])
+ then update t0 l
+ else t0 : l
+ filterMerge [] = []
+
+ -- For (2) above, we need to consider type equality modulo
+ -- quantified-variable names
+ typeMatch :: [Name] -> [Name] -> (Type,Type) -> (Type,Type) -> Bool
+ typeMatch vs1 vs2 eq1 eq2 | length vs1 /= length vs2 = False
+ | otherwise
+ = eq1 == everywhere (mkT f) eq2
+ where f (VarT n) = case n `elemIndex` vs2 of
+ -- is not a quantified variable
+ Nothing -> VarT n
+ -- it is, replace it with the equivalent var
+ Just i -> VarT (vs1 !! i)
+ f x = x
+
+ allTypeArgsEqs = eqs idxs (snd dt)
+
+ normInsts = map mkInst (handleADTs filterMerge allTypeArgsEqs)
+
+ return $ normInsts
+
+
+-- | Given the type and the name (as string) for the type to derive,
+-- generate the 'Constructor' instances and the 'Representable' instance.
+deriveAll :: Name -> Q [Dec]
+deriveAll n =
+ do a <- deriveConstructors n
+ b <- deriveRepresentable n
+ return (a ++ b)
+
+-- | Same as 'deriveAll', but taking a list as input.
+deriveAllL :: [Name] -> Q [Dec]
+deriveAllL = fmap concat . mapM deriveAll
+
+-- | Given a datatype name, derive datatypes and
+-- instances of class 'Constructor'.
+deriveConstructors :: Name -> Q [Dec]
+deriveConstructors = constrInstance
+
+-- | Given the type and the name (as string) for the Representable type
+-- synonym to derive, generate the 'Representable' instance.
+deriveRepresentable :: Name -> Q [Dec]
+deriveRepresentable n = do
+ rep <- deriveRep n
+ inst <- deriveInst n
+ return $ rep ++ inst
+
+-- | Derive only the 'Rep' type synonym. Not needed if 'deriveRepresentable'
+-- is used.
+deriveRep :: Name -> Q [Dec]
+deriveRep n = do
+ i <- reify n
+
+ let d = case i of
+ TyConI dec -> dec
+ _ -> error "unknown construct"
+
+ exTyFamsInsts <- genExTyFamInsts d
+ fmap (: exTyFamsInsts) $
+ tySynD (genRepName n) (typeVariables i) (repType d (typeVariables i))
+
+deriveInst :: Name -> Q [Dec]
+deriveInst t = do
+ i <- reify t
+ let typ q = return $ foldl (\a -> AppT a . VarT . tyVarBndrToName) (ConT q)
+ (typeVariables i)
+ inlPrg = pragInlD t (inlineSpecPhase True False True 1)
+ fcs <- mkFrom t 1 0 t
+ tcs <- mkTo t 1 0 t
+ liftM (:[]) $
+ instanceD (cxt [])
+ (conT ''Representable `appT` typ t)
+ [ tySynInstD ''Rep [typ t] (typ (genRepName t))
+ , {- inlPrg, -} funD 'from fcs, funD 'to tcs]
+
+constrInstance :: Name -> Q [Dec]
+constrInstance n = do
+ i <- reify n
+ case i of
+ TyConI (DataD _ n _ cs _) -> mkInstance n cs
+ TyConI (NewtypeD _ n _ c _) -> mkInstance n [c]
+ _ -> return []
+ where
+ mkInstance n cs = do
+ ds <- mapM (mkConstrData n) cs
+ is <- mapM (mkConstrInstance n) cs
+ return $ ds ++ is
+
+typeVariables :: Info -> [TyVarBndr]
+typeVariables (TyConI (DataD _ _ tv _ _)) = tv
+typeVariables (TyConI (NewtypeD _ _ tv _ _)) = tv
+typeVariables _ = []
+
+tyVarBndrsToNames :: [TyVarBndr] -> [Name]
+tyVarBndrsToNames = map tyVarBndrToName
+
+tyVarBndrToName :: TyVarBndr -> Name
+tyVarBndrToName (PlainTV name) = name
+tyVarBndrToName (KindedTV name _) = name
+
+stripRecordNames :: Con -> Con
+stripRecordNames (RecC n f) =
+ NormalC n (map (\(_, s, t) -> (s, t)) f)
+stripRecordNames c = c
+
+genName :: [Name] -> Name
+genName = mkName . (++"_") . intercalate "_" . map nameBase
+
+genRepName :: Name -> Name
+genRepName = mkName . (++"_") . ("Rep" ++) . nameBase
+
+mkConstrData :: Name -> Con -> Q Dec
+mkConstrData dt (NormalC n _) =
+ dataD (cxt []) (genName [dt, n]) [] [] []
+mkConstrData dt r@(RecC _ _) =
+ mkConstrData dt (stripRecordNames r)
+mkConstrData dt (InfixC t1 n t2) =
+ mkConstrData dt (NormalC n [t1,t2])
+-- Contexts are ignored
+mkConstrData dt (ForallC _ _ c) = mkConstrData dt c
+
+instance Lift Fixity where
+ lift Prefix = conE 'Prefix
+ lift (Infix a n) = conE 'Infix `appE` [| a |] `appE` [| n |]
+
+instance Lift Associativity where
+ lift LeftAssociative = conE 'LeftAssociative
+ lift RightAssociative = conE 'RightAssociative
+ lift NotAssociative = conE 'NotAssociative
+
+mkConstrInstance :: Name -> Con -> Q Dec
+-- Contexts are ignored
+mkConstrInstance dt (ForallC _ _ c) = mkConstrInstance dt c
+mkConstrInstance dt (NormalC n _) = mkConstrInstanceWith dt n []
+mkConstrInstance dt (RecC n _) = mkConstrInstanceWith dt n
+ [ funD 'conIsRecord [clause [wildP] (normalB (conE 'True)) []]]
+mkConstrInstance dt (InfixC t1 n t2) =
+ do
+ i <- reify n
+ let fi = case i of
+ DataConI _ _ _ f -> convertFixity f
+ _ -> Prefix
+ instanceD (cxt []) (appT (conT ''Constructor) (conT $ genName [dt, n]))
+ [funD 'conName [clause [wildP] (normalB (stringE (nameBase n))) []],
+ funD 'conFixity [clause [wildP] (normalB [| fi |]) []]]
+ where
+ convertFixity (Fixity n d) = Infix (convertDirection d) n
+ convertDirection InfixL = LeftAssociative
+ convertDirection InfixR = RightAssociative
+ convertDirection InfixN = NotAssociative
+
+mkConstrInstanceWith :: Name -> Name -> [Q Dec] -> Q Dec
+mkConstrInstanceWith dt n extra =
+ instanceD (cxt []) (appT (conT ''Constructor) (conT $ genName [dt, n]))
+ (funD 'conName [clause [wildP] (normalB (stringE (nameBase n))) []] : extra)
+
+repType :: Dec -> [TyVarBndr] -> Q Type
+repType i repVs =
+ do let sum :: Q Type -> Q Type -> Q Type
+ sum a b = conT ''(:+:) `appT` a `appT` b
+ case i of
+ (DataD _ dt vs cs _) ->
+ (foldBal' sum (error "Empty datatypes are not supported.")
+ (map (repConGADT (dt, tyVarBndrsToNames vs) repVs
+ (extractIndices vs cs)) cs))
+ (NewtypeD _ dt vs c _) -> repConGADT (dt, tyVarBndrsToNames vs) repVs
+ (extractIndices vs [c]) c
+ (TySynD t _ _) -> error "type synonym?"
+ _ -> error "unknown construct"
+
+
+-- Given a datatype declaration, returns a list of its type variables which are
+-- used as index and not as data
+extractIndices :: [TyVarBndr] -> [Con] -> [Name]
+extractIndices vs = nub . everything (++) ([] `mkQ` isIndexEq) where
+ isIndexEq :: Pred -> [Name]
+ isIndexEq (EqualP (VarT a) (VarT b)) = if a `elem` tyVarBndrsToNames vs
+ then (a:)
+ (if b `elem` tyVarBndrsToNames vs
+ then [b] else []) else []
+ isIndexEq (EqualP (VarT a) _) = if a `elem` tyVarBndrsToNames vs
+ then [a] else []
+ isIndexEq (EqualP _ (VarT a)) = if a `elem` tyVarBndrsToNames vs
+ then [a] else []
+ isIndexEq _ = []
+
+repConGADT :: (Name, [Name]) -> [TyVarBndr] -> [Name] -> Con -> Q Type
+-- We only accept one index variable, for now
+repConGADT _ _ vs@(_:_:_) (ForallC _ _ _) =
+ error ("Datatype indexed over >1 variable: " ++ show vs)
+-- Handle type equality constraints
+repConGADT d@(dt, dtVs) repVs [indexVar] (ForallC vs ctx c) =
+ do
+ let
+ genTypeEqs ((EqualP t1 t2):r) | otherwise = case genTypeEqs r of
+ (t1s,t2s) -> ( ConT ''(:*:) `AppT` (substTyVar vsN t1) `AppT` t1s
+ , ConT ''(:*:) `AppT` (substTyVar vsN t2) `AppT` t2s)
+ genTypeEqs (_:r) = genTypeEqs r -- other constraints are ignored
+ genTypeEqs [] = baseEqs
+
+ substTyVar :: [Name] -> Type -> Type
+ substTyVar ns = everywhere (mkT f) where
+ f (VarT v) = case elemIndex v ns of
+ Nothing -> VarT v
+ Just i -> ConT ''X
+ `AppT` ConT (genName [dt,getConName c])
+ `AppT` int2TLNat i
+ `AppT` VarT indexVar
+ f x = x
+
+ vsN :: [Name]
+ vsN = tyVarBndrsToNames vs
+
+ -- Go on with generating the representation type, taking the equalities
+ repCon (dt, dtVs) (everywhere (mkT (substTyVar vsN)) c) (genTypeEqs ctx)
+-- No constraints, go on as usual
+repConGADT d _repVs _ c = repCon d c baseEqs
+
+-- Extract the constructor name
+getConName :: Con -> Name
+getConName (NormalC n _) = n
+getConName (RecC n _) = n
+getConName (InfixC _ n _) = n
+getConName (ForallC _ _ c) = getConName c
+
+-- Generate a type-level natural from an Int
+int2TLNat :: Int -> Type
+int2TLNat 0 = ConT ''Ze
+int2TLNat n = ConT ''Su `AppT` int2TLNat (n-1)
+
+-- Generate the mobility rules for the existential type families
+genExTyFamInsts :: Dec -> Q [Dec]
+genExTyFamInsts (DataD _ n _ cs _) = fmap concat $
+ mapM (genExTyFamInsts' n) cs
+genExTyFamInsts (NewtypeD _ n _ c _) = genExTyFamInsts' n c
+
+genExTyFamInsts' :: Name -> Con -> Q [Dec]
+genExTyFamInsts' dt (ForallC vs cxt c) =
+ do let mR = mobilityRules (tyVarBndrsToNames vs) cxt
+ conName = ConT (genName [dt,getConName c])
+ tySynInst ty n x = TySynInstD ''X [conName, int2TLNat n, ty] x
+ return [ tySynInst ty n (VarT nm) | (n,(nm, ty)) <- zip [0..] mR ]
+genExTyFamInsts' _ _ = return []
+
+-- Compute the shape of the mobility rules
+mobilityRules :: [Name] -> Cxt -> [(Name,Type)]
+mobilityRules [] _ = []
+mobilityRules vs cxt = concat [ mobilityRules' v p | v <- vs, p <- cxt ] where
+ mobilityRules' :: Name -> Pred -> [(Name,Type)]
+ mobilityRules' _ (EqualP (VarT _) (VarT _)) = []
+ mobilityRules' v (EqualP (VarT a) x) | v `inComplex` x = [(v,x)]
+ | otherwise = []
+ mobilityRules' v (EqualP x (VarT a)) = mobilityRules' v (EqualP (VarT a) x)
+ mobilityRules' v _ = []
+
+ inComplex :: Name -> Type -> Bool
+ inComplex v (VarT _) = False
+ inComplex v x = everything (||) (False `mkQ` q) x where
+ q (VarT x) | x == v = True
+ q (VarT x) | otherwise = False
+ q _ = False
+
+flattenEqs :: (Type, Type) -> Q Type
+flattenEqs (t1, t2) = return t1 `appT` return t2
+
+-- () ~ ()
+baseEqs :: (Type, Type)
+baseEqs = (TupleT 0, TupleT 0)
+
+repCon :: (Name, [Name]) -> Con -> (Type,Type) -> Q Type
+repCon _ (ForallC _ _ _) _ = error "impossible"
+repCon (dt, vs) (NormalC n []) (t1,t2) =
+ conT ''CEq `appT` (conT $ genName [dt, n]) `appT` return t1
+ `appT` return t2 `appT` conT ''U
+repCon (dt, vs) (NormalC n fs) (t1,t2) =
+ conT ''CEq `appT` (conT $ genName [dt, n]) `appT` return t1
+ `appT` return t2 `appT`
+ (foldBal prod (map (repField (dt, vs) . snd) fs)) where
+ prod :: Q Type -> Q Type -> Q Type
+ prod a b = conT ''(:*:) `appT` a `appT` b
+repCon (dt, vs) r@(RecC n []) (t1,t2) =
+ conT ''CEq `appT` (conT $ genName [dt, n]) `appT` return t1
+ `appT` return t2 `appT` conT ''U
+repCon (dt, vs) r@(RecC n fs) (t1,t2) =
+ conT ''CEq `appT` (conT $ genName [dt, n]) `appT` return t1
+ `appT` return t2 `appT`
+ (foldBal prod (map (repField' (dt, vs) n) fs)) where
+ prod :: Q Type -> Q Type -> Q Type
+ prod a b = conT ''(:*:) `appT` a `appT` b
+repCon d (InfixC t1 n t2) eqs = repCon d (NormalC n [t1,t2]) eqs
+
+--dataDeclToType :: (Name, [Name]) -> Type
+--dataDeclToType (dt, vs) = foldl (\a b -> AppT a (VarT b)) (ConT dt) vs
+
+repField :: (Name, [Name]) -> Type -> Q Type
+--repField d t | t == dataDeclToType d = conT ''I
+repField d t = conT ''Rec `appT` return t
+
+repField' :: (Name, [Name]) -> Name -> (Name, Strict, Type) -> Q Type
+--repField' d ns (_, _, t) | t == dataDeclToType d = conT ''I
+repField' (dt, vs) ns (f, _, t) = conT ''Rec `appT` return t
+-- Note: we should generate Var too, at some point
+
+
+mkFrom :: Name -> Int -> Int -> Name -> Q [Q Clause]
+mkFrom ns m i n =
+ do
+ -- runIO $ putStrLn $ "processing " ++ show n
+ let wrapE e = e -- lrE m i e
+ i <- reify n
+ let b = case i of
+ TyConI (DataD _ dt vs cs _) ->
+ zipWith (fromCon wrapE ns (dt, map tyVarBndrToName vs)
+ (length cs)) [1..] cs
+ TyConI (NewtypeD _ dt vs c _) ->
+ [fromCon wrapE ns (dt, map tyVarBndrToName vs) 1 0 c]
+ TyConI (TySynD t _ _) -> error "type synonym?"
+ -- [clause [varP (field 0)] (normalB (wrapE $ conE 'K1 `appE` varE (field 0))) []]
+ _ -> error "unknown construct"
+ return b
+
+mkTo :: Name -> Int -> Int -> Name -> Q [Q Clause]
+mkTo ns m i n =
+ do
+ -- runIO $ putStrLn $ "processing " ++ show n
+ let wrapP p = p -- lrP m i p
+ i <- reify n
+ let b = case i of
+ TyConI (DataD _ dt vs cs _) ->
+ zipWith (toCon wrapP ns (dt, map tyVarBndrToName vs)
+ (length cs)) [1..] cs
+ TyConI (NewtypeD _ dt vs c _) ->
+ [toCon wrapP ns (dt, map tyVarBndrToName vs) 1 0 c]
+ TyConI (TySynD t _ _) -> error "type synonym?"
+ -- [clause [wrapP $ conP 'K1 [varP (field 0)]] (normalB $ varE (field 0)) []]
+ _ -> error "unknown construct"
+ return b
+
+fromCon :: (Q Exp -> Q Exp) -> Name -> (Name, [Name]) -> Int -> Int -> Con -> Q Clause
+-- Contexts are ignored
+fromCon wrap ns d m i (ForallC _ _ c) = fromCon wrap ns d m i c
+fromCon wrap ns (dt, vs) m i (NormalC cn []) =
+ clause
+ [conP cn []]
+ (normalB $ wrap $ lrE m i $ appE (conE 'C) $ conE 'U) []
+fromCon wrap ns (dt, vs) m i (NormalC cn fs) =
+ -- runIO (putStrLn ("constructor " ++ show ix)) >>
+ clause
+ [conP cn (map (varP . field) [0..length fs - 1])]
+ (normalB $ wrap $ lrE m i $ conE 'C `appE`
+ foldBal prod (zipWith (fromField (dt, vs)) [0..] (map snd fs))) []
+ where prod x y = conE '(:*:) `appE` x `appE` y
+fromCon wrap ns (dt, vs) m i r@(RecC cn []) =
+ clause
+ [conP cn []]
+ (normalB $ wrap $ lrE m i $ conE 'C `appE` (conE 'U)) []
+fromCon wrap ns (dt, vs) m i r@(RecC cn fs) =
+ clause
+ [conP cn (map (varP . field) [0..length fs - 1])]
+ (normalB $ wrap $ lrE m i $ conE 'C `appE`
+ foldBal prod (zipWith (fromField (dt, vs)) [0..] (map trd fs))) []
+ where prod x y = conE '(:*:) `appE` x `appE` y
+fromCon wrap ns (dt, vs) m i (InfixC t1 cn t2) =
+ fromCon wrap ns (dt, vs) m i (NormalC cn [t1,t2])
+
+fromField :: (Name, [Name]) -> Int -> Type -> Q Exp
+--fromField (dt, vs) nr t | t == dataDeclToType (dt, vs) = conE 'I `appE` varE (field nr)
+fromField (dt, vs) nr t = conE 'Rec `appE` varE (field nr)
+
+toCon :: (Q Pat -> Q Pat) -> Name -> (Name, [Name]) -> Int -> Int -> Con -> Q Clause
+-- Contexts are ignored
+toCon wrap ns d m i (ForallC _ _ c) = toCon wrap ns d m i c
+toCon wrap ns (dt, vs) m i (NormalC cn []) =
+ clause
+ [wrap $ lrP m i $ conP 'C [conP 'U []]]
+ (normalB $ conE cn) []
+toCon wrap ns (dt, vs) m i (NormalC cn fs) =
+ -- runIO (putStrLn ("constructor " ++ show ix)) >>
+ clause
+ [wrap $ lrP m i $ conP 'C
+ [foldBal prod (zipWith (toField (dt, vs)) [0..] (map snd fs))]]
+ (normalB $ foldl appE (conE cn) (map (varE . field) [0..length fs - 1])) []
+ where prod x y = conP '(:*:) [x,y]
+toCon wrap ns (dt, vs) m i r@(RecC cn []) =
+ clause
+ [wrap $ lrP m i $ conP 'U []]
+ (normalB $ conE cn) []
+toCon wrap ns (dt, vs) m i r@(RecC cn fs) =
+ clause
+ [wrap $ lrP m i $ conP 'C
+ [foldBal prod (zipWith (toField (dt, vs)) [0..] (map trd fs))]]
+ (normalB $ foldl appE (conE cn) (map (varE . field) [0..length fs - 1])) []
+ where prod x y = conP '(:*:) [x,y]
+toCon wrap ns (dt, vs) m i (InfixC t1 cn t2) =
+ toCon wrap ns (dt, vs) m i (NormalC cn [t1,t2])
+
+toField :: (Name, [Name]) -> Int -> Type -> Q Pat
+--toField (dt, vs) nr t | t == dataDeclToType (dt, vs) = conP 'I [varP (field nr)]
+toField (dt, vs) nr t = conP 'Rec [varP (field nr)]
+
+
+field :: Int -> Name
+field n = mkName $ "f" ++ show n
+
+lrP :: Int -> Int -> (Q Pat -> Q Pat)
+{-
+lrP 1 0 p = p
+lrP m 0 p = conP 'L [p]
+lrP m i p = conP 'R [lrP (m-1) (i-1) p]
+-}
+lrP m i p | m == 0 = error "1"
+ | m == 1 = p
+ | i <= div m 2 = conP 'L [lrP (div m 2) i p]
+ | i > div m 2 = conP 'R [lrP (m - div m 2) (i - div m 2) p]
+
+lrE :: Int -> Int -> (Q Exp -> Q Exp)
+{-
+lrE 1 0 e = e
+lrE m 0 e = conE 'L `appE` e
+lrE m i e = conE 'R `appE` lrE (m-1) (i-1) e
+-}
+lrE m i e | m == 0 = error "2"
+ | m == 1 = e
+ | i <= div m 2 = conE 'L `appE` lrE (div m 2) i e
+ | i > div m 2 = conE 'R `appE` lrE (m - div m 2) (i - div m 2) e
+
+trd (_,_,c) = c
+
+-- | Variant of foldr1 which returns a special element for empty lists
+foldr1' f x [] = x
+foldr1' _ _ [x] = x
+foldr1' f x (h:t) = f h (foldr1' f x t)
+
+-- | Variant of foldr1 for producing balanced lists
+foldBal :: (a -> a -> a) -> [a] -> a
+foldBal op = foldBal' op (error "foldBal: empty list")
+
+foldBal' :: (a -> a -> a) -> a -> [a] -> a
+foldBal' _ x [] = x
+foldBal' _ _ [y] = y
+foldBal' op x l = let (a,b) = splitAt (length l `div` 2) l
+ in foldBal' op x a `op` foldBal' op x b