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
|
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
module Main (main) where
import Control.Lens hiding (Bifunctor(..))
import Control.Monad (void)
import Data.Generics.Product
import GHC.Generics
import Test.HUnit
main :: IO ()
main = void $ runTestTT $
bimap (* 2) show mytree ~=? mytreeBimapped
data Tree a w = Leaf a
| Fork (Tree a w) (Tree a w)
| WithWeight (Tree a w) w
deriving (Show, Eq, Generic)
instance Bifunctor Tree where
bimap = gbimap
mytree :: Tree Int Int
mytree = Fork (WithWeight (Leaf 42) 1)
(WithWeight (Fork (Leaf 88) (Leaf 37)) 2)
mytreeBimapped :: Tree Int String
mytreeBimapped = Fork (WithWeight (Leaf 84) "1")
(WithWeight (Fork (Leaf 176) (Leaf 74)) "2")
--------------------------------------------------------------------------------
class Bifunctor p where
bimap :: (a -> c) -> (b -> d) -> p a b -> p c d
gbimap ::
( HasParam 0 (p a b) (p a d) b d
, HasParam 1 (p a d) (p c d) a c
) => (a -> c) -> (b -> d) -> p a b -> p c d
gbimap f g s = s & param @0 %~ g & param @1 %~ f
|
