Main.hs at main · stau.space/haskell-trampoline

Very simple implementation of trampolines and CPS in Haskell.
haskell-trampoline / Main.hs
at main 2.5 kB view raw
 1newtype Cont r a = Cont ((a -> r) -> r)
 2
 3instance Functor (Cont r) where
 4    fmap :: (a -> b) -> Cont r a -> Cont r b
 5    fmap f (Cont c) = Cont $ \k -> c $ k . f
 6
 7instance Applicative (Cont r) where
 8    pure :: a -> Cont r a
 9    pure a = Cont $ \k -> k a
10
11    (<*>) :: Cont r (a -> b) -> Cont r a -> Cont r b
12    Cont f <*> Cont v = Cont $ \k -> f (\f' -> v $ k . f')
13
14instance Monad (Cont r) where
15    (>>=) :: Cont r a -> (a -> Cont r b) -> Cont r b
16    Cont x >>= f = Cont $ \k -> x (\a -> let Cont c = f a in c k)
17
18runCont :: Cont r a -> (a -> r) -> r
19runCont (Cont c) = c
20
21evalCont :: Cont a a -> a
22evalCont (Cont c) = c id
23
24callCC :: ((a -> Cont r b) -> Cont r a) -> Cont r a
25callCC f = Cont $ \k -> runCont (f (\x -> Cont $ \_ -> k x)) k
26
27foldrCPS :: (a -> b -> Cont r b) -> b -> [a] -> Cont r b
28foldrCPS f z list = case list of
29    []     -> pure z
30    (x:xs) -> foldrCPS f z xs >>= f x
31
32addCPS :: Num a => a -> a -> Cont r a
33addCPS a b = pure (a + b)
34
35sumCPS :: [Int] -> Int
36sumCPS = evalCont . foldrCPS addCPS 0
37
38data Trampoline a = More (() -> Trampoline a) | Done a
39
40runTrampoline :: Trampoline a -> a
41runTrampoline t = case t of
42    Done a -> a
43    More k -> runTrampoline $ k ()
44
45instance Functor Trampoline where
46    fmap :: (a -> b) -> Trampoline a -> Trampoline b
47    fmap f t = case t of
48        Done a -> pure $ f a
49        More k -> More . const $ f <$> k ()
50
51instance Applicative Trampoline where
52    pure :: a -> Trampoline a
53    pure = Done
54
55    (<*>) :: Trampoline (a -> b) -> Trampoline a -> Trampoline b
56    l <*> r = case (l, r) of
57        (Done f, Done x) -> pure $ f x
58        (More k, Done x) -> More . const $ k () <*> pure x
59        (Done f, More c) -> More . const $ f <$> c ()
60        (More k, More c) -> More . const $ k () <*> c ()
61
62instance Monad Trampoline where
63    (>>=) :: Trampoline a -> (a -> Trampoline b) -> Trampoline b
64    l >>= f = case l of
65        Done a -> f a
66        More k -> More . const $ k () >>= f
67
68foldrT :: (a -> b -> Trampoline b) -> b -> [a] -> Trampoline b
69foldrT f z list = case list of
70    []     -> pure z
71    (x:xs) -> More . const $ foldrT f z xs >>= f x
72
73addT :: Int -> Int -> Trampoline Int
74addT a b = pure (a + b)
75
76sumT :: [Int] -> Int
77sumT = runTrampoline . foldrT addT 0
78
79fibT :: Int -> Trampoline Int
80fibT n = case n of
81    0 -> pure 0
82    1 -> pure 1
83    n -> More . const $ (+) <$> fibT (n - 2) <*> fibT (n - 1)
84
85fib :: Int -> Int
86fib n = case n of
87    0 -> 0
88    1 -> 1
89    n -> fib(n - 1) + fib(n - 2)
90
91main = do
92    print $ fib 48