Mercurial > hg > Members > atton > similar_monad

comparison similar.hs @ 17:279ebcf670c4

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Define Similar as Applicative
author Yasutaka Higa <e115763@ie.u-ryukyu.ac.jp>
date Tue, 09 Sep 2014 16:21:22 +0900
parents 4b315cf0edb9
children c77397d0677f
comparison
equal deleted inserted replaced
16:4b315cf0edb9 17:279ebcf670c4
1 import Control.Applicative
2
1 data Similar a = Single a | Similar a (Similar a) deriving (Show) 3 data Similar a = Single a | Similar a (Similar a) deriving (Show)
2 4
3 instance (Eq a) => Eq (Similar a) where 5 instance (Eq a) => Eq (Similar a) where
4 s == ss = (same s) == (same ss) 6 s == ss = (same s) == (same ss)
5 7
16 similar (Similar x s) ss = Similar x (similar s ss) 18 similar (Similar x s) ss = Similar x (similar s ss)
17 19
18 instance Functor Similar where 20 instance Functor Similar where
19 fmap f (Single a) = Single (f a) 21 fmap f (Single a) = Single (f a)
20 fmap f (Similar a s) = Similar (f a) (fmap f s) 22 fmap f (Similar a s) = Similar (f a) (fmap f s)
23
24 instance Applicative Similar where
25 pure = Single
26 (Single f) <*> s = fmap f s
27 (Similar f s) <*> ss = similar (fmap f ss) (s <*> ss)
21 28
22 mu :: (Similar (Similar a)) -> Similar a 29 mu :: (Similar (Similar a)) -> Similar a
23 mu (Single s) = s 30 mu (Single s) = s
24 mu (Similar s ss) = similar s (mu ss) 31 mu (Similar s ss) = similar s (mu ss)
25 32
55 *Main> same $ fmap same $ fmap (fmap double) (fmap (plusTwo ) (Single 1)) 62 *Main> same $ fmap same $ fmap (fmap double) (fmap (plusTwo ) (Single 1))
56 *** Exception: same 63 *** Exception: same
57 *Main> same $ fmap same $ fmap (fmap double) (fmap (plusTwo ) (Single 2)) 64 *Main> same $ fmap same $ fmap (fmap double) (fmap (plusTwo ) (Single 2))
58 Single 8 65 Single 8
59 66
67 - Similar as Applicative Functor
68 *Main> Single (\x -> x * x) <*> Single 100
69 Single 10000
70 *Main> Similar (\x -> x * x) (Single (\x -> x * 3)) <*> Single 100
71 Similar 10000 (Single 300)
72 *Main> Similar (\x -> x * x) (Single (\x -> x * 3)) <*> (Similar 100 (Single 200))
73 Similar 10000 (Similar 40000 (Similar 300 (Single 600)))
74
60 - Similar as Monad 75 - Similar as Monad
61 *Main> return 100 >>= double >>= twicePlus 76 *Main> return 100 >>= double >>= twicePlus
62 Similar 400 (Single 400) 77 Similar 400 (Single 400)
63 *Main> return 100 >>= double >>= twicePlus >>= plusTwo 78 *Main> return 100 >>= double >>= twicePlus >>= plusTwo
64 Similar 402 (Similar 800 (Similar 402 (Single 800))) 79 Similar 402 (Similar 800 (Similar 402 (Single 800)))