generic-deriving (empty) → 0.3

raw patch · 13 files changed

+2040/−0 lines, 13 filesdep +basedep +template-haskellbuild-type:Customsetup-changed

Dependencies added: base, template-haskell

Files

LICENSE +28/−0
Setup.hs +6/−0
examples/Examples.hs +533/−0
generic-deriving.cabal +42/−0
src/Generics/Deriving.hs +20/−0
src/Generics/Deriving/Base.hs +318/−0
src/Generics/Deriving/Enum.hs +237/−0
src/Generics/Deriving/Eq.hs +79/−0
src/Generics/Deriving/Functor.hs +76/−0
src/Generics/Deriving/Show.hs +136/−0
src/Generics/Deriving/TH.hs +397/−0
src/Generics/Deriving/Typeable.hs +93/−0
src/Generics/Deriving/Uniplate.hs +75/−0

+ LICENSE view

@@ -0,0 +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.+

+ Setup.hs view

@@ -0,0 +1,6 @@+module Main (main) where++import Distribution.Simple++main :: IO ()+main = defaultMain

+ examples/Examples.hs view

@@ -0,0 +1,533 @@+{-# LANGUAGE EmptyDataDecls #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE KindSignatures #-}
+
+module Main (
+  -- * Run all tests
+  main
+  ) where
+
+import Prelude hiding (Either(..))
+import Generics.Deriving
+import Generics.Deriving.TH
+
+
+--------------------------------------------------------------------------------
+-- Temporary tests for TH generation
+--------------------------------------------------------------------------------
+
+data (:/:) f a = MyType1Nil
+               | MyType1Cons { myType1Rec :: (f :/: a), myType2Rec :: MyType2 }
+               | MyType1Cons2 (f :/: a) Int a (f a)
+
+data MyType2 = MyType2 Float ([] :/: Int)
+
+$(deriveAll ''(:/:))
+$(deriveAll ''MyType2)
+
+--------------------------------------------------------------------------------
+-- Example: Haskell's lists and Maybe
+--------------------------------------------------------------------------------
+
+hList1, hList2 :: [Int]
+hList1 = [1..10]
+hList2 = [2,4..]
+
+maybe1 = Nothing
+maybe2 = Just (Just 'p')
+
+testsStandard = [ gshow hList1
+                , gshow (children maybe2)
+                , gshow (geq hList1 hList1)
+                , gshow (geq maybe1 maybe2)
+                , gshow (take 5 (genum :: [Maybe Int]))
+                , gshow (take 15 (genum :: [[Int]]))
+                , gshow (range ([0], [1::Int]))
+                , gshow (inRange ([0], [3,5::Int]) hList1) ]
+
+--------------------------------------------------------------------------------
+-- Example: trees of integers (kind *)
+--------------------------------------------------------------------------------
+
+data Tree = Empty | Branch Int Tree Tree
+
+#ifdef __UHC__
+
+deriving instance GShow Tree
+deriving instance Uniplate Tree
+deriving instance GEnum Tree
+
+#else
+{-
+data Tree_
+data Empty_
+data Branch_
+
+instance Datatype Tree_ where
+  datatypeName _ = "Tree"
+  moduleName   _ = "Examples"
+
+instance Constructor Empty_  where conName _ = "Empty"
+instance Constructor Branch_ where conName _ = "Branch"
+
+-- Only a Representable0 instance is needed (no Representable1)
+type Rep0Tree = D1 Tree_ (C1 Empty_ U1 :+: 
+                          C1 Branch_ (Rec0 Int :*: (Rec0 Tree :*: Rec0 Tree)))
+instance Representable0 Tree Rep0Tree where  
+  from0 Empty          = M1 (L1 (M1 U1))
+  from0 (Branch i l r) = M1 (R1 (M1 (K1 i :*: (K1 l :*: K1 r))))
+  to0 (M1 (L1 (M1 U1)))                         = Empty
+  to0 (M1 (R1 (M1 (K1 i :*: (K1 l :*: K1 r))))) = Branch i l r
+-}
+
+$(deriveAll ''Tree)
+
+instance GShow Tree where gshowsPrec = gshowsPrecdefault (undefined :: Rep0Tree_ x)
+instance Uniplate Tree where children = childrendefault (undefined :: Rep0Tree_ x)
+instance GEnum Tree where genum = genumDefault (undefined :: Rep0Tree_ x)
+instance Typeable Tree where typeOf = typeOf0default (undefined :: Rep0Tree_ x)
+
+#endif
+
+-- Example usage
+tree = Branch 2 Empty (Branch 1 Empty Empty)
+testsTree = [ gshow tree 
+            , gshow (children tree)
+            , gshow (take 10 (genum :: [Tree])) ]
+
+--------------------------------------------------------------------------------
+-- Example: lists (kind * -> *)
+--------------------------------------------------------------------------------
+
+data List a = Nil | Cons a (List a) 
+
+#ifdef __UHC__
+
+deriving instance (GShow a) => GShow (List a)
+deriving instance GFunctor List
+deriving instance Uniplate (List a)
+
+#else
+
+data List_
+data Nil_
+data Cons_
+
+instance Datatype List_ where
+  datatypeName _ = "List"
+  moduleName   _ = "Examples"
+
+instance Constructor Nil_  where conName _ = "Nil"
+instance Constructor Cons_ where conName _ = "Cons"
+
+type Rep0List_ a = D1 List_ ((:+:) (C1 Nil_ U1) (C1 Cons_ ((:*:) (Par0 a) (Rec0 (List a)))))
+instance Representable0 (List a) (Rep0List_ a) where
+  from0 Nil        = M1 (L1 (M1 U1))
+  from0 (Cons h t) = M1 (R1 (M1 ((:*:) (K1 h) (K1 t))))
+  to0 (M1 (L1 (M1 U1)))                     = Nil
+  to0 (M1 (R1 (M1 (K1 h :*: K1 t)))) = Cons h t
+
+type Rep1List_ = D1 List_ ((:+:) (C1 Nil_ U1) (C1 Cons_ ((:*:) Par1 (Rec1 List))))
+instance Representable1 List Rep1List_ where
+  from1 Nil        = M1 (L1 (M1 U1))
+  from1 (Cons h t) = M1 (R1 (M1 (Par1 h :*: Rec1 t)))
+  to1 (M1 (L1 (M1 U1)))                         = Nil
+  to1 (M1 (R1 (M1 (Par1 h :*: Rec1 t)))) = Cons h t
+
+-- Instance for generic functions (should be automatically generated)
+instance GFunctor List where
+  gmap = t undefined where
+    t :: Rep1List_ a -> (a -> b) -> List a -> List b
+    t = gmapdefault
+{-
+instance (Typeable a) => Typeable1 List where
+  typeOf1 = t undefined where
+    t :: (Typeable a) => Rep1List_ a -> List a -> TypeRep
+    t = typeOf1default
+
+
+instance GFoldable List where
+  gfoldMap = gfoldMapdefault (undefined :: RepList x)
+
+instance GTraversable List where
+  gtraverse = gtraversedefault (undefined :: RepList x)
+-}
+
+instance (GShow a) => GShow (List a) where
+  gshowsPrec = t undefined where
+    t :: (GShow a) => Rep0List_ a x -> Int -> List a -> ShowS
+    t = gshowsPrecdefault
+
+instance (Uniplate a) => Uniplate (List a) where
+  children = t undefined where
+    t :: (Uniplate a) => Rep0List_ a x -> List a -> [List a]
+    t = childrendefault
+
+#endif
+
+-- Example usage
+list = Cons 'p' (Cons 'q' Nil)
+listlist = Cons list (Cons Nil Nil) -- ["pq",""]
+
+testsList = [ gshow (gmap fromEnum list)
+            , gshow (gmap gshow listlist)
+            , gshow list
+            , gshow listlist
+            , gshow (children list)
+            , gshow (children listlist) ]
+
+
+--------------------------------------------------------------------------------
+-- Example: Nested datatype, record selectors
+--------------------------------------------------------------------------------
+
+data Nested a = Leaf | Nested { value :: a, rec :: Nested [a] }
+
+#ifdef __UHC__
+
+deriving instance (GShow a) => GShow (Nested a)
+deriving instance GFunctor Nested
+
+#else
+{-
+data NestedD
+data NestedC
+data Leaf_
+data Value
+data Rec
+
+instance Datatype NestedD where
+  datatypeName _ = "Nested"
+  moduleName   _ = "Examples"
+
+instance Constructor NestedC where
+  conName _     = "Nested"
+  conIsRecord _ = True
+
+instance Constructor Leaf_ where conName _     = "Leaf"
+
+instance Selector Value where selName _ = "value"
+instance Selector Rec   where selName _ = "rec"
+
+-- Representable1 instances
+type Rep0Nested a = D1 NestedD (    C1 Leaf_ U1 
+                                :+: C1 NestedC (    S1 Value (Par0 a)
+                                                :*: S1 Rec (Rec0 (Nested [a]))))
+instance Representable0 (Nested a) (Rep0Nested a) where
+  from0 Leaf = M1 (L1 (M1 U1))
+  from0 (Nested a l) = M1 (R1 (M1 (M1 (K1 a) :*: M1 (K1 l))))
+  to0 (M1 (L1 (M1 U1))) = Leaf
+  to0 (M1 (R1 (M1 (M1 (K1 a) :*: M1 (K1 l))))) = Nested a l
+-}
+
+$(deriveAll ''Nested)
+
+type RepNested = D1 Nested_ (C1 Nested_Leaf_ U1 :+: C1 Nested_Nested_ (Par1 :*: Nested :.: Rec1 []))
+instance Representable1 Nested RepNested where
+  from1 Leaf = M1 (L1 (M1 U1))
+  from1 (Nested a l) = M1 (R1 (M1 (Par1 a :*: Comp1 (gmap Rec1 l))))
+  to1 (M1 (L1 (M1 U1))) = Leaf
+  to1 (M1 (R1 (M1 (Par1 a :*: Comp1 l)))) = Nested a (gmap unRec1 l)
+
+-- Instance for gshow (should be automatically generated)
+instance (GShow a) => GShow (Nested a) where
+  gshowsPrec = t undefined where
+    t :: (GShow a) => Rep0Nested_ a x -> Int -> Nested a -> ShowS
+    t = gshowsPrecdefault
+
+instance GFunctor Nested where
+  gmap = t undefined where
+    t :: RepNested a -> (a -> b) -> Nested a -> Nested b
+    t = gmapdefault
+{-
+instance (GFoldable f) => GFoldable (GRose f) where
+  gfoldMap f (x :: GRose f a) = gfoldMapdefault (undefined :: RepGRose f x) f x
+
+instance (GTraversable f) => GTraversable (GRose f) where
+  gtraverse f (x :: GRose f a) = gtraversedefault (undefined :: RepGRose f x) f x
+-}
+
+#endif
+
+
+-- Example usage
+nested :: Nested Int
+nested = Nested 1 (Nested [2] (Nested [[3],[4,5],[]] Leaf))
+--nested = Nested 1 (Nested (Nested 1 Leaf) Leaf)
+
+
+testsNested = [ gshow nested
+              , gshow (gmap gshow nested) ]
+
+
+--------------------------------------------------------------------------------
+-- Example: Type composition
+--------------------------------------------------------------------------------
+
+data Rose a = Rose [a] [Rose a]
+
+#ifdef __UHC__
+
+deriving instance (GShow a) => GShow (Rose a)
+deriving instance GFunctor Rose
+
+#else
+
+data RoseD
+data RoseC
+
+instance Datatype RoseD where
+  datatypeName _ = "Rose"
+  moduleName   _ = "Examples"
+
+instance Constructor RoseC where conName _ = "Rose"
+
+-- Representable1 instances
+type Rep0Rose a = D1 RoseD (C1 RoseC (Rec0 [a] :*: Rec0 [Rose a]))
+instance Representable0 (Rose a) (Rep0Rose a) where
+  from0 (Rose a x) = M1 (M1 (K1 a :*: K1 x))
+  to0 (M1 (M1 (K1 a :*: K1 x))) = Rose a x
+
+type RepRose = D1 RoseD (C1 RoseC (Rec1 [] :*: [] :.: Rec1 Rose))
+instance Representable1 Rose RepRose where
+  from1 (Rose a x) = M1 (M1 (Rec1 a :*: Comp1 (gmap Rec1 x)))
+  to1 (M1 (M1 (Rec1 a :*: Comp1 x))) = Rose a (gmap unRec1 x)
+
+-- Instance for gshow (should be automatically generated)
+instance (GShow a) => GShow (Rose a) where
+  gshowsPrec = t undefined where
+    t :: (GShow a) => Rep0Rose a x -> Int -> Rose a -> ShowS
+    t = gshowsPrecdefault
+
+instance GFunctor Rose where
+  gmap = t undefined where
+    t :: RepRose a -> (a -> b) -> Rose a -> Rose b
+    t = gmapdefault
+{-
+instance GFoldable Rose where
+  gfoldMap = gfoldMapdefault (undefined :: RepRose x)
+
+instance GTraversable Rose where
+  gtraverse = gtraversedefault (undefined :: RepRose x)
+-}
+
+#endif
+
+-- Example usage
+rose1 :: Rose Int
+rose1 = Rose [1,2] [Rose [3,4] [], Rose [5] []]
+
+testsRose = [ gshow rose1
+            , gshow (gmap gshow rose1) ]
+
+
+--------------------------------------------------------------------------------
+-- Example: Higher-order kinded datatype, type composition
+--------------------------------------------------------------------------------
+
+data GRose f a = GRose (f a) (f (GRose f a))
+
+#ifdef __UHC__
+
+deriving instance (GShow (f a), GShow (f (GRose f a))) =>  GShow (GRose f a)
+deriving instance (GFunctor f) => GFunctor (GRose f)
+
+#else
+{-
+data GRoseD
+data GRoseC
+
+instance Datatype GRoseD where
+  datatypeName _ = "GRose"
+  moduleName   _ = "Examples"
+
+instance Constructor GRoseC where conName _ = "GRose"
+
+type Rep0GRose f a = D1 GRoseD (C1 GRoseC (Rec0 (f a) :*: Rec0 (f (GRose f a))))
+instance Representable0 (GRose f a) (Rep0GRose f a) where
+  from0 (GRose a x) = M1 (M1 (K1 a :*: K1 x))
+  to0 (M1 (M1 (K1 a :*: K1 x))) = GRose a x
+-}
+
+$(deriveAll ''GRose)
+
+type Rep1GRose f = D1 GRose_ (C1 GRose_GRose_ (Rec1 f :*: f :.: (Rec1 (GRose f))))
+instance (GFunctor f) => Representable1 (GRose f) (Rep1GRose f) where
+  from1 (GRose a x) = M1 (M1 (Rec1 a :*: Comp1 (gmap Rec1 x)))
+  to1 (M1 (M1 (Rec1 a :*: Comp1 x))) = GRose a (gmap unRec1 x)
+
+-- Requires UndecidableInstances
+instance (GShow (f a), GShow (f (GRose f a))) => GShow (GRose f a) where
+  gshowsPrec = t undefined where
+    t :: (GShow (f a), GShow (f (GRose f a))) => Rep0GRose_ f a x -> Int -> GRose f a -> ShowS
+    t = gshowsPrecdefault
+
+instance (GFunctor f) => GFunctor (GRose f) where
+  gmap = t undefined where
+    t :: (GFunctor f) => Rep1GRose f a -> (a -> b) -> GRose f a -> GRose f b
+    t = gmapdefault
+{-
+instance (GFoldable f) => GFoldable (GRose f) where
+  gfoldMap f (x :: GRose f a) = gfoldMapdefault (undefined :: RepGRose f x) f x
+
+instance (GTraversable f) => GTraversable (GRose f) where
+  gtraverse f (x :: GRose f a) = gtraversedefault (undefined :: RepGRose f x) f x
+-}
+
+#endif
+
+-- Example usage
+grose1 :: GRose [] Int
+grose1 = GRose [1,2] [GRose [3] [], GRose [] []]
+
+testsGRose = [ gshow grose1
+             , gshow (gmap gshow grose1) ]
+
+--------------------------------------------------------------------------------
+-- Example: NGRose (minimal)
+--------------------------------------------------------------------------------
+
+-- Cannot represent because of nesting on an argument other than the parameter
+{-
+data NGRose f a = NGNode a (f (NGRose (Comp f f) a))
+data Comp f g a = Comp (f (g a))
+
+type Rep0NGRose f a = Par0 a :*: Rec0 (f (NGRose (Comp f f) a))
+instance Representable0 (NGRose f a) (Rep0NGRose f a) where
+  from0 (NGNode a x) = K1 a :*: K1 x
+  to0 (K1 a :*: K1 x) = NGNode a x
+
+type Rep0Comp f g a = Rec0 (f (g a))
+instance Representable0 (Comp f g a) (Rep0Comp f g a) where
+  from0 (Comp x) = K1 x
+  to0 (K1 x) = Comp x
+
+type Rep1Comp f g = f :.: Rec1 g
+instance (GFunctor f) => Representable1 (Comp f g) (Rep1Comp f g) where
+  from1 (Comp x) = Comp1 (gmap Rec1 x)
+  to1 (Comp1 x) = Comp (gmap unRec1 x)
+
+type Rep1NGRose f = Par1 :*: f :.: Rec1 (NGRose (Comp f f))
+instance (GFunctor f) => Representable1 (NGRose f) (Rep1NGRose f) where
+  from1 (NGNode a x) = Par1 a :*: (Comp1 (gmap Rec1 x))
+  to1 (Par1 a :*: Comp1 x) = NGNode a (gmap unRec1 x)
+
+instance (GShow a, GShow (f (NGRose (Comp f f) a))) => GShow (NGRose f a) where
+  gshowsPrec = t undefined where
+    t :: (GShow a, GShow (f (NGRose (Comp f f) a))) => Rep0NGRose f a x -> NGRose f a -> ShowS
+    t = gshowsPrecdefault
+
+instance (GShow a) => GShow (Comp f g a) where
+  gshowsPrec = t undefined where
+    t :: (GShow a) => Rep0Comp f g a x -> Comp f g a -> ShowS
+    t = gshowsPrecdefault
+
+instance (GFunctor f, GFunctor (Comp f f)) => GFunctor (NGRose f) where
+  gmap = t undefined where
+    t :: (GFunctor f, GFunctor (Comp f f)) => Rep1NGRose f a -> (a -> b) -> NGRose f a -> NGRose f b
+    t = gmapdefault
+
+ngrose1 :: NGRose [] Int
+ngrose1 = NGNode 0 [ngrose2, ngrose2]
+
+ngrose2 :: NGRose (Comp [] []) Int
+ngrose2 = NGNode 1 (Comp [])
+
+testsNGRose = [ gshow ngrose1
+              , gshow (gmap gshow ngrose1) ]
+-}
+
+--------------------------------------------------------------------------------
+-- Example: Double type composition (minimal)
+--------------------------------------------------------------------------------
+
+-- Add this to EHC
+unComp (Comp1 x) = x
+
+data Weird a = Weird [[[a]]] deriving Show
+
+type Rep1Weird = [] :.: [] :.: Rec1 []
+instance Representable1 Weird Rep1Weird where
+  from1 (Weird x) = Comp1 (gmap (Comp1 . gmap Rec1) x)
+  to1 (Comp1 x) = Weird (gmap (gmap unRec1 . unComp) x)
+
+
+instance GFunctor Weird where
+  gmap = t undefined where
+    t :: Rep1Weird a -> (a -> b) -> Weird a -> Weird b
+    t = gmapdefault
+
+
+--------------------------------------------------------------------------------
+-- Example: Two parameters, datatype constraint, nested on other parameter
+--------------------------------------------------------------------------------
+
+-- Any constraints on |b| mean we cannot generate the Representable1 instance
+-- Constraints on |a| are just propagated to Representable0 and generic
+-- function instances
+data (Show a) => Either a b = Left (Either [a] b) | Right b
+
+
+-- Representable1 instances
+type Rep0Either a b = Rec0 (Either [a] b) :+: Rec0 b
+instance (Show a) => Representable0 (Either a b) (Rep0Either a b) where
+  from0 (Left a)  = L1 (K1 a)
+  from0 (Right a) = R1 (K1 a)
+  to0 (L1 (K1 a)) = Left a
+  to0 (R1 (K1 a)) = Right a
+
+type RepEither a = Rec1 (Either [a]) :+: Par1
+instance (Show a) => Representable1 (Either a) (RepEither a) where
+  from1 (Left a)  = L1 (Rec1 a)
+  from1 (Right a) = R1 (Par1 a)
+  to1 (L1 (Rec1 a)) = Left a
+  to1 (R1 (Par1 a)) = Right a
+
+
+-- Instance for gshow (should be automatically generated)
+instance (Show a, GShow a, GShow b) => GShow (Either a b) where
+  gshowsPrec = t undefined where
+    t :: (Show a, GShow a, GShow b) => Rep0Either a b x -> Int -> Either a b -> ShowS
+    t = gshowsPrecdefault
+
+instance (Show a) => GFunctor (Either a) where
+  gmap = t undefined where
+    t :: (Show a) => RepEither a b -> (b -> c) -> Either a b -> Either a c
+    t = gmapdefault
+
+either1 :: Either Int Char
+either1 = Left either2
+
+either2 :: Either [Int] Char
+either2 = Right 'p'
+
+testsEither = [ gshow either1
+              , gshow (gmap gshow either1) ]
+
+--------------------------------------------------------------------------------
+-- Main tests
+--------------------------------------------------------------------------------
+
+main :: IO ()
+main = do
+        let p = putStrLn . ((++) "- ") . show
+        putStrLn "[] and Maybe tests:"
+        mapM_ p testsStandard
+        putStrLn "Tests for Tree:"
+        mapM_ p testsTree
+        putStrLn "\nTests for List:"
+        mapM_ p testsList
+        putStrLn "\nTests for Rose:"
+        mapM_ p testsRose
+        putStrLn "\nTests for GRose:"
+        mapM_ p testsGRose
+        putStrLn "\nTests for Either:"
+        mapM_ p testsEither
+        putStrLn "\nTests for Nested:"
+        mapM_ p testsNested

+ generic-deriving.cabal view

@@ -0,0 +1,42 @@+name:                   generic-deriving+version:                0.3+synopsis:               Generic programming library for generalized deriving.+description:++  This package provides functionality for generalizing the deriving mechanism+  in Haskell to arbitrary classes. It is described in the paper:+  .+  *  /A generic deriving mechanism for Haskell/.+     Jose Pedro Magalhaes, Atze Dijkstra, Johan Jeuring, and Andres Loeh.+     Haskell'10.++category:               Generics+copyright:              (c) 2010 Universiteit Utrecht+license:                BSD3+license-file:           LICENSE+author:                 José Pedro Magalhães+maintainer:             generics@haskell.org+stability:              experimental+build-type:             Custom+cabal-version:          >= 1.2.1+tested-with:            GHC == 6.10.4+extra-source-files:     examples/Examples.hs++library+  hs-source-dirs:       src+  exposed-modules:      Generics.Deriving+                        Generics.Deriving.Base++                        -- Generics.Deriving.Data+                        Generics.Deriving.Enum+                        Generics.Deriving.Eq+                        Generics.Deriving.Functor+                        -- Generics.Deriving.GMapQ+                        Generics.Deriving.Show+                        Generics.Deriving.Typeable+                        Generics.Deriving.Uniplate+                        Generics.Deriving.TH+                        +  build-depends:        base <= 4.2.0.0, template-haskell >=2.4 && <2.5+  extensions:           MultiParamTypeClasses, CPP+  ghc-options:          -Wall

+ src/Generics/Deriving.hs view

@@ -0,0 +1,20 @@+
+module Generics.Deriving (
+
+    module Generics.Deriving.Base,
+    module Generics.Deriving.Enum,
+    module Generics.Deriving.Eq,
+    module Generics.Deriving.Functor,
+    module Generics.Deriving.Show,
+    module Generics.Deriving.Typeable,
+    module Generics.Deriving.Uniplate
+    
+  ) where
+
+import Generics.Deriving.Base
+import Generics.Deriving.Enum
+import Generics.Deriving.Eq
+import Generics.Deriving.Functor
+import Generics.Deriving.Show
+import Generics.Deriving.Typeable
+import Generics.Deriving.Uniplate

+ src/Generics/Deriving/Base.hs view

@@ -0,0 +1,318 @@+{-# LANGUAGE EmptyDataDecls #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE CPP #-}
+
+module Generics.Deriving.Base (
+#ifndef __UHC__
+  -- * Generic representation types
+    V1, U1(..), Par1(..), Rec1(..), K1(..), M1(..)
+  , (:+:)(..), (:*:)(..), (:.:)(..)
+
+  -- ** Synonyms for convenience
+  , Rec0, Par0, R, P
+  , D1, C1, S1, D, C, S
+
+  -- * Meta-information
+  , Datatype(..), Constructor(..), Selector(..), NoSelector
+  , Fixity(..), Associativity(..), Arity(..), prec
+
+  -- * Representable type classes
+  , Representable0(..), Representable1(..)
+
+  ,
+#else
+  module UHC.Generics,
+#endif
+  -- * Representations for base types
+    Rep0Char, Rep0Int, Rep0Float
+  , Rep0Maybe, Rep1Maybe
+  , Rep0List, Rep1List
+
+  ) where
+
+
+#ifdef __UHC__
+import UHC.Generics
+#endif
+
+#ifndef __UHC__
+--------------------------------------------------------------------------------
+-- Representation types
+--------------------------------------------------------------------------------
+
+-- | Void: used for datatypes without constructors
+#ifdef __UHC__
+V1 :: * -> *
+#endif
+data V1 p
+
+-- | Unit: used for constructors without arguments
+#ifdef __UHC__
+U1 :: * -> *
+#endif
+data U1 p = U1
+
+-- | Used for marking occurrences of the parameter
+#ifdef __UHC__
+Par1 :: * -> *
+#endif
+newtype Par1 p = Par1 { unPar1 :: p }
+
+
+-- | Recursive calls of kind * -> *
+#ifdef __UHC__
+Rec1 :: (* -> *) -> * -> *
+#endif
+newtype Rec1 f p = Rec1 { unRec1 :: f p }
+
+-- | Constants, additional parameters and recursion of kind *
+#ifdef __UHC__
+K1 :: * -> * -> * -> *
+#endif
+newtype K1 i c p = K1 { unK1 :: c }
+
+-- | Meta-information (constructor names, etc.)
+#ifdef __UHC__
+M1 :: * -> * -> (* -> *) -> * -> *
+#endif
+newtype M1 i c f p = M1 { unM1 :: f p }
+
+-- | Sums: encode choice between constructors
+infixr 5 :+:
+#ifdef __UHC__
+(:+:) :: (* -> *) -> (* -> *) -> * -> *
+#endif
+data (:+:) f g p = L1 { unL1 :: f p } | R1 { unR1 :: g p }
+
+-- | Products: encode multiple arguments to constructors
+infixr 6 :*:
+#ifdef __UHC__
+(:*:) :: (* -> *) -> (* -> *) -> * -> *
+#endif
+data (:*:) f g p = f p :*: g p
+
+-- | Composition of functors
+infixr 7 :.:
+#ifdef __UHC__
+(:.:) :: (* -> *) -> (* -> *) -> * -> *
+#endif
+newtype (:.:) f g p = Comp1 { unComp1 :: f (g p) }
+
+-- | Tag for K1: recursion (of kind *)
+data R
+-- | Tag for K1: parameters (other than the last)
+data P
+
+-- | Type synonym for encoding recursion (of kind *)
+type Rec0  = K1 R
+-- | Type synonym for encoding parameters (other than the last)
+type Par0  = K1 P
+
+-- | Tag for M1: datatype
+data D
+-- | Tag for M1: constructor
+data C
+-- | Tag for M1: record selector
+data S
+
+-- | Type synonym for encoding meta-information for datatypes
+type D1 = M1 D
+
+-- | Type synonym for encoding meta-information for constructors
+type C1 = M1 C
+
+-- | Type synonym for encoding meta-information for record selectors
+type S1 = M1 S
+
+-- | Class for datatypes that represent datatypes
+class Datatype d where
+  -- | The name of the datatype, fully qualified
+#ifdef __UHC__
+  datatypeName :: t d f a -> String
+  moduleName   :: t d f a -> String
+#else
+  datatypeName :: t d (f :: * -> *) a -> String
+  moduleName   :: t d (f :: * -> *) a -> String
+#endif
+
+-- | Class for datatypes that represent records
+class Selector s where
+  -- | The name of the selector
+#ifdef __UHC__
+  selName :: t s f a -> String
+#else
+  selName :: t s (f :: * -> *) a -> String
+#endif
+
+-- | Used for constructor fields without a name
+data NoSelector
+
+instance Selector NoSelector where selName _ = ""
+
+-- | Class for datatypes that represent data constructors
+class Constructor c where
+  -- | The name of the constructor
+#ifdef __UHC__
+  conName :: t c f a -> String
+#else
+  conName :: t c (f :: * -> *) a -> String
+#endif
+
+  -- | The fixity of the constructor
+#ifdef __UHC__
+  conFixity :: t c f a -> Fixity
+#else
+  conFixity :: t c (f :: * -> *) a -> Fixity
+#endif  
+  conFixity = const Prefix
+
+  -- | Marks if this constructor is a record
+#ifdef __UHC__
+  conIsRecord :: t c f a -> Bool
+#else
+  conIsRecord :: t c (f :: * -> *) a -> Bool
+#endif
+  conIsRecord = const False
+
+  -- | Marks if this constructor is a tuple, 
+  -- returning arity >=0 if so, <0 if not
+#ifdef __UHC__
+  conIsTuple :: t c f a -> Arity
+#else
+  conIsTuple :: t c (f :: * -> *) a -> Arity
+#endif
+  conIsTuple = const NoArity
+
+
+-- | Datatype to represent the arity of a tuple.
+data Arity = NoArity | Arity Int
+  deriving (Eq, Show, Ord, Read)
+
+-- | Datatype to represent the fixity of a constructor. An infix
+-- | declaration directly corresponds to an application of 'Infix'.
+data Fixity = Prefix | Infix Associativity Int
+  deriving (Eq, Show, Ord, Read)
+
+-- | Get the precedence of a fixity value.
+prec :: Fixity -> Int
+prec Prefix      = 10
+prec (Infix _ n) = n
+
+-- | Datatype to represent the associativy of a constructor
+data Associativity =  LeftAssociative 
+                   |  RightAssociative
+                   |  NotAssociative
+  deriving (Eq, Show, Ord, Read)
+
+-- | Representable types of kind *
+class Representable0 a rep where
+  -- | Convert from the datatype to its representation
+  from0  :: a -> rep x
+  -- | Convert from the representation to the datatype
+  to0    :: rep x -> a
+
+-- | Representable types of kind * -> *
+class Representable1 f rep where
+  -- | Convert from the datatype to its representation
+  from1  :: f a -> rep a
+  -- | Convert from the representation to the datatype
+  to1    :: rep a -> f a
+
+#endif
+--------------------------------------------------------------------------------
+-- Representation for base types
+--------------------------------------------------------------------------------
+
+-- Representation types
+{-
+type Rep1Par1 = Par1
+instance Representable1 Par1 Rep1Par1 where
+  from1 = id
+  to1 = id
+
+type Rep1Rec1 f = Rec1 f
+instance Representable1 (Rec1 f) (Rep1Rec1 f) where
+  from1 = id
+  to1 = id
+-}
+-- Kind *
+
+type Rep0Char = Rec0 Char
+instance Representable0 Char Rep0Char where
+  from0 = K1
+  to0 = unK1
+
+type Rep0Int = Rec0 Int
+instance Representable0 Int Rep0Int where
+  from0 = K1
+  to0 = unK1
+
+type Rep0Float = Rec0 Float
+instance Representable0 Float Rep0Float where
+  from0 = K1
+  to0 = unK1
+
+-- etc...
+
+-- Kind * -> *
+
+data Maybe_
+data Nothing_
+data Just_
+
+instance Datatype Maybe_ where
+  datatypeName _ = "Maybe"
+  moduleName   _ = "Representation"
+
+instance Constructor Nothing_ where
+  conName _ = "Nothing"
+
+instance Constructor Just_ where
+  conName _ = "Just"
+
+type Rep0Maybe a = D1 Maybe_ (C1 Nothing_ U1 :+: C1 Just_ (Par0 a))
+instance Representable0 (Maybe a) (Rep0Maybe a) where
+  from0 Nothing  = M1 (L1 (M1 U1))
+  from0 (Just x) = M1 (R1 (M1 (K1 x)))
+  to0 (M1 (L1 (M1 U1)))     = Nothing
+  to0 (M1 (R1 (M1 (K1 x)))) = Just x
+
+type Rep1Maybe = D1 Maybe_ (C1 Nothing_ U1 :+: C1 Just_ Par1)
+instance Representable1 Maybe Rep1Maybe where
+  from1 Nothing  = M1 (L1 (M1 U1))
+  from1 (Just x) = M1 (R1 (M1 (Par1 x)))
+  to1 (M1 (L1 (M1 U1)))       = Nothing
+  to1 (M1 (R1 (M1 (Par1 x)))) = Just x
+
+
+data List__
+data Nil__
+data Cons__
+
+instance Datatype [a] where
+  datatypeName _ = "[]"
+  moduleName   _ = "Data.List"
+
+instance Constructor Nil__  where conName _ = "[]"
+instance Constructor Cons__ where
+  conName   _ = ":"
+  conFixity _ = Infix RightAssociative 5
+
+type Rep0List a = D1 List__ ((C1 Nil__ U1) :+: (C1 Cons__ (Par0 a :*: Rec0 [a])))
+instance Representable0 [a] (Rep0List a) where
+  from0 []    = M1 (L1 (M1 U1))
+  from0 (h:t) = M1 (R1 (M1 (K1 h :*: K1 t)))
+  to0 (M1 (L1 (M1 U1)))              = []
+  to0 (M1 (R1 (M1 (K1 h :*: K1 t)))) = h : t
+
+type Rep1List = D1 List__ ((C1 Nil__ U1) :+: (C1 Cons__ (Par1 :*: Rec1 [])))
+instance Representable1 [] Rep1List where
+  from1 []    = M1 (L1 (M1 U1))
+  from1 (h:t) = M1 (R1 (M1 (Par1 h :*: Rec1 t)))
+  to1 (M1 (L1 (M1 U1)))                  = []
+  to1 (M1 (R1 (M1 (Par1 h :*: Rec1 t)))) = h : t
+
+-- etc...

+ src/Generics/Deriving/Enum.hs view

@@ -0,0 +1,237 @@+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE CPP #-}
+
+module Generics.Deriving.Enum (
+
+  -- * Generic enum class
+    GEnum(..)
+
+  -- * Default definitions for GEnum
+  , genumDefault, toEnumDefault, fromEnumDefault
+
+  -- * Generic Ix class
+  , GIx(..)
+
+  -- * Default definitions for GIx
+  , rangeDefault, indexDefault, inRangeDefault
+
+  ) where
+
+
+import Generics.Deriving.Base
+import Generics.Deriving.Eq
+
+
+-----------------------------------------------------------------------------
+-- Utility functions for Enum'
+-----------------------------------------------------------------------------
+
+infixr 5 |||
+
+-- | Interleave elements from two lists. Similar to (++), but swap left and
+-- right arguments on every recursive application.
+--
+-- From Mark Jones' talk at AFP2008
+(|||) :: [a] -> [a] -> [a]
+[]     ||| ys = ys
+(x:xs) ||| ys = x : ys ||| xs
+
+-- | Diagonalization of nested lists. Ensure that some elements from every
+-- sublist will be included. Handles infinite sublists.
+--
+-- From Mark Jones' talk at AFP2008
+diag :: [[a]] -> [a]
+diag = concat . foldr skew [] . map (map (\x -> [x]))
+
+skew :: [[a]] -> [[a]] -> [[a]]
+skew []     ys = ys
+skew (x:xs) ys = x : combine (++) xs ys
+
+combine :: (a -> a -> a) -> [a] -> [a] -> [a]
+combine _ xs     []     = xs
+combine _ []     ys     = ys
+combine f (x:xs) (y:ys) = f x y : combine f xs ys
+
+findIndex :: (a -> Bool) -> [a] -> Maybe Int
+findIndex p xs = let l = [ i | (y,i) <- zip xs [(0::Int)..], p y]
+                 in if (null l)
+                    then Nothing
+                    else Just (head l)
+
+--------------------------------------------------------------------------------
+-- Generic enum
+--------------------------------------------------------------------------------
+
+class Enum' f where
+  enum' :: [f a]
+
+instance Enum' U1 where
+  enum' = [U1]
+
+instance (GEnum c) => Enum' (K1 i c) where
+  enum' = map K1 genum
+
+instance (Enum' f) => Enum' (M1 i c f) where
+  enum' = map M1 enum'
+
+instance (Enum' f, Enum' g) => Enum' (f :+: g) where
+  enum' = map L1 enum' ||| map R1 enum'
+
+instance (Enum' f, Enum' g) => Enum' (f :*: g) where
+  enum' = diag [ [ x :*: y | y <- enum' ] | x <- enum' ]
+
+
+#ifdef __UHC__
+
+{-# DERIVABLE GEnum genum genumDefault #-}
+deriving instance (GEnum a) => GEnum (Maybe a)
+deriving instance (GEnum a) => GEnum [a]
+
+{-# DERIVABLE Enum toEnum toEnumDefault #-}
+{-# DERIVABLE Enum fromEnum fromEnumDefault #-}
+
+#else
+
+instance (GEnum a) => GEnum (Maybe a) where
+  genum = t undefined where
+    t :: (GEnum a) => Rep0Maybe a x -> [Maybe a]
+    t = genumDefault
+
+instance (GEnum a) => GEnum [a] where
+  genum = t undefined where
+    t :: (GEnum a) => Rep0List a x -> [[a]]
+    t = genumDefault
+
+#endif
+
+genumDefault :: (Representable0 a rep0, Enum' rep0) => rep0 x -> [a]
+genumDefault rep = map to0 (enum' `asTypeOf` [rep])
+
+toEnumDefault :: (Representable0 a rep0, Enum' rep0) => rep0 x -> Int -> a
+toEnumDefault rep i = let l = enum' `asTypeOf` [rep]
+                      in if (length l > i)
+                         then to0 (l !! i)
+                         else error "toEnum: invalid index"
+
+fromEnumDefault :: (GEq a, Representable0 a rep0, Enum' rep0)
+                => rep0 x -> a -> Int
+fromEnumDefault rep x = t x (map to0 (enum' `asTypeOf` [rep])) where
+  -- This weird local function is to appease EHC's type checker
+  t :: GEq a => a -> [a] -> Int
+  t y l = case (findIndex (geq y) l) of
+            Nothing -> error "fromEnum: no corresponding index"
+            Just i  -> i
+
+{-
+-- Natural definition
+fromEnumDefault :: (GEq a, Representable0 a rep0, Enum' rep0)
+                => rep0 x -> a -> Int
+fromEnumDefault rep x = let l = map to0 (enum' `asTypeOf` [rep])
+                        in case (findIndex (geq x) l) of
+                             Nothing -> error "fromEnum: no corresponding index"
+                             Just i  -> i
+-}
+
+class GEnum a where
+  genum :: [a]
+
+instance GEnum Int where
+  genum = [0..] ||| (neg 0) where
+    neg n = (n-1) : neg (n-1)
+
+--------------------------------------------------------------------------------
+-- Generic Ix
+--------------------------------------------------------------------------------
+
+-- Minimal complete instance: 'range', 'index' and 'inRange'.
+class (Ord a) => GIx a where
+    -- | The list of values in the subrange defined by a bounding pair.
+    range               :: (a,a) -> [a]
+    -- | The position of a subscript in the subrange.
+    index               :: (a,a) -> a -> Int
+    -- | Returns 'True' the given subscript lies in the range defined
+    -- the bounding pair.
+    inRange             :: (a,a) -> a -> Bool
+
+
+rangeDefault :: (GEq a, Representable0 a rep0, Enum' rep0)
+             => rep0 x -> (a,a) -> [a]
+rangeDefault rep = t (map to0 (enum' `asTypeOf` [rep])) where
+  t :: GEq a => [a] -> (a,a) -> [a]
+  t l (x,y) = 
+    case (findIndex (geq x) l, findIndex (geq y) l) of
+      (Nothing, _)     -> error "rangeDefault: no corresponding index"
+      (_, Nothing)     -> error "rangeDefault: no corresponding index"
+      (Just i, Just j) -> take (j-i) (drop i l)
+
+indexDefault :: (GEq a, Representable0 a rep0, Enum' rep0)
+             => rep0 x -> (a,a) -> a -> Int
+indexDefault rep = t (map to0 (enum' `asTypeOf` [rep])) where
+  t :: GEq a => [a] -> (a,a) -> a -> Int
+  t l (x,y) z =
+    case (findIndex (geq x) l, findIndex (geq y) l) of
+      (Nothing, _)     -> error "indexDefault: no corresponding index"
+      (_, Nothing)     -> error "indexDefault: no corresponding index"
+      (Just i, Just j) -> case findIndex (geq z) (take (j-i) (drop i l)) of
+                            Nothing -> error "indexDefault: index out of range"
+                            Just k  -> k
+
+inRangeDefault :: (GEq a, Representable0 a rep0, Enum' rep0)
+               => rep0 x -> (a,a) -> a -> Bool
+inRangeDefault rep = t (map to0 (enum' `asTypeOf` [rep])) where
+  t :: GEq a => [a] -> (a,a) -> a -> Bool
+  t l (x,y) z = 
+    case (findIndex (geq x) l, findIndex (geq y) l) of
+      (Nothing, _)     -> error "indexDefault: no corresponding index"
+      (_, Nothing)     -> error "indexDefault: no corresponding index"
+      (Just i, Just j) -> maybe False (const True)
+                            (findIndex (geq z) (take (j-i) (drop i l)))
+
+#ifdef __UHC__
+
+{-# DERIVABLE GIx range rangeDefault #-}
+{-# DERIVABLE GIx index indexDefault #-}
+{-# DERIVABLE GIx inRange inRangeDefault #-}
+
+deriving instance (GEq a, GEnum a, GIx a) => GIx (Maybe a)
+deriving instance (GEq a, GEnum a, GIx a) => GIx [a]
+
+#else
+
+instance (GEq a, GEnum a, GIx a) => GIx (Maybe a) where
+  range = t undefined where
+    t :: (GEq a, GEnum a, GIx a)
+      => Rep0Maybe a x -> (Maybe a, Maybe a) -> [Maybe a]
+    t = rangeDefault
+  index = t undefined where
+    t :: (GEq a, GEnum a, GIx a)
+      => Rep0Maybe a x -> (Maybe a, Maybe a) -> Maybe a -> Int
+    t = indexDefault
+  inRange = t undefined where
+    t :: (GEq a, GEnum a, GIx a)
+      => Rep0Maybe a x -> (Maybe a, Maybe a) -> Maybe a -> Bool
+    t = inRangeDefault
+
+instance (GEq a, GEnum a, GIx a) => GIx [a] where
+  range = t undefined where
+    t :: (GEq a, GEnum a, GIx a)
+      => Rep0List a x -> ([a], [a]) -> [[a]]
+    t = rangeDefault
+  index = t undefined where
+    t :: (GEq a, GEnum a, GIx a)
+      => Rep0List a x -> ([a], [a]) -> [a] -> Int
+    t = indexDefault
+  inRange = t undefined where
+    t :: (GEq a, GEnum a, GIx a)
+      => Rep0List a x -> ([a], [a]) -> [a] -> Bool
+    t = inRangeDefault
+
+#endif
+
+instance GIx Int where
+    range (m,n) = [m..n]
+    index (m,_n) i = i - m
+    inRange (m,n) i =  m <= i && i <= n

+ src/Generics/Deriving/Eq.hs view

@@ -0,0 +1,79 @@+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE CPP #-}
+
+module Generics.Deriving.Eq (
+  -- * Generic show class
+    GEq(..)
+
+  -- * Default definition
+  , geqdefault
+
+  ) where
+
+
+import Generics.Deriving.Base
+
+--------------------------------------------------------------------------------
+-- Generic show
+--------------------------------------------------------------------------------
+
+class GEq' f where
+  geq' :: f a -> f a -> Bool
+
+instance GEq' U1 where
+  geq' _ _ = True
+
+instance (GEq c) => GEq' (K1 i c) where
+  geq' (K1 a) (K1 b) = geq a b
+
+-- No instances for P or Rec because geq is only applicable to types of kind *
+
+instance (GEq' a) => GEq' (M1 i c a) where
+  geq' (M1 a) (M1 b) = geq' a b
+
+instance (GEq' a, GEq' b) => GEq' (a :+: b) where
+  geq' (L1 a) (L1 b) = geq' a b
+  geq' (R1 a) (R1 b) = geq' a b
+  geq' _      _      = False
+
+instance (GEq' a, GEq' b) => GEq' (a :*: b) where
+  geq' (a1 :*: b1) (a2 :*: b2) = geq' a1 a2 && geq' b1 b2
+
+
+class GEq a where 
+  geq :: a -> a -> Bool
+
+#ifdef __UHC__
+
+{-# DERIVABLE GEq geq geqdefault #-}
+deriving instance (GEq a) => GEq (Maybe a)
+deriving instance (GEq a) => GEq [a]
+
+#endif
+
+geqdefault :: (Representable0 a rep0, GEq' rep0) => rep0 x -> a -> a -> Bool
+geqdefault rep x y = geq' (from0 x `asTypeOf` rep) (from0 y `asTypeOf` rep)
+
+
+-- Base types instances
+instance GEq Char   where geq = (==)
+instance GEq Int    where geq = (==)
+instance GEq Float  where geq = (==)
+
+
+#ifndef __UHC__
+
+instance (GEq a) => GEq (Maybe a) where
+  geq = t undefined where
+    t :: (GEq a) => Rep0Maybe a x -> Maybe a -> Maybe a -> Bool
+    t = geqdefault
+
+instance (GEq a) => GEq [a] where
+  geq = t undefined where
+    t :: (GEq a) => Rep0List a x -> [a] -> [a] -> Bool
+    t = geqdefault
+
+#endif

+ src/Generics/Deriving/Functor.hs view

@@ -0,0 +1,76 @@+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE CPP #-}
+
+module Generics.Deriving.Functor (
+  -- * GFunctor class
+    GFunctor(..)
+
+  -- * Default method
+  , gmapdefault
+
+  ) where
+
+import Generics.Deriving.Base
+
+--------------------------------------------------------------------------------
+-- Generic fmap
+--------------------------------------------------------------------------------
+
+class GFunctor' f where
+  gmap' :: (a -> b) -> f a -> f b
+
+instance GFunctor' U1 where
+  gmap' _ U1 = U1
+
+instance GFunctor' Par1 where
+  gmap' f (Par1 a) = Par1 (f a)
+
+instance GFunctor' (K1 i c) where
+  gmap' _ (K1 a) = K1 a
+
+instance (GFunctor f) => GFunctor' (Rec1 f) where
+  gmap' f (Rec1 a) = Rec1 (gmap f a)
+
+instance (GFunctor' f) => GFunctor' (M1 i c f) where
+  gmap' f (M1 a) = M1 (gmap' f a)
+
+instance (GFunctor' f, GFunctor' g) => GFunctor' (f :+: g) where
+  gmap' f (L1 a) = L1 (gmap' f a)
+  gmap' f (R1 a) = R1 (gmap' f a)
+
+instance (GFunctor' f, GFunctor' g) => GFunctor' (f :*: g) where
+  gmap' f (a :*: b) = gmap' f a :*: gmap' f b
+
+instance (GFunctor f, GFunctor' g) => GFunctor' (f :.: g) where
+  gmap' f (Comp1 x) = Comp1 (gmap (gmap' f) x)
+
+
+class GFunctor f where
+  gmap :: (a -> b) -> f a -> f b
+
+gmapdefault :: (Representable1 f rep, GFunctor' rep)
+            => rep a -> (a -> b) -> f a -> f b
+gmapdefault ra f x = to1 (gmap' f (from1 x `asTypeOf` ra))
+
+#ifdef __UHC__
+
+{-# DERIVABLE GFunctor gmap gmapdefault #-}
+
+deriving instance GFunctor Maybe
+deriving instance GFunctor []
+
+#else
+
+-- Base types instances
+instance GFunctor Maybe where
+  gmap = t undefined where
+    t :: Rep1Maybe a -> (a -> b) -> Maybe a -> Maybe b
+    t = gmapdefault
+
+instance GFunctor [] where
+  gmap = t undefined where
+    t :: Rep1List a -> (a -> b) -> [a] -> [b]
+    t = gmapdefault
+
+#endif

+ src/Generics/Deriving/Show.hs view

@@ -0,0 +1,136 @@+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE IncoherentInstances #-} -- :-/
+{-# LANGUAGE CPP #-}
+
+module Generics.Deriving.Show (
+  -- * Generic show class
+    GShow(..)
+
+  -- * Default definition
+  , gshowsPrecdefault
+
+  ) where
+
+
+import Generics.Deriving.Base
+
+--------------------------------------------------------------------------------
+-- Generic show
+--------------------------------------------------------------------------------
+
+data Type = Rec | Tup | Pref | Inf String
+
+class GShow' f where
+  gshowsPrec' :: Type -> Int -> f a -> ShowS
+  isNullary   :: f a -> Bool
+  isNullary = error "generic show (isNullary): unnecessary case"
+
+instance GShow' U1 where
+  gshowsPrec' _ _ U1 = id
+  isNullary _ = True
+
+instance (GShow c) => GShow' (K1 i c) where
+  gshowsPrec' _ n (K1 a) = gshowsPrec n a
+  isNullary _ = False
+
+-- No instances for P or Rec because gshow is only applicable to types of kind *
+
+instance (GShow' a, Constructor c) => GShow' (M1 C c a) where
+  gshowsPrec' _ n c@(M1 x) = 
+    case fixity of
+      Prefix    -> showParen (n > 10 && not (isNullary x)) 
+                    ( showString (conName c) 
+                    . if (isNullary x) then id else showChar ' '
+                    . showBraces t (gshowsPrec' t 10 x))
+      Infix _ m -> showParen (n > m) (showBraces t (gshowsPrec' t m x))
+      where fixity = conFixity c
+            t = if (conIsRecord c) then Rec else
+                  case (conIsTuple c) of
+                    Arity _ -> Tup
+                    NoArity -> case fixity of
+                                 Prefix    -> Pref
+                                 Infix _ _ -> Inf (show (conName c))
+            showBraces :: Type -> ShowS -> ShowS
+            showBraces Rec     p = showChar '{' . p . showChar '}'
+            showBraces Tup     p = showChar '(' . p . showChar ')'
+            showBraces Pref    p = p
+            showBraces (Inf _) p = p
+  
+  isNullary (M1 x) = isNullary x
+
+instance (Selector s, GShow' a) => GShow' (M1 S s a) where
+  gshowsPrec' t n s@(M1 x) | selName s == "" = showParen (n > 10)
+                                                 (gshowsPrec' t n x)
+                           | otherwise       =   showString (selName s)
+                                               . showString " = "
+                                               . gshowsPrec' t 0 x
+  isNullary (M1 x) = isNullary x
+
+instance (GShow' a) => GShow' (M1 D d a) where
+  gshowsPrec' t n (M1 x) = gshowsPrec' t n x
+
+instance (GShow' a, GShow' b) => GShow' (a :+: b) where
+  gshowsPrec' t n (L1 x) = gshowsPrec' t n x
+  gshowsPrec' t n (R1 x) = gshowsPrec' t n x
+
+instance (GShow' a, GShow' b) => GShow' (a :*: b) where
+  gshowsPrec' t@Rec     n (a :*: b) =
+    gshowsPrec' t n     a . showString ", " . gshowsPrec' t n     b
+  gshowsPrec' t@(Inf s) n (a :*: b) =
+    gshowsPrec' t n     a . showString s    . gshowsPrec' t n     b
+  gshowsPrec' t@Tup     n (a :*: b) =
+    gshowsPrec' t n     a . showChar ','    . gshowsPrec' t n     b
+  gshowsPrec' t@Pref    n (a :*: b) =
+    gshowsPrec' t (n+1) a . showChar ' '    . gshowsPrec' t (n+1) b
+  
+  -- If we have a product then it is not a nullary constructor
+  isNullary _ = False
+
+
+class GShow a where 
+  gshowsPrec :: Int -> a -> ShowS
+  gshows :: a -> ShowS
+  gshows = gshowsPrec 0
+  gshow :: a -> String
+  gshow x = gshows x ""
+  
+
+#ifdef __UHC__
+
+{-# DERIVABLE GShow gshowsPrec gshowsPrecdefault #-}
+deriving instance (GShow a) => GShow (Maybe a)
+
+#else
+
+instance (GShow a) => GShow (Maybe a) where
+  gshowsPrec = t undefined where
+    t :: (GShow a) => Rep0Maybe a x -> Int -> Maybe a -> ShowS
+    t = gshowsPrecdefault
+
+#endif
+
+gshowsPrecdefault :: (Representable0 a rep0, GShow' rep0)
+                  => rep0 x -> Int -> a -> ShowS
+gshowsPrecdefault rep n x = gshowsPrec' Pref n (from0 x `asTypeOf` rep)
+
+
+-- Base types instances
+instance GShow Char   where gshowsPrec = showsPrec
+instance GShow Int    where gshowsPrec = showsPrec
+instance GShow Float  where gshowsPrec = showsPrec
+instance GShow String where gshowsPrec = showsPrec
+instance GShow Bool   where gshowsPrec = showsPrec
+
+intersperse :: a -> [a] -> [a]
+intersperse _ []    = []
+intersperse _ [h]   = [h]
+intersperse x (h:t) = h : x : (intersperse x t)
+
+instance (GShow a) => GShow [a] where
+  gshowsPrec _ l =   showChar '['
+                   . foldr (.) id
+                      (intersperse (showChar ',') (map (gshowsPrec 0) l))
+                   . showChar ']'

+ src/Generics/Deriving/TH.hs view

@@ -0,0 +1,397 @@+{-# LANGUAGE TemplateHaskell, CPP #-}+{-# OPTIONS_GHC -w           #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Generics.Deriving.TH+-- Copyright   :  (c) 2008--2009 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. For now, it generates only the 'Representable0' instance.+-- Empty datatypes are not yet supported.+-----------------------------------------------------------------------------++-- Adapted from Generics.Regular.TH+module Generics.Deriving.TH (+      deriveAll+    , deriveData+    , deriveConstructors+    , deriveSelectors+    , deriveRepresentable0+    , deriveRep0+    , simplInstance+  ) where++import Generics.Deriving.Base++import Language.Haskell.TH hiding (Fixity())+import Language.Haskell.TH.Syntax (Lift(..))++import Data.List (intercalate)+import Control.Monad++-- | 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 (genRepName 0 ty)+  x <- newName "x"+  let typ = ForallT [PlainTV x] [] +        ((foldl (\a -> AppT a . VarT . tyVarBndrToName) (ConT (genRepName 0 ty)) +          (typeVariables i)) `AppT` (VarT x))+  fmap (: []) $ instanceD (cxt []) (conT cl `appT` conT ty)+    [funD fn [clause [] (normalB (varE df `appE` +      (sigE (global 'undefined) (return typ)))) []]]+++-- | Given the type and the name (as string) for the type to derive,+-- generate the 'Data' instance, the 'Constructor' instances, the 'Selector'+-- instances, and the 'Representable0' instance.+deriveAll :: Name -> Q [Dec]+deriveAll n =+  do a <- deriveData n+     b <- deriveConstructors n+     c <- deriveSelectors n+     d <- deriveRepresentable0 n+     return (a ++ b ++ c ++ d)++-- | Given a datatype name, derive a datatype and instance of class 'Datatype'.+deriveData :: Name -> Q [Dec]+deriveData = dataInstance++-- | Given a datatype name, derive datatypes and +-- instances of class 'Constructor'.+deriveConstructors :: Name -> Q [Dec]+deriveConstructors = constrInstance++-- | Given a datatype name, derive datatypes and instances of class 'Selector'.+deriveSelectors :: Name -> Q [Dec]+deriveSelectors = selectInstance++-- | Given the type and the name (as string) for the Representable0 type+-- synonym to derive, generate the 'Representable0' instance.+deriveRepresentable0 :: Name -> Q [Dec]+deriveRepresentable0 n = do+    rep0 <- deriveRep0 n+    inst <- deriveInst n+    return $ rep0 ++ inst++-- | Derive only the 'Rep0' type synonym. Not needed if 'deriveRepresentable0'+-- is used.+deriveRep0 :: Name -> Q [Dec]+deriveRep0 n = do+  i <- reify n+  fmap (:[]) $ tySynD (genRepName 0 n) (typeVariables i) (rep0Type n)++deriveInst :: Name -> Q [Dec]+deriveInst t = do+  i <- reify t+  let typ q = foldl (\a -> AppT a . VarT . tyVarBndrToName) (ConT q) +                (typeVariables i)+  fcs <- mkFrom t 1 0 t+  tcs <- mkTo   t 1 0 t+  liftM (:[]) $+    instanceD (cxt [])+     (conT ''Representable0 `appT` return (typ t) `appT`+       return (typ (genRepName 0 t))) [funD 'from0 fcs, funD 'to0 tcs]++dataInstance :: Name -> Q [Dec]+dataInstance n = do+  i <- reify n+  case i of+    TyConI (DataD    _ n _ _ _) -> mkInstance n+    TyConI (NewtypeD _ n _ _ _) -> mkInstance n+    _ -> return []+  where+    mkInstance n = do+      ds <- mkDataData n+      is <- mkDataInstance n+      return $ [ds,is]++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++selectInstance :: Name -> Q [Dec]+selectInstance 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 (mkSelectData n) cs+      is <- mapM (mkSelectInstance n) cs+      return $ concat (ds ++ is)++typeVariables :: Info -> [TyVarBndr]+typeVariables (TyConI (DataD    _ _ tv _ _)) = tv+typeVariables (TyConI (NewtypeD _ _ tv _ _)) = tv+typeVariables _                           = []++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 :: Int -> Name -> Name+genRepName n = mkName . (++"_") . (("Rep" ++ show n) ++) . nameBase++mkDataData :: Name -> Q Dec+mkDataData n = dataD (cxt []) (genName [n]) [] [] []++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])++mkSelectData :: Name -> Con -> Q [Dec]+mkSelectData dt r@(RecC n fs) = return (map one fs)+  where one (f, _, _) = DataD [] (genName [dt, n, f]) [] [] []+mkSelectData dt _ = return []+++mkDataInstance :: Name -> Q Dec+mkDataInstance n =+  instanceD (cxt []) (appT (conT ''Datatype) (conT $ genName [n]))+    [funD 'datatypeName [clause [wildP] (normalB (stringE (nameBase n))) []]+    ,funD 'moduleName   [clause [wildP] (normalB (stringE name)) []]]+  where+    name = maybe (error "Cannot fetch module name!") id (nameModule n)++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+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)++mkSelectInstance :: Name -> Con -> Q [Dec]+mkSelectInstance dt r@(RecC n fs) = return (map one fs) where+  one (f, _, _) = +    InstanceD ([]) (AppT (ConT ''Selector) (ConT $ genName [dt, n, f]))+      [FunD 'selName [Clause [WildP] +        (NormalB (LitE (StringL (nameBase f)))) []]]+mkSelectInstance _ _ = return []++rep0Type :: Name -> Q Type+rep0Type n =+    do+      -- runIO $ putStrLn $ "processing " ++ show n+      i <- reify n+      let b = case i of+                TyConI (DataD _ dt vs cs _) ->+                  (conT ''D1) `appT` (conT $ genName [dt]) `appT` +                    (foldr1' sum (conT ''V1) +                      (map (rep0Con (dt, map tyVarBndrToName vs)) cs))+                TyConI (NewtypeD _ dt vs c _) ->+                  (conT ''D1) `appT` (conT $ genName [dt]) `appT`+                    (rep0Con (dt, map tyVarBndrToName vs) c)+                TyConI (TySynD t _ _) -> error "type synonym?" +                _ -> error "unknown construct" +      --appT b (conT $ mkName (nameBase n))+      b where+    sum :: Q Type -> Q Type -> Q Type+    sum a b = conT ''(:+:) `appT` a `appT` b+++rep0Con :: (Name, [Name]) -> Con -> Q Type+rep0Con (dt, vs) (NormalC n []) =+    conT ''C1 `appT` (conT $ genName [dt, n]) `appT` +     (conT ''S1 `appT` conT ''NoSelector `appT` conT ''U1)+rep0Con (dt, vs) (NormalC n fs) =+    conT ''C1 `appT` (conT $ genName [dt, n]) `appT` +     (foldr1 prod (map (repField (dt, vs) . snd) fs)) where+    prod :: Q Type -> Q Type -> Q Type+    prod a b = conT ''(:*:) `appT` a `appT` b+rep0Con (dt, vs) r@(RecC n []) =+    conT ''C1 `appT` (conT $ genName [dt, n]) `appT` conT ''U1+rep0Con (dt, vs) r@(RecC n fs) =+    conT ''C1 `appT` (conT $ genName [dt, n]) `appT` +      (foldr1 prod (map (repField' (dt, vs) n) fs)) where+    prod :: Q Type -> Q Type -> Q Type+    prod a b = conT ''(:*:) `appT` a `appT` b++rep0Con d (InfixC t1 n t2) = rep0Con d (NormalC n [t1,t2])++--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 ''S1 `appT` conT ''NoSelector `appT`+                 (conT ''Rec0 `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 ''S1 `appT` conT (genName [dt, ns, f]) +                                    `appT` (conT ''Rec0 `appT` return t)+-- Note: we should generate Par0 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 = 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)) [0..] 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 = 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)) [0..] 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+fromCon wrap ns (dt, vs) m i (NormalC cn []) =+  clause+    [conP cn []]+    (normalB $ appE (conE 'M1) $ wrap $ lrE m i $ appE (conE 'M1) $ +      conE 'M1 `appE` (conE 'U1)) []+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 $ appE (conE 'M1) $ wrap $ lrE m i $ conE 'M1 `appE` +      foldr1 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 $ appE (conE 'M1) $ wrap $ lrE m i $ conE 'M1 `appE` (conE 'U1)) []+fromCon wrap ns (dt, vs) m i r@(RecC cn fs) =+  clause+    [conP cn (map (varP . field) [0..length fs - 1])]+    (normalB $ appE (conE 'M1) $ wrap $ lrE m i $ conE 'M1 `appE` +      foldr1 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 'M1 `appE` (conE 'K1 `appE` varE (field nr))++toCon :: (Q Pat -> Q Pat) -> Name -> (Name, [Name]) -> Int -> Int -> Con -> Q Clause+toCon wrap ns (dt, vs) m i (NormalC cn []) =+    clause+      [wrap $ conP 'M1 [lrP m i $ conP 'M1 [conP 'M1 [conP 'U1 []]]]]+      (normalB $ conE cn) []+toCon wrap ns (dt, vs) m i (NormalC cn fs) =+    -- runIO (putStrLn ("constructor " ++ show ix)) >>+    clause+      [wrap $ conP 'M1 [lrP m i $ conP 'M1+        [foldr1 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 $ conP 'M1 [lrP m i $ conP 'M1 [conP 'U1 []]]]+      (normalB $ conE cn) []+toCon wrap ns (dt, vs) m i r@(RecC cn fs) =+    clause+      [wrap $ conP 'M1 [lrP m i $ conP 'M1+        [foldr1 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 'M1 [conP 'K1 [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 'L1 [p]+lrP m i p = conP 'R1 [lrP (m-1) (i-1) p]++lrE :: Int -> Int -> (Q Exp -> Q Exp)+lrE 1 0 e = e+lrE m 0 e = conE 'L1 `appE` e+lrE m i e = conE 'R1 `appE` lrE (m-1) (i-1) 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)

+ src/Generics/Deriving/Typeable.hs view

@@ -0,0 +1,93 @@+{-# LANGUAGE EmptyDataDecls #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+module Generics.Deriving.Typeable (
+
+    typeOf0default, typeOf1default,
+
+#ifndef __UHC__
+    module Data.Typeable
+#endif
+
+  ) where
+
+
+import Generics.Deriving.Base
+
+#ifndef __UHC__
+import Data.Typeable
+#endif
+
+--------------------------------------------------------------------------------
+-- Typeable0
+--------------------------------------------------------------------------------
+
+#ifdef __UHC__
+data TypeRep
+instance Eq TypeRep where (==) = undefined
+
+data TyCon
+instance Eq TyCon where (==) = undefined
+
+mkTyConApp  :: TyCon -> [TypeRep] -> TypeRep
+mkTyConApp = undefined
+
+
+mkFunTy  :: TypeRep -> TypeRep -> TypeRep
+mkFunTy = undefined
+
+splitTyConApp :: TypeRep -> (TyCon,[TypeRep])
+splitTyConApp = undefined
+
+funResultTy :: TypeRep -> TypeRep -> Maybe TypeRep
+funResultTy = undefined
+
+mkAppTy :: TypeRep -> TypeRep -> TypeRep
+mkAppTy = undefined
+
+mkTyCon :: String -> TyCon
+mkTyCon = undefined
+
+typeRepTyCon :: TypeRep -> TyCon
+typeRepTyCon = undefined
+
+typeRepArgs :: TypeRep -> [TypeRep]
+typeRepArgs = undefined
+
+
+class Typeable a where
+  typeOf :: a -> TypeRep
+
+class Typeable1 f where
+  typeOf1 :: f a -> TypeRep
+
+#endif
+
+
+class Typeable0' f where
+  typeOf0' :: f a -> TypeRep
+
+instance (Datatype d) => Typeable0' (M1 D d a) where
+  typeOf0' x = mkTyConApp (mkTyCon (datatypeName x)) []
+
+
+typeOf0default :: (Representable0 a rep, Typeable0' rep)
+              => rep x -> a -> TypeRep
+typeOf0default rep x = typeOf0' (from0 x `asTypeOf` rep)
+
+
+class Typeable1' f a where
+  typeOf1' :: f a -> TypeRep
+
+instance (Typeable a, Datatype d) => Typeable1' (M1 D d f) a where
+  typeOf1' x = mkTyConApp (mkTyCon (datatypeName x)) [typeOf (y x)]
+    where y :: M1 D d f b -> b
+          y _ = undefined
+
+
+typeOf1default :: (Representable1 f rep, Typeable1' rep a)
+              => rep a -> f a -> TypeRep
+typeOf1default rep x = typeOf1' (from1 x `asTypeOf` rep)

+ src/Generics/Deriving/Uniplate.hs view

@@ -0,0 +1,75 @@+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE IncoherentInstances #-} -- :-/
+{-# LANGUAGE CPP #-}
+
+module Generics.Deriving.Uniplate (
+    Uniplate(..)
+
+  -- * Default definition
+  , childrendefault
+
+  ) where
+
+
+import Generics.Deriving.Base
+
+--------------------------------------------------------------------------------
+-- Generic Uniplate
+--------------------------------------------------------------------------------
+
+class Uniplate' f b where
+  children' :: f a -> [b]
+
+instance Uniplate' U1 a where
+  children' U1 = []
+
+instance Uniplate' (K1 i a) a where
+  children' (K1 a) = [a]
+
+instance Uniplate' (K1 i a) b where
+  children' (K1 _) = []
+
+instance (Uniplate' f b) => Uniplate' (M1 i c f) b where
+  children' (M1 a) = children' a
+
+instance (Uniplate' f b, Uniplate' g b) => Uniplate' (f :+: g) b where
+  children' (L1 a) = children' a
+  children' (R1 a) = children' a
+
+instance (Uniplate' f b, Uniplate' g b) => Uniplate' (f :*: g) b where
+  children' (a :*: b) = children' a ++ children' b 
+
+
+class Uniplate a where 
+  children :: a -> [a]
+  children _ = []
+
+#ifdef __UHC__
+
+{-# DERIVABLE Uniplate children childrendefault #-}
+deriving instance (Uniplate a) => Uniplate (Maybe a)
+
+#endif
+
+childrendefault :: (Representable0 a rep0, Uniplate' rep0 a) => rep0 x -> a -> [a]
+childrendefault rep x = children' (from0 x `asTypeOf` rep)
+
+
+-- Base types instances
+instance Uniplate Char
+instance Uniplate Int
+instance Uniplate Float
+
+instance Uniplate [a] where
+  children []    = []
+  children (_:t) = [t]
+
+#ifndef __UHC__
+instance (Uniplate a) => Uniplate (Maybe a) where
+  children = t undefined where
+    t :: Rep0Maybe a x -> Maybe a -> [Maybe a]
+    t = childrendefault
+#endif