File: CustomChildren.hs

package info (click to toggle)
haskell-generic-lens 2.2.2.0-2
  • links: PTS
  • area: main
  • in suites: sid, trixie
  • size: 228 kB
  • sloc: haskell: 1,378; makefile: 6
file content (63 lines) | stat: -rw-r--r-- 2,056 bytes parent folder | download | duplicates (3)
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]