Mercurial > hg > Members > atton > delta_monad

comparison similar.hs @ 13:88d6897c391a

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Redefine Similar. reject function in data
author Yasutaka Higa <e115763@ie.u-ryukyu.ac.jp>
date Sat, 06 Sep 2014 11:03:34 +0900
parents 158ae705cd16
children 116131b196bb
comparison
equal deleted inserted replaced
12:158ae705cd16 13:88d6897c391a
1 {-# LANGUAGE GADTs #-} 1 data Similar a = Single a | Similar a (Similar a)
2 2
3 data Similar a = (Eq a) => Similar a (a -> a) a 3 same :: (Eq a) => Similar a -> a
4 same (Single x) = x
5 same (Similar x s) = if x == (same s) then x else undefined
4 6
5 instance (Eq a) => Eq (Similar a) where 7 instance (Eq a) => Eq (Similar a) where
6 s == ss = same s == same ss 8 s == ss = (same s) == (same ss)
7 9
8 same :: (Eq a) => Similar a -> a 10 instance Functor Similar where
9 same (Similar x f y) = if (f x) == y then y else undefined 11 fmap f (Single a) = Single (f a)
12 fmap f (Similar a s) = Similar (f a) (fmap f s)
13
14 {-
10 15
11 mu :: (Eq a) => Similar (Similar a) -> Similar a 16 mu :: (Eq a) => Similar (Similar a) -> Similar a
12 mu (Similar a f b) = if ((f a) == b) then b else undefined 17 mu (Similar a f b) = if ((f a) == b) then b else undefined
13
14 class EqFunctor f where
15 eqmap :: (Eq a, Eq b) => (a -> b) -> f a -> f b
16
17 instance EqFunctor Similar where
18 eqmap f s = Similar fs id fs
19 where fs = f $ same s
20
21 class EqMonad m where
22 (>>=) :: (Eq a, Eq b) => m a -> (a -> m b) -> m b
23 return ::(Eq a) => a -> m a
24
25 instance EqMonad Similar where
26 return x = Similar x id x
27 s >>= f = mu (eqmap f s)
28 18
29 similar :: (Eq a) => (a -> a) -> (a -> a) -> a -> a 19 similar :: (Eq a) => (a -> a) -> (a -> a) -> a -> a
30 similar f g x = same $ Similar x g (f x) 20 similar f g x = same $ Similar x g (f x)
31 21
32 22
51 41
52 *Main> same $ Main.return 100 Main.>>= (\x -> Similar x plusTwo $ double x) 42 *Main> same $ Main.return 100 Main.>>= (\x -> Similar x plusTwo $ double x)
53 *** Exception: Prelude.undefined 43 *** Exception: Prelude.undefined
54 -} 44 -}
55 45
46 -}