@@ -0,0 +1,42 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE DefaultSignatures #-}
3+{-# LANGUAGE DeriveAnyClass #-}
4+{-# LANGUAGE DeriveGeneric #-}
5+{-# LANGUAGE FlexibleContexts #-}
6+{-# LANGUAGE MonoLocalBinds #-}
7+{-# LANGUAGE TypeApplications #-}
8+
9+module Main (main) where
10+
11+import Control.Lens hiding (Bifunctor(..))
12+import Control.Monad (void)
13+import Data.Generics.Product
14+import GHC.Generics
15+import Test.HUnit
16+
17+main :: IO ()
18+main = void $ runTestTT $
19+ bimap (* 2) show mytree ~=? mytreeBimapped
20+
21+data Tree a w = Leaf a
22+ | Fork (Tree a w) (Tree a w)
23+ | WithWeight (Tree a w) w
24+ deriving (Show, Eq, Generic, Bifunctor)
25+
26+mytree :: Tree Int Int
27+mytree = Fork (WithWeight (Leaf 42) 1)
28+ (WithWeight (Fork (Leaf 88) (Leaf 37)) 2)
29+
30+mytreeBimapped :: Tree Int String
31+mytreeBimapped = Fork (WithWeight (Leaf 84) "1")
32+ (WithWeight (Fork (Leaf 176) (Leaf 74)) "2")
33+
34+-- Derivable Bifunctor
35+class Bifunctor p where
36+ bimap :: (a -> c) -> (b -> d) -> p a b -> p c d
37+
38+ default bimap ::
39+ ( HasParam 0 (p a b) (p a d) b d
40+ , HasParam 1 (p a d) (p c d) a c
41+ ) => (a -> c) -> (b -> d) -> p a b -> p c d
42+ bimap f g s = s & param @0 %~ g & param @1 %~ f