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
|
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TypeOperators #-}
-----------------------------------------------------------------------------
-- |
-- Module : Control.Monad.Fix
-- Copyright : (c) Andy Gill 2001,
-- (c) Oregon Graduate Institute of Science and Technology, 2002
-- License : BSD-style (see the file libraries/base/LICENSE)
-- Maintainer : libraries@haskell.org
-- Stability : experimental
-- Portability : portable
--
-- Monadic fixpoints.
--
-- For a detailed discussion, see Levent Erkok's thesis,
-- /Value Recursion in Monadic Computations/, Oregon Graduate Institute, 2002.
--
-----------------------------------------------------------------------------
module Control.Monad.Fix (
MonadFix(mfix),
fix
) where
import Data.Either
import Data.Function ( fix )
import Data.Maybe
import Data.Monoid ( Dual(..), Sum(..), Product(..)
, First(..), Last(..), Alt(..) )
import GHC.Base ( Monad, errorWithoutStackTrace, (.) )
import GHC.Generics
import GHC.List ( head, tail )
import GHC.ST
import System.IO
-- | Monads having fixed points with a \'knot-tying\' semantics.
-- Instances of 'MonadFix' should satisfy the following laws:
--
-- [/purity/]
-- @'mfix' ('return' . h) = 'return' ('fix' h)@
--
-- [/left shrinking/ (or /tightening/)]
-- @'mfix' (\\x -> a >>= \\y -> f x y) = a >>= \\y -> 'mfix' (\\x -> f x y)@
--
-- [/sliding/]
-- @'mfix' ('Control.Monad.liftM' h . f) = 'Control.Monad.liftM' h ('mfix' (f . h))@,
-- for strict @h@.
--
-- [/nesting/]
-- @'mfix' (\\x -> 'mfix' (\\y -> f x y)) = 'mfix' (\\x -> f x x)@
--
-- This class is used in the translation of the recursive @do@ notation
-- supported by GHC and Hugs.
class (Monad m) => MonadFix m where
-- | The fixed point of a monadic computation.
-- @'mfix' f@ executes the action @f@ only once, with the eventual
-- output fed back as the input. Hence @f@ should not be strict,
-- for then @'mfix' f@ would diverge.
mfix :: (a -> m a) -> m a
-- Instances of MonadFix for Prelude monads
-- | @since 2.01
instance MonadFix Maybe where
mfix f = let a = f (unJust a) in a
where unJust (Just x) = x
unJust Nothing = errorWithoutStackTrace "mfix Maybe: Nothing"
-- | @since 2.01
instance MonadFix [] where
mfix f = case fix (f . head) of
[] -> []
(x:_) -> x : mfix (tail . f)
-- | @since 2.01
instance MonadFix IO where
mfix = fixIO
-- | @since 2.01
instance MonadFix ((->) r) where
mfix f = \ r -> let a = f a r in a
-- | @since 4.3.0.0
instance MonadFix (Either e) where
mfix f = let a = f (unRight a) in a
where unRight (Right x) = x
unRight (Left _) = errorWithoutStackTrace "mfix Either: Left"
-- | @since 2.01
instance MonadFix (ST s) where
mfix = fixST
-- Instances of Data.Monoid wrappers
-- | @since 4.8.0.0
instance MonadFix Dual where
mfix f = Dual (fix (getDual . f))
-- | @since 4.8.0.0
instance MonadFix Sum where
mfix f = Sum (fix (getSum . f))
-- | @since 4.8.0.0
instance MonadFix Product where
mfix f = Product (fix (getProduct . f))
-- | @since 4.8.0.0
instance MonadFix First where
mfix f = First (mfix (getFirst . f))
-- | @since 4.8.0.0
instance MonadFix Last where
mfix f = Last (mfix (getLast . f))
-- | @since 4.8.0.0
instance MonadFix f => MonadFix (Alt f) where
mfix f = Alt (mfix (getAlt . f))
-- Instances for GHC.Generics
-- | @since 4.9.0.0
instance MonadFix Par1 where
mfix f = Par1 (fix (unPar1 . f))
-- | @since 4.9.0.0
instance MonadFix f => MonadFix (Rec1 f) where
mfix f = Rec1 (mfix (unRec1 . f))
-- | @since 4.9.0.0
instance MonadFix f => MonadFix (M1 i c f) where
mfix f = M1 (mfix (unM1. f))
-- | @since 4.9.0.0
instance (MonadFix f, MonadFix g) => MonadFix (f :*: g) where
mfix f = (mfix (fstP . f)) :*: (mfix (sndP . f))
where
fstP (a :*: _) = a
sndP (_ :*: b) = b
|
