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
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
|
-----------------------------------------------------------------------------
-- |
-- Module : Control.Sequence
-- Copyright : (c) Ross Paterson 2003
-- License : BSD-style (see the LICENSE file in the distribution)
--
-- Maintainer : ross@soi.city.ac.uk
-- Stability : experimental
-- Portability : portable
--
-- This module describes a structure intermediate between a functor and
-- a monad: it provides pure expressions and sequencing, but no binding.
-- (Technically, a lax monoidal premonad with a weak symmetry condition;
-- if anyone knows the Real Name for these things, please let me know.)
--
-- This interface was introduced for parsers by Niklas Rjemo, because
-- it admits more sharing than the monadic interface. The names here are
-- mostly based on recent parsing work by Doaitse Swierstra.
module Control.Sequence(
Sequence(..),
-- * Lifting
lift1, lift3,
-- * Application of pure functions
(<$>), (<$),
-- * Sequencing
(<*), (*>), (<**>),
-- * Alternatives
Alternative(..),
-- * Instances
ArrowSequence(..), MonadSequence(..)
) where
import Control.Arrow
import Control.Monad
infixl 4 <$>, <$
infixl 4 <*>, <*, *>, <**>
-- | A functor with sequencing.
--
-- Minimal definition: 'lift0' and either 'lift2' or '<*>'.
--
--
-- If the functor is also a monad, define 'lift0' = 'return' and
-- 'lift2' = 'liftM2'.
class Functor f => Sequence f where
-- | Lift a value
lift0 :: a -> f a
-- | Lift a binary function.
-- 'lift0' and 'lift2' should satisfy
--
-- > lift2 f (unit x) v = fmap (\y -> f x y) v
--
-- > lift2 f u (unit y) = fmap (\x -> f x y) u
--
-- > lift2 f u (lift2 g v w) = lift2 ($) (lift2 (\x y z -> f x (g y z))) u v) w)
lift2 :: (a -> b -> c) -> f a -> f b -> f c
lift2 f fa fb = f <$> fa <*> fb
-- | Sequential application.
-- This function should satisfy
--
-- > lift0 f <*> v = fmap f v
--
-- > u <*> lift0 y = fmap ($ y) u
--
-- > u <*> (v <*> w) = (fmap (.) u <*> v) <*> w
(<*>) :: f (a -> b) -> f a -> f b
p <*> q = lift2 ($) p q
-- | Lift a unary function (a synonym for 'fmap')
lift1 :: Sequence f => (a -> b) -> f a -> f b
lift1 = fmap
-- | Lift a ternary function
lift3 :: Sequence f => (a -> b -> c -> d) -> f a -> f b -> f c -> f d
lift3 f fa fb fc = f <$> fa <*> fb <*> fc
-- | Apply a unary function (a synonym for 'fmap')
(<$>) :: Functor f => (a -> b) -> f a -> f b
(<$>) = fmap
-- | Replace the value
(<$) :: Functor f => a -> f b -> f a
(<$) = fmap . const
-- | Sequence, discarding the value of the first argument
(*>) :: Sequence f => f a -> f b -> f b
(*>) = lift2 (const id)
-- | Sequence, discarding the value of the second argument
(<*) :: Sequence f => f a -> f b -> f a
(<*) = lift2 const
-- | A variant of '<*>' with the arguments reversed
(<**>) :: Sequence f => f a -> f (a -> b) -> f b
(<**>) = lift2 (flip ($))
instance Sequence Maybe where
lift0 = Just
lift2 f (Just x) (Just y) = Just (f x y)
lift2 _ _ _ = Nothing
instance Sequence [] where
lift0 x = [x]
lift2 f xs ys = [f x y | x <- xs, y <- ys]
instance Sequence IO where
lift0 = return
lift2 = liftM2
-- | A monoid on sequences
class Sequence f => Alternative f where
-- | The identity of '<|>'
empty :: f a
-- | An associative binary operation
(<|>) :: f a -> f a -> f a
newtype ArrowSequence a b c = ArrowSequence { runArrowSequence :: a b c }
instance Arrow a => Functor (ArrowSequence a s) where
fmap k (ArrowSequence f) = ArrowSequence (f >>> arr k)
instance Arrow a => Sequence (ArrowSequence a s) where
lift0 x = ArrowSequence (arr (const x))
lift2 f (ArrowSequence u) (ArrowSequence v) =
ArrowSequence (u &&& v >>> arr (uncurry f))
instance (ArrowZero a, ArrowPlus a) => Alternative (ArrowSequence a s) where
empty = ArrowSequence zeroArrow
ArrowSequence p <|> ArrowSequence q = ArrowSequence (p <+> q)
-- A special case of this is monads:
newtype MonadSequence m a = MonadSequence { runMonadSequence :: m a }
instance Monad m => Functor (MonadSequence m) where
fmap k (MonadSequence f) = MonadSequence (liftM k f)
instance Monad m => Sequence (MonadSequence m) where
lift0 x = MonadSequence (return x)
lift2 f (MonadSequence u) (MonadSequence v) =
MonadSequence (liftM2 f u v)
instance MonadPlus m => Alternative (MonadSequence m) where
empty = MonadSequence mzero
MonadSequence p <|> MonadSequence q = MonadSequence (p `mplus` q)
|
