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
|
{-# 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
instance MonadFix Maybe where
mfix f = let a = f (unJust a) in a
where unJust (Just x) = x
unJust Nothing = errorWithoutStackTrace "mfix Maybe: Nothing"
instance MonadFix [] where
mfix f = case fix (f . head) of
[] -> []
(x:_) -> x : mfix (tail . f)
instance MonadFix IO where
mfix = fixIO
instance MonadFix ((->) r) where
mfix f = \ r -> let a = f a r in a
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"
instance MonadFix (ST s) where
mfix = fixST
-- Instances of Data.Monoid wrappers
instance MonadFix Dual where
mfix f = Dual (fix (getDual . f))
instance MonadFix Sum where
mfix f = Sum (fix (getSum . f))
instance MonadFix Product where
mfix f = Product (fix (getProduct . f))
instance MonadFix First where
mfix f = First (mfix (getFirst . f))
instance MonadFix Last where
mfix f = Last (mfix (getLast . f))
instance MonadFix f => MonadFix (Alt f) where
mfix f = Alt (mfix (getAlt . f))
-- Instances for GHC.Generics
instance MonadFix Par1 where
mfix f = Par1 (fix (unPar1 . f))
instance MonadFix f => MonadFix (Rec1 f) where
mfix f = Rec1 (mfix (unRec1 . f))
instance MonadFix f => MonadFix (M1 i c f) where
mfix f = M1 (mfix (unM1. f))
instance (MonadFix f, MonadFix g) => MonadFix (f :*: g) where
mfix f = (mfix (fstP . f)) :*: (mfix (sndP . f))
where
fstP (a :*: _) = a
sndP (_ :*: b) = b
|
