Mercurial > hg > Members > atton > delta_monad

comparison delta.hs @ 57:dfcd72dc697e

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
ReDefine Delta used non-empty-list for infinite changes
author Yasutaka Higa <e115763@ie.u-ryukyu.ac.jp>
date Sat, 22 Nov 2014 12:29:32 +0900
parents 1e6fecb54f1f
children 1229ee398567
comparison
equal deleted inserted replaced
56:bfb6be9a689d 57:dfcd72dc697e
1 import Control.Applicative 1 import Control.Applicative
2 import Data.Numbers.Primes -- $ cabal install primes 2 import Data.Numbers.Primes -- $ cabal install primes
3 3
4 type DeltaLog = [String] 4 data Delta a = Mono a | Delta a (Delta a) deriving Show
5
6 data Delta a = Mono DeltaLog a | Delta DeltaLog a (Delta a) deriving Show
7
8 logAppend :: DeltaLog -> Delta a -> Delta a
9 logAppend l (Mono lx x) = Mono (l ++ lx) x
10 logAppend l (Delta lx x d) = Delta (l ++ lx) x (logAppend l d)
11 5
12 deltaAppend :: Delta a -> Delta a -> Delta a 6 deltaAppend :: Delta a -> Delta a -> Delta a
13 deltaAppend (Mono lx x) d = Delta lx x d 7 deltaAppend (Mono x) d = Delta x d
14 deltaAppend (Delta lx x d) ds = Delta lx x (deltaAppend d ds) 8 deltaAppend (Delta x d) ds = Delta x (deltaAppend d ds)
15 9
16 headDelta :: Delta a -> Delta a 10 headDelta :: Delta a -> Delta a
17 headDelta d@(Mono _ _) = d 11 headDelta d@(Mono _) = d
18 headDelta (Delta lx x _) = Mono lx x 12 headDelta (Delta x _) = Mono x
19 13
20 tailDelta :: Delta a -> Delta a 14 tailDelta :: Delta a -> Delta a
21 tailDelta d@(Mono _ _) = d 15 tailDelta d@(Mono _) = d
22 tailDelta (Delta _ _ ds) = ds 16 tailDelta (Delta _ ds) = ds
23 17
24 instance Functor Delta where 18 instance Functor Delta where
25 fmap f (Mono lx x) = Mono lx (f x) 19 fmap f (Mono x) = Mono (f x)
26 fmap f (Delta lx x d) = Delta lx (f x) (fmap f d) 20 fmap f (Delta x d) = Delta (f x) (fmap f d)
27 21
28 instance Applicative Delta where 22 instance Applicative Delta where
29 pure f = Mono [] f 23 pure f = Mono f
30 (Mono lf f) <*> (Mono lx x) = Mono (lf ++ lx) (f x) 24 (Mono f) <*> (Mono x) = Mono (f x)
31 df@(Mono lf f) <*> (Delta lx x d) = Delta (lf ++ lx) (f x) (df <*> d) 25 df@(Mono f) <*> (Delta x d) = Delta (f x) (df <*> d)
32 (Delta lf f df) <*> d@(Mono lx x) = Delta (lf ++ lx) (f x) (df <*> d) 26 (Delta f df) <*> d@(Mono x) = Delta (f x) (df <*> d)
33 (Delta lf f df) <*> (Delta lx x d) = Delta (lf ++ lx) (f x) (df <*> d) 27 (Delta f df) <*> (Delta x d) = Delta (f x) (df <*> d)
34 28
35 29
36 mu :: Delta (Delta a) -> Delta a
37 mu (Mono ld d) = logAppend ld d
38 mu (Delta ld d ds) = (logAppend ld $ headDelta d) `deltaAppend` (mu $ fmap tailDelta ds)
39
40 instance Monad Delta where 30 instance Monad Delta where
41 return x = Mono [] x 31 return x = Mono x
42 d >>= f = mu $ fmap f d 32 (Mono x) >>= f = f x
33 (Delta x d) >>= f = (headDelta (f x)) `deltaAppend` (d >>= (tailDelta . f))
43 34
44 returnS :: (Show s) => s -> Delta s 35 returnS :: (Show s) => s -> Delta s
45 returnS x = Mono [(show x)] x 36 returnS x = Mono x
46 37
47 returnSS :: (Show s) => s -> s -> Delta s 38 returnSS :: (Show s) => s -> s -> Delta s
48 returnSS x y = (returnS x) `deltaAppend` (returnS y) 39 returnSS x y = (returnS x) `deltaAppend` (returnS y)
49 40
50 41