about summary refs log tree commit diff
path: root/scratch/haskell-programming-from-first-principles/traversable.hs
blob: 5dc4ea411bc2956491f58333859db54afac8b0b6 (plain) (blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
module TraversableScratch where

import qualified Data.Foldable as F

import Test.QuickCheck

newtype Identity a = Identity a
  deriving (Eq, Ord, Show)

instance Functor Identity where
  fmap f (Identity x) = Identity (f x)

instance Foldable Identity where
  foldMap f (Identity x) = f x

instance Traversable Identity where
  traverse f (Identity x) = Identity <$> f x

--------------------------------------------------------------------------------

data Optional a
  = Nada
  | Some a
  deriving (Eq, Show)

instance Functor Optional where
  fmap f Nada = Nada
  fmap f (Some x) = Some (f x)

instance Foldable Optional where
  foldMap f Nada = mempty
  foldMap f (Some x) = f x

instance Traversable Optional where
  traverse f Nada = pure Nada
  traverse f (Some x) = Some <$> f x

--------------------------------------------------------------------------------

data List a = Nil | Cons a (List a) deriving (Eq, Show)

instance Functor List where
  fmap _ Nil = Nil
  fmap f (Cons x xs) = Cons (f x) (fmap f xs)

instance Foldable List where
  foldMap f Nil = mempty
  foldMap f (Cons x xs) = mappend (f x) (foldMap f xs)

instance Traversable List where
  sequenceA Nil = pure Nil
  sequenceA (Cons x xs) = Cons <$> x <*> sequenceA xs

--------------------------------------------------------------------------------

data Three a b c = Three a b c
  deriving (Eq, Show)

instance Functor (Three a b) where
  fmap f (Three x y z) = Three x y (f z)

instance Foldable (Three a b) where
  foldMap f (Three _ _ z) = f z

instance Traversable (Three a b) where
  sequenceA (Three x y z) = (\z' -> Three x y z') <$> z

--------------------------------------------------------------------------------

data Pair a b = Pair a b
  deriving (Eq, Show)

instance Functor (Pair a) where
  fmap f (Pair x y) = Pair x (f y)

instance Foldable (Pair a) where
  foldMap f (Pair x y) = f y

instance Traversable (Pair a) where
  sequenceA (Pair x y) = (\y' -> Pair x y') <$> y

--------------------------------------------------------------------------------

data Big a b = Big a b b
  deriving (Eq, Show)

instance Functor (Big a) where
  fmap f (Big x y z) = Big x (f y) (f z)

instance Foldable (Big a) where
  foldMap f (Big x y z) = f y <> f z

instance Traversable (Big a) where
  sequenceA (Big x y z) = (\y' z' -> Big x y' z') <$> y <*> z

--------------------------------------------------------------------------------

data Bigger a b = Bigger a b b b
  deriving (Eq, Show)

instance Functor (Bigger a) where
  fmap f (Bigger w x y z) = Bigger w (f x) (f y) (f z)

instance Foldable (Bigger a) where
  foldMap f (Bigger w x y z) = f x <> f y <> f z

instance Traversable (Bigger a) where
  sequenceA (Bigger w x y z) = (\x' y' z' -> Bigger w x' y' z') <$> x <*> y <*> z

--------------------------------------------------------------------------------

data Tree a
  = Empty
  | Leaf a
  | Node (Tree a) a (Tree a)
  deriving (Eq, Show)

instance Functor Tree where
  fmap f Empty = Empty
  fmap f (Leaf x) = Leaf (f x)
  fmap f (Node lhs x rhs) = Node (fmap f lhs) (f x) (fmap f rhs)

instance Foldable Tree where
  foldMap f Empty = mempty
  foldMap f (Leaf x) = f x
  foldMap f (Node lhs x rhs) = (foldMap f lhs) <> (f x) <> (foldMap f rhs)

instance Traversable Tree where
  sequenceA Empty = pure Empty
  sequenceA (Leaf x) = Leaf <$> x
  sequenceA (Node lhs x rhs) = Node <$> sequenceA lhs <*> x <*> sequenceA rhs