1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
|
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module CustomChildren
( customTypesTest
) where
import GHC.Generics
import Data.Generics.Product
import Test.HUnit
import Data.Generics.Internal.VL.Lens
import Data.Generics.Labels ()
import Data.Kind
-- Opaque has no Generic instance
data Opaque = Opaque String
deriving (Show, Eq)
-- Hide does have a Generic instance, but we want to hide its contents
-- from the traversal
data Hide = Hide String
deriving (Show, Generic, Eq)
-- We first define a symbol for the custom traversal
data Custom
type instance Children Custom a = ChildrenCustom a
type family ChildrenCustom (a :: Type) where
ChildrenCustom Opaque = '[String] -- here we state explicitly that Opaque contains a String
ChildrenCustom Hide = '[] -- and hide the contents of Hide
ChildrenCustom a = Children ChGeneric a -- for the rest, we defer to the generic children
-- We define the traversal of Opaque like so:
instance HasTypesCustom Custom Opaque Opaque String String where
typesCustom f (Opaque str) = Opaque <$> f str
customTypesTest1 :: Test
customTypesTest1
= TestCase (assertEqual "foo" (over (typesUsing @Custom @String) (++ "!") original) expected)
where original = (Opaque "foo", Hide "bar")
expected = (Opaque "foo!", Hide "bar") -- only Opaque's String gets modified
customTypesTest2 :: Test
customTypesTest2
= TestCase (assertEqual "foo" (over (typesUsing @Custom @String) (++ "!") original) expected)
where original = Opaque "foo"
expected = Opaque "foo!"
customTypesTest3 :: Test
customTypesTest3
= TestCase (assertEqual "foo" (over (typesUsing @Custom @String) (++ "!") original) expected)
where original = Hide "foo"
expected = Hide "foo"
customTypesTest :: Test
customTypesTest = TestList [customTypesTest1, customTypesTest2, customTypesTest3]
|
