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
|
{-# OPTIONS_GHC -fglasgow-exts #-}
-----------------------------------------------------------------------------
-- |
-- Module : Control.Arrow.Transformer.Static
-- Copyright : (c) Ross Paterson 2003
-- License : BSD-style (see the LICENSE file in the distribution)
--
-- Maintainer : ross@soi.city.ac.uk
-- Stability : experimental
-- Portability : non-portable (multi-parameter type classes)
--
-- Arrow transformer adding static information.
module Control.Arrow.Transformer.Static(
StaticArrow, StaticMonadArrow, StaticArrowArrow,
wrapA, unwrapA, wrapM, unwrapM,
) where
import Control.Applicative
import Control.Arrow hiding (pure)
import Control.Arrow.Internals
import Control.Arrow.Operations
import Control.Arrow.Transformer
import Control.Monad
-- | An arrow type that augments the underlying arrow with static information.
newtype StaticArrow f a b c = SA (f (a b c))
instance (Arrow a, Applicative f) => ArrowTransformer (StaticArrow f) a where
lift f = SA (pure f)
instance (Arrow a, Applicative f) => Arrow (StaticArrow f a) where
arr f = SA (pure (arr f))
SA f >>> SA g = SA ((>>>) <$> f <*> g)
first (SA f) = SA (first <$> f)
-- The following promotions follow directly from the arrow transformer.
instance (ArrowZero a, Applicative f) => ArrowZero (StaticArrow f a) where
zeroArrow = lift zeroArrow
instance (ArrowCircuit a, Applicative f) => ArrowCircuit (StaticArrow f a) where
delay x = lift (delay x)
instance (ArrowError ex a, Applicative f) => ArrowError ex (StaticArrow f a) where
raise = lift raise
handle (SA f) (SA h) = SA (handle <$> f <*> h)
tryInUnless (SA f) (SA s) (SA h) = SA (tryInUnless <$> f <*> s <*> h)
instance (ArrowReader r a, Applicative f) => ArrowReader r (StaticArrow f a) where
readState = lift readState
newReader (SA f) = SA (newReader <$> f)
instance (ArrowState s a, Applicative f) => ArrowState s (StaticArrow f a) where
fetch = lift fetch
store = lift store
instance (ArrowWriter w a, Applicative f) => ArrowWriter w (StaticArrow f a) where
write = lift write
newWriter (SA f) = SA (newWriter <$> f)
-- Classes that are preserved.
instance (ArrowChoice a, Applicative f) => ArrowChoice (StaticArrow f a) where
left (SA f) = SA (left <$> f)
-- ArrowApply is generally not preserved.
instance (ArrowLoop a, Applicative f) => ArrowLoop (StaticArrow f a) where
loop (SA f) = SA (loop <$> f)
instance (ArrowPlus a, Applicative f) => ArrowPlus (StaticArrow f a) where
SA f <+> SA g = SA ((<+>) <$> f <*> g)
-- promotions
instance (ArrowAddStream a a', Applicative f) =>
ArrowAddStream (StaticArrow f a) (StaticArrow f a') where
liftStream (SA f) = SA (liftStream <$> f)
elimStream (SA f) = SA (elimStream <$> f)
instance (ArrowAddState s a a', Applicative f) =>
ArrowAddState s (StaticArrow f a) (StaticArrow f a') where
liftState (SA f) = SA (liftState <$> f)
elimState (SA f) = SA (elimState <$> f)
instance (ArrowAddReader r a a', Applicative f) =>
ArrowAddReader r (StaticArrow f a) (StaticArrow f a') where
liftReader (SA f) = SA (liftReader <$> f)
elimReader (SA f) = SA (elimReader <$> f)
instance (ArrowAddWriter w a a', Applicative f) =>
ArrowAddWriter w (StaticArrow f a) (StaticArrow f a') where
liftWriter (SA f) = SA (liftWriter <$> f)
elimWriter (SA f) = SA (elimWriter <$> f)
instance (ArrowAddError ex a a', Applicative f) =>
ArrowAddError ex (StaticArrow f a) (StaticArrow f a') where
liftError (SA f) = SA (liftError <$> f)
elimError (SA f) (SA h) = SA (elimError <$> f <*> h)
-- | A special case.
type StaticArrowArrow a s = StaticArrow (WrappedArrow a s)
wrapA :: (Arrow a, Arrow a') => a s (a' b c) -> StaticArrowArrow a s a' b c
wrapA x = SA (WrapArrow x)
unwrapA :: (Arrow a, Arrow a') => StaticArrowArrow a s a' b c -> a s (a' b c)
unwrapA (SA (WrapArrow x)) = x
-- | A special case is monads applied to the whole arrow, in contrast to
-- 'Kleisli' arrows, in which the monad is applied to the output.
type StaticMonadArrow m = StaticArrow (WrappedMonad m)
wrapM :: (Monad m, Arrow a) => m (a b c) -> StaticMonadArrow m a b c
wrapM x = SA (WrapMonad x)
unwrapM :: (Monad m, Arrow a) => StaticMonadArrow m a b c -> m (a b c)
unwrapM (SA (WrapMonad x)) = x
|
