git.iko.soy/generic-lens
on master help sign in
Add Bifunctor derivation test
409f3a3Csongor Kiss
generic-lens.cabal+16
compare with master
unifiedsplit
@@ -100,6 +100,22 @@ test-suite generic-lens-test
100 build-depends: dump-core
100 build-depends: dump-core
101 ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html
101 ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html
102
102
103+test-suite generic-lens-bifunctor
104+ type: exitcode-stdio-1.0
105+ hs-source-dirs: test
106+ main-is: Bifunctor.hs
107+
108+ build-depends: base >= 4.9 && <= 5.0
109+ , generic-lens
110+ , lens
111+ , HUnit
112+
113+ default-language: Haskell2010
114+ ghc-options: -Wall
115+ if flag(dump-core)
116+ build-depends: dump-core
117+ ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html
118+
103test-suite generic-lens-syb-tree
119test-suite generic-lens-syb-tree
104 type: exitcode-stdio-1.0
120 type: exitcode-stdio-1.0
105 hs-source-dirs: test/syb
121 hs-source-dirs: test/syb
test/Bifunctor.hsnew file+42
@@ -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