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]
|