├── Setup.hs
├── .gitignore
├── ChangeLog.md
├── README.md
├── freer-church.cabal
├── LICENSE
├── tests
    └── example.hs
└── src
    └── Control
        └── Monad
            └── Freer
                └── Church.hs


/Setup.hs:
--------------------------------------------------------------------------------
1 | import Distribution.Simple
2 | main = defaultMain
3 | 


--------------------------------------------------------------------------------
/.gitignore:
--------------------------------------------------------------------------------
1 | *~
2 | dist/
3 | new-dist/
4 | .cabal-sandbox/
5 | cabal.sandbox.config
6 | 


--------------------------------------------------------------------------------
/ChangeLog.md:
--------------------------------------------------------------------------------
1 | # Revision history for freer-church
2 | 
3 | ## 0.0  -- 2016-10-26
4 | 
5 | * First version.
6 | 


--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
 1 | # Church-encoded Freer Monad #
 2 | 
 3 | This Oleg's [Freer monad](http://okmij.org/ftp/Computation/free-monad.html) but Church-encoded.
 4 | 
 5 | - Because it's the Freer monad, `FFC g` is a Monad for any `g` even if it isn't a functor.
 6 | - Because it's Church-encoded, it reassociates left-nested binds: `(m >>= f) >>= g` immediately reassociates to `m >>= \x -> f x >>= g`
 7 | 
 8 | 
 9 | ## It's just continuations ##
10 | 
11 | Start with Oleg's "Freer monad"
12 | 
13 | ```haskell
14 | data Freer g a where
15 |   FPure   :: a -> Freer g a
16 |   FImpure :: g x -> (x -> Freer g a) -> Freer g a
17 | ```
18 | 
19 | Church encode it to get
20 | 
21 | ```haskell
22 | data FFC g a =
23 |   FFC { unFFC :: forall r . (a -> r) -> (forall x . g x -> (x -> r) -> r) -> r }
24 | ```
25 | 
26 | Now flip the two arguments around and note that <code>[Cont](http://hackage.haskell.org/package/transformers-0.5.2.0/docs/Control-Monad-Trans-Cont.html#t:Cont) t b = (b -> t) -> t</code>
27 | 
28 | ```haskell
29 | data FFC g a =
30 |   FFC { unFFC :: forall r . (forall x . g x -> Cont r x) -> Cont r a }
31 | ```
32 | 
33 | So, the Freer monad is just an interpreter for 'g' into the continuation monad.
34 | 


--------------------------------------------------------------------------------
/freer-church.cabal:
--------------------------------------------------------------------------------
 1 | name:                freer-church
 2 | version:             0.0
 3 | synopsis:            Church-encoded Freer monad
 4 | -- description:         
 5 | homepage:            https://github.com/lambdageek/freer-church
 6 | license:             BSD3
 7 | license-file:        LICENSE
 8 | author:              Aleksey Kliger
 9 | maintainer:          aleksey@lambdageek.org
10 | -- copyright:           
11 | category:            Control
12 | build-type:          Simple
13 | extra-source-files:  ChangeLog.md
14 | cabal-version:       >=1.10
15 | 
16 | library
17 |   exposed-modules:     Control.Monad.Freer.Church
18 |   -- other-modules:       
19 |   -- other-extensions:    
20 |   build-depends:       base >=4.8 && <5
21 |                      , transformers >= 0.5 && < 0.6
22 |   hs-source-dirs:      src
23 |   default-language:    Haskell2010
24 |   ghc-options:         -fno-max-relevant-binds
25 | 
26 | test-suite example
27 |   type:                exitcode-stdio-1.0
28 |   default-language:    Haskell2010
29 |   hs-source-dirs:      tests
30 |   main-is:             example.hs
31 |   build-depends:       base >= 4.9 && < 5
32 |                      , free >= 4.12
33 |                      , freer-church
34 |                      , transformers >= 0.5 && < 0.6


--------------------------------------------------------------------------------
/LICENSE:
--------------------------------------------------------------------------------
 1 | Copyright (c) 2016, Aleksey Kliger
 2 | 
 3 | All rights reserved.
 4 | 
 5 | Redistribution and use in source and binary forms, with or without
 6 | modification, are permitted provided that the following conditions are met:
 7 | 
 8 |     * Redistributions of source code must retain the above copyright
 9 |       notice, this list of conditions and the following disclaimer.
10 | 
11 |     * Redistributions in binary form must reproduce the above
12 |       copyright notice, this list of conditions and the following
13 |       disclaimer in the documentation and/or other materials provided
14 |       with the distribution.
15 | 
16 |     * Neither the name of Aleksey Kliger nor the names of other
17 |       contributors may be used to endorse or promote products derived
18 |       from this software without specific prior written permission.
19 | 
20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31 | 


--------------------------------------------------------------------------------
/tests/example.hs:
--------------------------------------------------------------------------------
  1 | {-# language GADTs, RankNTypes, GeneralizedNewtypeDeriving #-}
  2 | 
  3 | import Control.Monad.Free.Church (F (..), retract, hoistF)
  4 | import Control.Monad.Freer.Church
  5 | 
  6 | import Control.Applicative (Alternative (..))
  7 | import Control.Monad (MonadPlus(..), unless, replicateM_)
  8 | import Control.Monad.Trans.State
  9 | import Control.Monad.Trans.Except
 10 | import Control.Monad.Trans.Class (lift)
 11 | 
 12 | import Data.Functor.Identity
 13 | import Data.Function (on)
 14 | 
 15 | -- | The empty type constructor with no values.
 16 | data Empty a
 17 | 
 18 | -- | Ex falso quodlibet.
 19 | vacuous :: Empty a -> b
 20 | vacuous emp = emp `seq` vacuous emp
 21 | 
 22 | instance Functor Empty where
 23 |   fmap _f emp = vacuous emp
 24 | 
 25 | -- | The freer monad of the empty 'Functor' is the 'Identity' monad
 26 | interpEmpty :: FFC Empty a -> Identity a
 27 | interpEmpty = retractFFC . foist phi
 28 |   where
 29 |     phi :: Empty x -> Identity x
 30 |     phi emp = vacuous emp
 31 | 
 32 | f :: Monad m => Int -> m Int
 33 | f 0 = return 1
 34 | f 1 = return 1
 35 | f n = do
 36 |   i <- f (n - 1)
 37 |   j <- f (n - 2)
 38 |   return (i + j)
 39 | 
 40 | data Const b a = Const b
 41 | 
 42 | instance Functor (Const b) where
 43 |   fmap _f (Const b) = Const b
 44 | 
 45 | interpConst :: FFC (Const b) a -> Either b a
 46 | interpConst = retractFFC . foist phi
 47 |   where
 48 |     phi :: Const b x -> Either b x
 49 |     phi (Const b) = Left b
 50 | 
 51 | raiseConst :: b -> FFC (Const b) a
 52 | raiseConst b = eta (Const b)
 53 | 
 54 | data Cont a = Cont { runCont :: forall r . (a -> r) -> r }
 55 | 
 56 | instance Functor Cont where
 57 |   fmap f (Cont c) = Cont (\k -> c (k . f))
 58 | 
 59 | instance Applicative Cont where
 60 |   pure = retCont
 61 |   mf <*> mx = mf >>= \f -> mx >>= (return . f)
 62 | 
 63 | instance Monad Cont where
 64 |   return = retCont
 65 |   (Cont cx) >>= f = Cont (\k -> cx (\x -> runCont (f x) k))
 66 | 
 67 | retCont :: a -> Cont a
 68 | retCont a = Cont (\k -> k a)
 69 | 
 70 | interpretIdentity :: FFC Identity a -> Cont a
 71 | interpretIdentity = retractFFC . foist phi
 72 |   where
 73 |     phi :: Identity x -> Cont x
 74 |     phi (Identity x) = retCont x
 75 | 
 76 | contCont :: (forall r . (a -> r) -> r) -> FFC Identity a
 77 | contCont k = eta (k Identity)
 78 | 
 79 | data Teletype a where
 80 |   ReadTTY :: Teletype Char
 81 |   WriteTTY :: Char -> Teletype ()
 82 | 
 83 | data TeleF next where
 84 |   ReadF :: (Char -> next) -> TeleF next
 85 |   WriteF :: Char -> next -> TeleF next
 86 | 
 87 | instance Functor TeleF where
 88 |   fmap f (ReadF k) = ReadF (f . k)
 89 |   fmap f (WriteF c k) = WriteF c (f k)
 90 | 
 91 | teleTo :: FFC Teletype a -> F TeleF a
 92 | teleTo = retractFFC . foist phi
 93 |             -- F (\ar telek -> p ar (\tty k -> case tty of
 94 |             --                                  ReadTTY -> telek (ReadF k)
 95 |             --                                  WriteTTY c -> telek (WriteF c (k ()))))
 96 |   where
 97 |     phi :: Teletype x -> F TeleF x
 98 |     phi ReadTTY = F (\ar telek -> telek (ReadF ar))
 99 |     phi (WriteTTY c) = F (\ar telek -> telek (WriteF c (ar ())))
100 | 
101 | 
102 | teleFrom :: F TeleF a -> FFC Teletype a
103 | teleFrom = retract . hoistF phi
104 |               -- FFC (\pur imp -> q pur (\telek -> case telek of
105 |               --                                    ReadF k -> imp ReadTTY k
106 |               --                                    WriteF c k -> imp (WriteTTY c) (\() -> k)))
107 |   where
108 |     phi :: TeleF x -> FFC Teletype x
109 |     phi (ReadF k) = fimpure ReadTTY (fpure . k)
110 |     phi (WriteF c k) = fimpure (WriteTTY c) (\() -> pure k)
111 | 
112 | 
113 | ttyIO :: FFC Teletype a -> IO a
114 | ttyIO = retractFFC . foist phi
115 |                 -- p return (\tty -> case tty of
116 |                 --                      ReadTTY -> \k -> getChar >>= k
117 |                 --                      WriteTTY c -> \k -> putChar c >> k ())
118 |   where
119 |     phi :: Teletype x -> IO x
120 |     phi ReadTTY = getChar
121 |     phi (WriteTTY c) = putChar c
122 | 
123 | newtype TapeIn = TapeIn String
124 |   deriving (Show, Eq)
125 | newtype TapeOut = TapeOut ShowS
126 | 
127 | mkTapeOut :: String -> TapeOut
128 | mkTapeOut = TapeOut . showString
129 | 
130 | playOutTape :: TapeOut -> String
131 | playOutTape (TapeOut s) = s ""
132 | 
133 | instance Eq TapeOut where
134 |   (==) = (==) `on` playOutTape
135 | 
136 | instance Show TapeOut where
137 |   showsPrec _ = showString . playOutTape
138 | 
139 | newtype Tapes a = Tapes { unTapes :: ExceptT () (State (TapeIn, TapeOut)) a }
140 |   deriving (Functor, Applicative, Alternative, Monad, MonadPlus)
141 | 
142 | runTapes :: Tapes a -> TapeIn -> (Maybe a, TapeIn, TapeOut)
143 | runTapes (Tapes m) tapeIn = case runState (runExceptT m) (tapeIn, TapeOut id) of
144 |                               (Left (), (tapeIn, tapeOut)) -> (Nothing, tapeIn, tapeOut)
145 |                               (Right a, (tapeIn, tapeOut)) -> (Just a, tapeIn, tapeOut)
146 | 
147 | getTape :: Tapes Char
148 | getTape = Tapes $ do
149 |   (tapeIn, tapeOut) <- lift get
150 |   case tapeIn of
151 |     TapeIn [] -> mzero
152 |     TapeIn (c:cs) -> do
153 |       lift $ put (TapeIn cs, tapeOut)
154 |       return c
155 | 
156 | putTape :: Char -> Tapes ()
157 | putTape c = Tapes $ lift $ modify (\(tapeIn, TapeOut cs) -> (tapeIn, TapeOut (cs . showChar c)))
158 | 
159 | 
160 | ttyTape :: FFC Teletype a -> Tapes a
161 | ttyTape = retractFFC . foist phi -- (FFC p) = p pur imp
162 |   where
163 |     phi :: Teletype x -> Tapes x
164 |     phi ReadTTY = getTape
165 |     phi (WriteTTY c) = putTape c
166 |   -- where
167 |   --   pur :: a -> TapeIn -> (Maybe (a, TapeOut), TapeIn)
168 |   --   pur = \x tape -> (Just (x, TapeOut []), tape)
169 |   --   imp :: Teletype x -> (x -> TapeIn -> (Maybe (a, TapeOut), TapeIn)) -> TapeIn -> (Maybe (a, TapeOut), TapeIn)
170 |   --   imp = \tty -> case tty of
171 |   --                      ReadTTY -> \ k tape -> case tape of
172 |   --                                   TapeIn [] -> (Nothing, TapeIn [])
173 |   --                                   TapeIn (c:cs) -> k c (TapeIn cs)
174 |   --                      WriteTTY c -> \k tape -> case k () tape of
175 |   --                                      (Nothing, tapeIn) -> (Nothing, tapeIn)
176 |   --                                      (Just (ans, TapeOut cs), tapeIn) -> (Just (ans, TapeOut (c:cs)), tapeIn)
177 | {-# INLINE ttyTape #-}
178 | 
179 | readTTY :: FFC Teletype Char
180 | readTTY = eta ReadTTY
181 | 
182 | writeTTY :: Char -> FFC Teletype ()
183 | writeTTY = eta . WriteTTY
184 | 
185 | echo :: Int -> FFC Teletype ()
186 | echo n = replicateM_ n $ do
187 |   c <- readTTY
188 |   writeTTY c
189 | 
190 |   
191 | echo' :: Int -> FFC Teletype ()
192 | echo' = teleFrom . teleTo . echo
193 | 
194 | assertEq :: (Show a, Eq a) => a -> a -> IO ()
195 | assertEq got want =
196 |   unless (got == want) $ fail ("Expected: " ++ show want ++ "\nGot: " ++ show got)
197 | 
198 | echoTape = ttyTape . echo
199 | echoTape' = ttyTape . echo'
200 | 
201 | main = do
202 |   assertEq (interpEmpty (f 10)) 89
203 |   assertEq (runTapes (echoTape 2) (TapeIn "abcd")) (Just (), TapeIn "cd", mkTapeOut "ab")
204 |   assertEq (runTapes (echoTape' 2) (TapeIn "abcd")) (Just (), TapeIn "cd", mkTapeOut "ab")
205 | -- ttyIO (echo 10)
206 | 
207 | 


--------------------------------------------------------------------------------
/src/Control/Monad/Freer/Church.hs:
--------------------------------------------------------------------------------
  1 | -- | Church encoded Freer monad
  2 | --
  3 | -- Based on Oleg's Freer Monad <http://okmij.org/ftp/Computation/free-monad.html> but Chruch encoded.
  4 | {-# language GADTs, RankNTypes #-}
  5 | module Control.Monad.Freer.Church (
  6 |   -- * Derivation
  7 |   -- $derivation
  8 |   
  9 |   -- * Definition
 10 |   FFC (..)
 11 |   , FFCT (..)
 12 |   -- * Operations
 13 |   , eta
 14 |   , eta'
 15 |   , fpure
 16 |   , fpure'
 17 |   , fimpure
 18 |   , fimpure'
 19 |   , foist
 20 |   , foistT
 21 |   , retractFFC
 22 |   , retractFFCT
 23 |     -- * Proofs
 24 |     -- $proofs
 25 |   ) where
 26 | 
 27 | import Control.Monad.Trans.Cont
 28 | import Control.Monad.Trans.Class
 29 | 
 30 | -- $derivation
 31 | --
 32 | -- Start with Oleg's "Freer monad"
 33 | --
 34 | -- @
 35 | -- data Freer g a where
 36 | --   FPure   :: a -> Freer g a
 37 | --   FImpure :: g x -> (x -> Freer g a) -> Freer g a
 38 | -- @
 39 | --
 40 | -- Church encode it to get
 41 | --
 42 | -- @
 43 | -- data FFC g a =
 44 | --   FFC { unFFC :: forall r . (a -> r) -> (forall x . g x -> (x -> r) -> r) -> r }
 45 | -- @
 46 | --
 47 | -- Now flip the two arguments around and note that @'Cont' t b = (b -> t) -> t@
 48 | --
 49 | -- @
 50 | -- data FFC g a =
 51 | --   FFC { unFFC :: forall r . (forall x . g x -> Cont r x) -> Cont r a }
 52 | -- @
 53 | --
 54 | -- So, the Freer monad is just an interpreter for 'g' into the continuation monad.
 55 | 
 56 | -- | The Church-encoded Freer 'Monad'.  For any @g@ (even if it isn't a 'Functor'!) @FFC g@ is a monad.
 57 | --
 58 | -- 
 59 | -- Think of 'FFC' as if it were like @Freer@
 60 | --
 61 | -- @
 62 | -- data Freer g a where
 63 | --   FPure   :: a -> Freer g a
 64 | --   FImpure :: g x -> (x -> Freer g a) -> Freer g a
 65 | -- @
 66 | newtype FFC g a =
 67 |   FFC { unFFC :: forall r . (forall x . g x -> Cont r x) -> Cont r a }
 68 | 
 69 | -- | Freer monad transformer.
 70 | --
 71 | -- Unfolding the definition of 'ContT' this type is precisely <https://hackage.haskell.org/package/free/docs/Control-Monad-Trans-Free-Church.html#t:FT FT>
 72 | --
 73 | newtype FFCT g m a =
 74 |   FFCT { unFFCT :: forall r . (forall x . g x -> ContT r m x) -> ContT r m a}
 75 | 
 76 | runFFC :: FFC g a -> (a -> r) -> (forall x . g x -> (x -> r) -> r) -> r
 77 | runFFC ma pur imp = runCont (unFFC ma (cont . imp)) pur
 78 | 
 79 | runFFCT :: Monad m => FFCT g m a -> (a -> m r) -> (forall x . g x -> (x -> m r) -> m r) -> m r
 80 | runFFCT tma mpur mimp = runContT (unFFCT tma (ContT . mimp)) mpur
 81 | 
 82 | -- | It's a 'Functor' without a constraint on g
 83 | instance Functor (FFC g) where
 84 |   fmap f = \ma -> FFC (\imp -> fmap f (unFFC ma imp))
 85 |   {-# INLINE fmap #-}
 86 | 
 87 | instance Functor (FFCT g m) where
 88 |   fmap f = \tma -> FFCT (\mimp -> fmap f (unFFCT tma mimp))
 89 | 
 90 | -- | Lift a pure value into the Freer monad
 91 | fpure :: a -> FFC g a
 92 | fpure = \a -> FFC (\imp -> pure a)
 93 | {-# INLINE fpure #-}
 94 | 
 95 | -- | Lift a pure value into a Freer monad transformer
 96 | fpure' :: a -> FFCT g m a
 97 | fpure' = \a -> FFCT (\mimp -> pure a)
 98 | {-# INLINE fpure' #-}
 99 | 
100 | -- | Given an operation in @g@ and a continuation returning a monadic
101 | -- computation, sequence the continuation after the operation.
102 | fimpure :: g x -> (x -> FFC g a) -> FFC g a
103 | fimpure = \gx k -> FFC (\imp -> (imp gx) >>= \x -> unFFC (k x) imp)
104 | {-# INLINE fimpure #-}
105 | 
106 | -- | Sequence an operation in @g@ to be followed by the continuation.
107 | fimpure' :: g x -> (x -> FFCT g m a) -> FFCT g m a
108 | fimpure' = \ gx k -> FFCT (\mimp -> (mimp gx) >>= \x -> unFFCT (k x) mimp)
109 | 
110 | -- | Embed an operation of 'g' into the monad
111 | --
112 | -- @
113 | -- eta eff === fimpure eff fpure
114 | -- @
115 | eta :: g a -> FFC g a
116 | eta = \eff -> FFC (\imp -> imp eff)
117 | {-# INLINE eta #-}
118 | -- proof:
119 | --     eta eff
120 | -- === FFC (\pur imp -> imp eff pur)                                                 by defn
121 | -- === FFC (\pur imp -> imp eff (\x -> pur x))                                       by eta expansion
122 | -- === FFC (\pur imp -> imp eff (\x -> unFFC (FFC (\pur' _ -> pur' x)) pur imp))    by defn & eta expansion
123 | -- === FFC (\pur imp -> imp eff (\x -> unFFC (fpure x) pur imp))                    by defn
124 | -- === fimpure eff fpure                                                             by defn
125 | 
126 | -- | Embed an operation of 'g' into the monad transformer
127 | eta' :: g a -> FFCT g m a
128 | eta' = \eff -> FFCT (\mimp -> mimp eff)
129 | {-# INLINE eta' #-}
130 | 
131 | -- | It's an 'Applicative' without a constraint on g
132 | instance Applicative (FFC g) where
133 |   pure = fpure
134 |   {-# INLINE pure #-}
135 |   (<*>) = \mf mx -> FFC (\imp -> unFFC mf imp <*> unFFC mx imp)
136 |           -- \mf mx -> unFFC mf (unFFC mx (\x f -> (fpure (f x)))
137 |           --                      (\gx k f -> fimpure gx (\x -> (k x f))))
138 |           --          fimpure
139 |   {-# INLINE (<*>) #-}
140 | 
141 | instance Applicative (FFCT g m) where
142 |   pure = fpure'
143 |   (<*>) = \mf mx -> FFCT (\mimp -> unFFCT mf mimp <*> unFFCT mx mimp)
144 | 
145 | 
146 | -- | And it's a 'Monad' without constraints on 'g'
147 | instance Monad (FFC g) where
148 |   return = fpure
149 |   {-# INLINE return #-}
150 |   (>>=) = \mx f -> FFC (\imp -> unFFC mx imp >>= \x -> unFFC (f x) imp)
151 |                    -- unFFC mx f fimpure
152 |   {-# INLINE (>>=) #-}
153 | 
154 | instance Monad (FFCT g m) where
155 |   return = fpure'
156 |   (>>=) = \mx f -> FFCT (\mimp -> unFFCT mx mimp >>= \x -> unFFCT (f x) mimp)
157 | 
158 | instance MonadTrans (FFCT g) where
159 |   lift m = FFCT (\mimp -> lift m)
160 | 
161 | -- | Lift a natural transformation in Hask to a natural transformation on the free monads.
162 | foist :: (forall x . f x -> g x) -> FFC f a -> FFC g a
163 | foist phi = \ma -> -- unFFC ma return (fimpure . phi)
164 |               FFC (\imp -> unFFC ma (imp . phi))
165 | {-# INLINE foist #-}
166 | 
167 | -- | Lift a natural transformation in Hask to a natural transformation on the free monads.
168 | foistT :: (forall x . f x -> g x) -> FFCT f m a -> FFCT g m a
169 | foistT phi = \ma -> FFCT (\mimp -> unFFCT ma (mimp . phi))
170 | 
171 | -- | If @m@ is a monad, we can interpret @FFC m@ in itself
172 | retractFFC :: Monad m => FFC m a -> m a
173 | retractFFC ma = runCont (unFFC ma (\mx -> cont (\f -> mx >>= f))) return
174 | {-# INLINE retractFFC #-}
175 | -- effects are interpreted as themselves:
176 | --
177 | -- @
178 | -- retractFFC (eff ma) === ma
179 | -- @
180 | --
181 | -- @
182 | --     retractFFC (eff ma)
183 | -- === unFFC (FFC (\pur imp -> imp ma pur) return (>>=))   by defns
184 | -- === (>>=) ma return                                      by beta
185 | -- === ma                                                   by right identity law
186 | -- @
187 | --
188 | -- and its a monad homomorphism
189 | --
190 | -- @
191 | -- retractFFC (return a) === return a
192 | -- @
193 | --
194 | -- @
195 | --     unFFC (FFC (\pur _ -> pur a)) return (>>=)   by defns
196 | -- === return a                                      by beta
197 | -- @
198 | --
199 | -- @
200 | -- retractFFC (m >>= f) === retractFFC m >>= retractFFC . f
201 | -- @
202 | --
203 | -- @
204 | --     retractFFC (FFC (\pur imp -> unFFC m (\x -> unFFC (f x) pur imp) imp))            by defn (>>=)
205 | -- === unFFC (FFC (\pur imp -> unFFC m (\x -> unFFC (f x) pur imp) imp)) return (>>=)   by defn retractFFC
206 | -- === unFFC m (\x -> unFFC (f x) return (>>=)) (>>=)                                    by beta
207 | -- ===
208 | -- === ???
209 | -- ===
210 | -- === unFFC m return (>>=) >>= \x -> unFFC (f x) return (>>=)                           by defn retractFFC
211 | --     retractFFC m >>= \x -> retractFFC (f x)
212 | -- @
213 | --
214 | -- stuck here.
215 | 
216 | -- | Interpret the freer monad transformer in itself.
217 | retractFFCT :: (MonadTrans t, Monad (t m), Monad m) => FFCT (t m) m a -> t m a
218 | retractFFCT ma = join . lift $ runContT (unFFCT ma (\tmx -> ContT (\kmtm -> return $ tmx >>= (join . lift . kmtm)))) (return . return)
219 |   where
220 |     join :: Monad m => m (m a) -> m a
221 |     join mmx = mmx >>= id
222 | 
223 | -- $proofs
224 | --
225 | -- == Functor law
226 | --
227 | -- It's a real functor.  (id law left as exercise)
228 | --
229 | -- === Composition
230 | --
231 | -- @fmap f . fmap g === fmap (f . g)@
232 | --
233 | -- @
234 | --     fmap f (fmap g (FFC p))
235 | -- === fmap f (FFC (\\pur imp -> p (pur . g) imp))                         by defn
236 | -- === FFC (\\pur' imp' -> (\\pur imp -> p (pur . g) imp) (pur' . f) imp')  by defn
237 | -- === FFC (\\pur' imp' -> p ((pur' . f) . g) imp')                        by beta
238 | -- === FFC (\\pur' imp' -> p (pur' . (f . g)) imp')                        by assoc-compose
239 | -- === fmap (f . g) (FFC p)                                               by defn
240 | -- @
241 | --
242 | -- == Applicative Laws
243 | --
244 | -- === Identity
245 | -- @
246 | -- pure id \<*\> v === v
247 | -- @
248 | --
249 | -- @
250 | --     pure id \<*\> (FFC vp)
251 | -- === (FFC (\\pur _ -> pur id)) \<*\> (FFC vp)                                    by defn pure
252 | -- === FFC (\\pur' imp' -> (\\pur _ -> pur id) (\\f -> vp (pur' . f) imp') imp')   by defn (\<*\>)
253 | -- === FFC (\\pur' imp' -> (\\f -> vp (pur' . f) imp') id)                        by beta
254 | -- === FFC (\\pur' imp' -> vp (pur' . id) imp')                                  by beta
255 | -- === FFC (\\pur' imp' -> vp pur' imp')                                         by compose-id
256 | -- === FFC vp                                                                   by eta
257 | -- @
258 | --
259 | -- === Homomorphism
260 | --
261 | -- @
262 | -- pure f \<*\> pure x === pure (f x)
263 | -- @
264 | --
265 | -- @
266 | --     pure f <*> pure x
267 | -- === FFC (\\pur _ -> pur f) <*> FFC (\\pur' _-> pur' x)                                                by defn
268 | -- === FFC (\\pur'' imp'' -> (\\pur _ -> pur f) (\\h -> (\\pur' _ -> pur' x) (pur'' . h) imp'') imp'')   by defn
269 | -- === FFC (\\pur'' imp'' -> (\\h -> (\\pur' -> pur' x) (pur'' . h) imp'') f)                           by beta
270 | -- === FFC (\\pur'' imp'' -> (\\pur' _ -> pur' x) (pur'' . f) imp'')                                   by beta
271 | -- === FFC (\\pur'' imp'' -> (pur'' . f) x)                                                           by beta
272 | -- === FFC (\\pur'' _ -> pur'' (f x))                                                                 by defn-compose
273 | -- === pure (f x)                                                                                    by defn
274 | -- @
275 | --
276 | -- === Interchange
277 | --
278 | -- @
279 | -- u \<*\> pure y === pure (\\k -> k y) \<*\> u
280 | -- @
281 | --
282 | -- @
283 | --     FFC ru \<*\> FFC (\\pur _ -> pur y)                                                   by defn
284 | -- === FFC (\\pur' imp' -> ru (\\u -> (\\pur _ -> pur y) (pur' . u) imp') imp')              by defn
285 | -- === FFC (\\pur' imp' -> ru (\\u -> (pur' . u) y) imp')                                   by beta
286 | -- === FFC (\\pur' imp' -> ru (\\u -> pur' (u y)) imp')                                     by beta
287 | -- === FFC (\\pur' imp' -> ru (\\u -> pur' ((\\k -> k y) u)) imp')                           by beta
288 | -- === FFC (\\pur' imp' -> ru (\\u -> (pur' . (\\k -> k y)) u) imp')                         by defn-compose
289 | -- === FFC (\\pur' imp' -> ru (pur' . (\\k -> k y)) imp')                                   by eta
290 | -- === FFC (\\pur' imp' -> (\\f -> ru (pur' . f) imp') (\\k -> k y))                         by beta
291 | -- === FFC (\\pur' imp' -> (\\pur _ -> pur (\\k -> k y)) (\\f -> ru (pur' . f) imp') imp')    by defn
292 | -- === FFC (\\pur _ -> pur (\\k -> k y)) \<*\> FFC ru
293 | -- @
294 | --
295 | -- === Composition
296 | --
297 | -- @
298 | -- pure compose \<*\> u \<*\> v \<*\> w === u \<*\> (v \<*\> w)
299 | -- @
300 | --
301 | -- Please send a Pull Request.  (Proof seems straightforward, but tedious)
302 | --
303 | --
304 | -- == Monad Laws
305 | -- 
306 | -- === Left Identity
307 | --
308 | -- @
309 | -- return a >>= f === f a
310 | -- @
311 | --
312 | -- @
313 | --     FFC (\\pur' _ -> pur' a) >>= f
314 | -- === FFC (\\pur imp -> (\\pur' _ -> pur' a) (\\x -> unFFC (f x) pur imp) imp)   by defn
315 | -- === FFC (\\pur imp -> (\\x -> unFFC (f x) pur imp) a)                         by beta
316 | -- === FFC (\\pur imp -> unFFC (f a) pur imp)                                   by beta
317 | -- === FFC (unFFC (f a))                                                       by eta
318 | -- === f a                                                                      by eta
319 | -- @
320 | --
321 | --
322 | -- === Right Identity
323 | -- 
324 | -- @
325 | -- (FFC mp) >>= return === (FFC mp)
326 | -- @
327 | -- 
328 | -- @
329 | --     FFC mp >>= (\\x -> FFC (\\pur' _ -> pur' x))                                            by defn
330 | -- === FFC (\\pur imp -> mp (\\a -> unFFC ((\\x -> FFC (\\pur' _ -> pur' x)) a) pur imp) imp)   by defn
331 | -- === FFC (\\pur imp -> mp (\\a -> unFFC (FFC (\\pur' _ -> pur' a)) pur imp) imp)             by beta
332 | -- === FFC (\\pur imp -> mp (\\a -> pur a) imp)                                                by beta
333 | -- === FFC (\\pur imp -> mp pur imp)                                                          by eta
334 | -- === FFC mp                                                                                by eta
335 | -- @
336 | --
337 | --
338 | -- === Associativity
339 | --
340 | -- @
341 | -- (FFC mp >>= f) >>= g === (FFC mp) >>= (\\x -> f x >>= g)
342 | -- @
343 | --
344 | -- @
345 | --     FFC (\\pur imp -> unFFC (FFC mp >>= f) (\\a -> unFFC (g a) pur imp) imp)                                                 by defn (>>=) outer
346 | -- === FFC (\\pur imp -> unFFC (FFC (\\pur' imp' -> mp (\\b -> unFFC (f b) pur' imp') imp')) (\\a -> unFFC (g a) pur imp) imp)   by defn (>>= inner)
347 | -- === FFC (\\pur imp -> mp (\\b -> unFFC (f b) (\\a -> unFFC (g a) pur imp)) imp)                                               by beta
348 | -- === FFC (\\pur imp -> mp (\\b -> unFFC (FFC (\\pur' imp' -> unFFC (f b) (\\a -> unFFC (g a) pur' imp') imp')) pur imp) imp)   by beta
349 | -- === FFC (\\pur imp -> mp (\\b -> unFFC (f b >>= g) pur imp) imp)                                                              by defn
350 | -- === FFC (\\pur imp -> mp (\\b -> unFFC ((\\z -> f z >>= g) b) pur imp) imp)                                                    by beta
351 | -- === FFC mp >>= (\\z -> f z >>= g)                                                                                             by defn
352 | -- @
353 | 


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