{-# 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: Nested datatype Bush (minimal)
--------------------------------------------------------------------------------
data Bush a = BushNil | BushCons a (Bush (Bush a))
$(deriveAll ''Bush)
type Rep1Bush = U1 :+: Par1 :*: Bush :.: Rec1 Bush
instance Representable1 Bush Rep1Bush where
from1 BushNil = L1 U1
from1 (BushCons a b) = R1 (Par1 a :*: Comp1 (gmap Rec1 b))
to1 (L1 U1) = BushNil
to1 (R1 (Par1 a :*: Comp1 b)) = BushCons a (gmap unRec1 b)
instance GFunctor Bush where
gmap = t undefined where
t :: Rep1Bush a -> (a -> b) -> Bush a -> Bush b
t = gmapdefault
instance (GShow a) => GShow (Bush a) where
gshowsPrec = t undefined where
t :: (GShow a) => Rep0Bush_ a x -> Int -> Bush a -> ShowS
t = gshowsPrecdefault
-- Example usage
bush1 :: Bush Int
bush1 = BushCons 0 (BushCons (BushCons 1 BushNil) BushNil)
testsBush = [ gshow bush1
, gshow (gmap gshow bush1) ]
--------------------------------------------------------------------------------
-- 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
putStrLn "\nTests for Bush:"
mapM_ p testsBush