Remove the type-checking knot.
[ghc.git] / testsuite / tests / polykinds / MonoidsTF.hs
1 -- From a blog post: http://www.jonmsterling.com/posts/2012-01-12-unifying-monoids-and-monads-with-polymorphic-kinds.html
2
3 {-# LANGUAGE PolyKinds #-}
4 {-# LANGUAGE MultiParamTypeClasses #-}
5 {-# LANGUAGE FlexibleInstances, FlexibleContexts #-}
6 {-# LANGUAGE UndecidableInstances #-}
7 {-# LANGUAGE FunctionalDependencies #-}
8 {-# LANGUAGE RankNTypes #-}
9 {-# LANGUAGE TypeOperators #-}
10 {-# LANGUAGE DeriveFunctor #-}
11 {-# LANGUAGE UnicodeSyntax #-}
12 {-# LANGUAGE TypeFamilies #-}
13
14 module Main where
15
16 import Data.Kind
17 import Control.Monad (Monad(..), join, ap, liftM)
18 import Data.Monoid (Monoid(..))
19 import Data.Semigroup (Semigroup(..))
20
21 -- First we define the type class Monoidy:
22
23 class Monoidy (to :: k0 -> k1 -> Type) (m :: k1) where
24 type MComp to m :: k1 -> k1 -> k0
25 type MId to m :: k0
26 munit :: MId to m `to` m
27 mjoin :: MComp to m m m `to` m
28
29 -- We use functional dependencies to help the typechecker understand that
30 -- m and ~> uniquely determine comp (times) and id.
31
32 -- This kind of type class would not have been possible in previous
33 -- versions of GHC; with the new kind system, however, we can abstract
34 -- over kinds!2 Now, let’s create types for the additive and
35 -- multiplicative monoids over the natural numbers:
36
37 newtype Sum a = Sum a deriving Show
38 newtype Product a = Product a deriving Show
39 instance Num a ⇒ Monoidy () (Sum a) where
40 type MComp () (Sum a) = (,)
41 type MId () (Sum a) = ()
42 munit _ = Sum 0
43 mjoin (Sum x, Sum y) = Sum $ x + y
44
45 instance Num a ⇒ Monoidy () (Product a) where
46 type MComp () (Product a) = (,)
47 type MId () (Product a) = ()
48 munit _ = Product 1
49 mjoin (Product x, Product y) = Product $ x * y
50
51 -- It will be slightly more complicated to make a monadic instance with
52 -- Monoidy. First, we need to define the identity functor, a type for
53 -- natural transformations, and a type for functor composition:
54
55 data Id α = Id { runId :: α } deriving Functor
56
57 -- A natural transformation (Λ f g α. (f α) → (g α)) may be encoded in Haskell as follows:
58
59 data NT f g = NT { runNT :: ∀ α. f α → g α }
60
61 -- Functor composition (Λ f g α. f (g α)) is encoded as follows:
62
63 data FC f g α = FC { runFC :: f (g α) }
64
65 -- Now, let us define some type T which should be a monad:
66
67 data Wrapper a = Wrapper { runWrapper :: a } deriving (Show, Functor)
68 instance Monoidy NT Wrapper where
69 type MComp NT Wrapper = FC
70 type MId NT Wrapper = Id
71 munit = NT $ Wrapper . runId
72 mjoin = NT $ runWrapper . runFC
73
74
75 -- With these defined, we can use them as follows:
76
77 test1 = do { print (mjoin (munit (), Sum 2))
78 -- Sum 2
79 ; print (mjoin (Product 2, Product 3))
80 -- Product 6
81 ; print (runNT mjoin $ FC $ Wrapper (Wrapper "hello, world"))
82 -- Wrapper {runWrapper = "hello, world" }
83 }
84
85 -- We can even provide a special binary operator for the appropriate monoids as follows:
86
87 (<+>) :: (Monoidy () m, MId () m ~ (), MComp () m ~ (,))
88 ⇒ m → m → m
89 (<+>) = curry mjoin
90
91 test2 = print (Sum 1 <+> Sum 2 <+> Sum 4) -- Sum 7
92
93 -- Now, all the extra wrapping that Haskell requires for encoding this is
94 -- rather cumbersome in actual use. So, we can give traditional Monad and
95 -- Monoid instances for instances of Monoidy:
96
97 instance (MId () m ~ (), MComp () m ~ (,), Monoidy () m)
98 ⇒ Semigroup m where
99 (<>) = curry mjoin
100
101 instance (MId () m ~ (), MComp () m ~ (,), Monoidy () m)
102 ⇒ Monoid m where
103 mempty = munit ()
104
105 instance Applicative Wrapper where
106 pure = return
107 (<*>) = ap
108
109 instance Monad Wrapper where
110 return x = runNT munit $ Id x
111 x >>= f = runNT mjoin $ FC (f `fmap` x)
112
113 -- And so the following works:
114
115 test3
116 = do { print (mappend mempty (Sum 2))
117 -- Sum 2
118 ; print (mappend (Product 2) (Product 3))
119 -- Product 6
120 ; print (join $ Wrapper $ Wrapper "hello")
121 -- Wrapper {runWrapper = "hello" }
122 ; print (Wrapper "hello, world" >>= return)
123 -- Wrapper {runWrapper = "hello, world" }
124 }
125
126 main = test1 >> test2 >> test3