Commit 69cc9a59 authored by dreixel's avatar dreixel

Add some tests for the new generic deriving mechanism.

parent a07c8a4f
{-# LANGUAGE TypeOperators, Generics, FlexibleContexts, FlexibleInstances #-}
module GEq where
import GHC.Generics
class GEq' f where
geq' :: f a -> f a -> Bool
instance GEq' U1 where
geq' _ _ = True
instance GEq' (K1 P c) where
geq' (K1 a) (K1 b) = undefined
instance (GEq c) => GEq' (K1 R 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
default geq :: (Representable0 a, GEq' (Rep0 a)) => a -> a -> Bool
geq x y = geq' (from0 x) (from0 y)
-- Base types instances (ad-hoc)
instance GEq Char where geq = (==)
instance GEq Int where geq = (==)
instance GEq Float where geq = (==)
{-
-- Generic instances
instance (GEq a) => GEq (Maybe a)
instance (GEq a) => GEq [a]
-}
{-# LANGUAGE TypeOperators, Generics #-}
module Main where
import GHC.Generics hiding (C, D)
import GEq
-- We should be able to generate a generic representation for these types
data C = C0 | C1
data D a = D0 | D1 { d11 :: a, d12 :: (D a) }
-- Example values
c0 = C0
c1 = C1
d0 :: D Char
d0 = D0
d1 = D1 'p' D0
-- Generic instances
instance GEq C
instance (GEq a) => GEq (D a)
-- Tests
teq0 = geq c0 c1
teq1 = geq d0 d1
teq2 = geq d0 d0
main = mapM_ print [teq0, teq1, teq2]
TOP=../../../..
include $(TOP)/mk/boilerplate.mk
include $(TOP)/mk/test.mk
setTestOpts(only_compiler_types(['ghc']))
test('GEq1', normal, multimod_compile_and_run, ['Main', ''])
\ No newline at end of file
TOP=../../..
include $(TOP)/mk/boilerplate.mk
include $(TOP)/mk/test.mk
{-# LANGUAGE Generics #-}
module Main where
import GHC.Generics
import Uniplate
data Tree = Leaf | Node Int Tree Tree deriving Show
data Pair a b = Pair a b deriving Show
instance Uniplate Tree
instance Uniplate (Pair a b)
-- Tests
t1 = children ('p')
t2 = children (Pair "abc" (Pair "abc" 2))
t3 = children (Node 2 Leaf Leaf)
main = print (t1, t2, t3)
TOP=../../../..
include $(TOP)/mk/boilerplate.mk
include $(TOP)/mk/test.mk
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE Generics #-}
{-# LANGUAGE IncoherentInstances #-} -- necessary, unfortunately
module Uniplate where
import GHC.Generics
--------------------------------------------------------------------------------
-- 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]
default children :: (Representable0 a, Uniplate' (Rep0 a) a) => a -> [a]
children = children' . from0
-- Base types instances
instance Uniplate Char where children _ = []
instance Uniplate Int where children _ = []
instance Uniplate Float where children _ = []
instance Uniplate [a] where
children [] = []
children (_:t) = [t]
setTestOpts(only_compiler_types(['ghc']))
test('Uniplate1', normal, multimod_compile_and_run, ['Main', ''])
\ No newline at end of file
setTestOpts(only_compiler_types(['ghc']))
test('canDoRep0', normal, compile, [''])
test('cannotDoRep0', normal, compile_fail, [''])
test('cannotDoRep1', normal, compile_fail, [''])
test('cannotDoRep2', normal, compile_fail, [''])
{-# LANGUAGE Generics #-}
module ShouldCompile0 where
-- We should be able to generate a generic representation for these types
data A
data B a
data C = C0 | C1
data D a = D0 | D1 { d11 :: a, d12 :: (D a) }
data E a = E0 a (E a) (D a)
{-# LANGUAGE DeriveRepresentable #-}
{-# LANGUAGE ExistentialQuantification #-}
module ShouldFail0 where
import GHC.Generics
-- We do not support existential quantification
data Dynamic = forall a. Dynamic a deriving Representable0
{-# LANGUAGE DeriveRepresentable #-}
module ShouldFail1 where
import GHC.Generics
-- We do not support datatypes with context
data (Show a) => Context a = Context a deriving Representable0
{-# LANGUAGE DeriveRepresentable #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE GADTs #-}
module ShouldFail2 where
import GHC.Generics
-- We do not support GADTs
data Term a where
Int :: Term Int
deriving instance Representable0 (Term a)
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment