free 4.7.1 → 4.8

raw patch · 15 files changed

+849/−379 lines, 15 filesdep +eitherdep ~basedep ~mtldep ~transformersPVP ok

version bump matches the API change (PVP)

Dependencies added: either

Dependency ranges changed: base, mtl, transformers

API changes (from Hackage documentation)

Files

• CHANGELOG.markdown +5/−0
• examples/MandelbrotIter.lhs +138/−0
• examples/NewtonCoiter.lhs +99/−0
• examples/RetryTH.hs +86/−0
• examples/Teletype.lhs +104/−0
• examples/ValidationForm.hs +112/−0
• free.cabal +10/−3
• src/Control/Applicative/Free.hs +22/−0
• src/Control/Applicative/Trans/Free.hs +217/−0
• src/Control/Comonad/Trans/Coiter.hs +2/−105
• src/Control/Monad/Free.hs +15/−0
• src/Control/Monad/Free/Church.hs +10/−0
• src/Control/Monad/Free/Class.hs +4/−0
• src/Control/Monad/Free/TH.hs +21/−126
• src/Control/Monad/Trans/Iter.hs +4/−145

@@ -1,3 +1,8 @@+4.8+-----+* Added a `MonadFree` instance for `EitherT` (frrom the `either` package).+* Support for `transformers` 0.4+ 4.7.1 ----- * Added more versions of `cutoff`.

@@ -0,0 +1,138 @@+Compiling to an executable file with the @-O2@ optimization level is recomended.++For example: @ghc -o 'mandelbrot_iter' -O2 MandelbrotIter.lhs ; ./mandelbrot_iter@++> {-# LANGUAGE PackageImports #-}++> import Control.Arrow+> import Control.Monad.Trans.Iter+> import "mtl" Control.Monad.Reader+> import "mtl" Control.Monad.List+> import "mtl" Control.Monad.Identity+> import Control.Monad.IO.Class+> import Data.Complex+> import Graphics.HGL (runGraphics, Window, withPen,+>                      line, RGB (RGB), RedrawMode (Unbuffered, DoubleBuffered), openWindowEx,+>                      drawInWindow, mkPen, Style (Solid))++Some fractals can be defined by infinite sequences of complex numbers. For example,+to render the <https://en.wikipedia.org/wiki/Mandelbrot_set Mandelbrot set>,+the following sequence is generated for each point @c@ in the complex plane:++@+z₀ = c      ++z₁ = z₀² + c       ++z₂ = z₁² + c        ++…+@++If, after some iterations, |z_i| ≥ 2, the point is not in the set. We+can compute if a point is not in the Mandelbrot set this way:++@+ escaped :: Complex Double -> Int+ escaped c = loop 0 0 where+   loop z n = if (magnitude z) >= 2 then n+                                    else loop (z*z + c) (n+1)+@++If @c@ is not in the Mandelbrot set, we get the number of iterations required to+prove that fact. But, if @c@ is in the mandelbrot set, 'escaped' will+run forever.++We can use the 'Iter' monad to delimit this effect. By applying+'delay' before the recursive call, we decompose the computation into+terminating steps.++> escaped :: Complex Double -> Iter Int+> escaped c = loop 0 0 where+>   loop z n = if (magnitude z) >= 2 then return n+>                                    else delay $ loop (z*z + c) (n+1)+>++If we draw each point on a canvas after it escapes, we can get a _negative_+image of the Mandelbrot set. Drawing pixels is a side-effect, so it+should happen inside the IO monad. Also, we want to have an+environment to store the size of the canvas, and the target window.++By using 'IterT', we can add all these behaviours to our non-terminating+computation.++> data Canvas = Canvas { width :: Int, height :: Int, window :: Window }+>+> type FractalM a = IterT (ReaderT Canvas IO) a++Any simple, non-terminating computation can be lifted into a richer environment.++> escaped' :: Complex Double -> IterT (ReaderT Canvas IO) Int+> escaped' = liftIter . escaped++Then, to draw a point, we can just retrieve the number of iterations until it+finishes, and draw it. The color will depend on the number of iterations.++> mandelbrotPoint :: (Int, Int) -> FractalM ()+> mandelbrotPoint p = do+>   c <- scale p+>   n <- escaped' c+>   let color =  if (even n) then RGB   0   0 255 -- Blue+>                            else RGB   0   0 127 -- Darker blue+>   drawPoint color p++The pixels on the screen don't match the region in the complex plane where the+fractal is; we need to map them first. The region we are interested in is+Im z = [-1,1], Re z = [-2,1].++> scale :: (Int, Int) -> FractalM (Complex Double)+> scale (xi,yi) = do+>   (w,h) <- asks $ (fromIntegral . width) &&& (fromIntegral . height)+>   let (x,y) = (fromIntegral xi, fromIntegral yi)+>   let im = (-y + h / 2     ) / (h/2)+>   let re = ( x - w * 2 / 3 ) / (h/2)+>   return $ re :+ im++Drawing a point is equivalent to drawing a line of length one.++> drawPoint :: RGB -> (Int,Int) -> FractalM ()+> drawPoint color p@(x,y) = do+>   w <- asks window+>   let point = line (x,y) (x+1, y+1)+>   liftIO $ drawInWindow w $ mkPen Solid 1 color (flip withPen point)++We may want to draw more than one point. However, if we just sequence the computations+monadically, the first point that is not a member of the set will block the whole+process. We need advance all the points at the same pace, by interleaving the+computations.++> drawMandelbrot :: FractalM ()+> drawMandelbrot = do+>   (w,h) <- asks $ width &&& height+>   let ps = [mandelbrotPoint (x,y) | x <- [0 .. (w-1)], y <- [0 .. (h-1)]]+>   interleave_ ps++To run this computation, we can just use @retract@, which will run indefinitely:++> runFractalM :: Canvas -> FractalM a -> IO a+> runFractalM canvas  = flip runReaderT canvas . retract++Or, we can trade non-termination for getting an incomplete result,+by cutting off after a certain number of steps.++> runFractalM' :: Integer -> Canvas -> FractalM a -> IO (Maybe a)+> runFractalM' n canvas  = flip runReaderT canvas . retract . cutoff n++Thanks to the 'IterT' transformer, we can separate timeout concerns from+computational concerns.++> main :: IO ()+> main = do+>   let windowWidth = 800+>   let windowHeight = 480+>   runGraphics $ do+>     w <- openWindowEx "Mandelbrot" Nothing (windowWidth, windowHeight) DoubleBuffered (Just 1)+>     let canvas = Canvas windowWidth windowHeight w+>     runFractalM' 100 canvas drawMandelbrot+>     putStrLn $ "Fin"+

@@ -0,0 +1,99 @@+Many numerical approximation methods compute infinite sequences of results; each,+hopefully, more accurate than the previous one.++<https://en.wikipedia.org/wiki/Newton's_method Newton's method>+to find zeroes of a function is one such algorithm.++> {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-}++> import Control.Comonad.Trans.Coiter+> import Control.Comonad.Env+> import Control.Applicative+> import Data.Foldable (toList, find)++> data Function = Function {+>   -- Function to find zeroes of+>   function   :: Double -> Double,+>   -- Derivative of the function+>   derivative :: Double -> Double+> }+>+> data Result = Result {+>   -- Estimated zero of the function+>   value  :: Double,+>   -- Estimated distance to the actual zero+>   xerror :: Double,+>   -- How far is value from being an actual zero; that is,+>   -- the difference between @0@ and @f value@+>   ferror :: Double+> } deriving (Show)+>+> data Outlook = Outlook { result :: Result,+>                          -- Whether the result improves in future steps+>                          progress :: Bool } deriving (Show)++To make our lives easier, we will store the problem at hand using the Env+environment comonad.++> type Solution a = CoiterT (Env Function) a++Problems consist of a function and its derivative as the environment, and+an initial value.++> type Problem = Env Function Double++We can express an iterative algorithm using unfold over an initial environment.++> newton :: Problem -> Solution Double+> newton = unfold (\wd ->+>                     let  f  = asks function wd in+>                     let df  = asks derivative wd in+>                     let  x  = extract wd in+>                     x - f x / df x)+>+>++To estimate the error, we look forward one position in the stream. The next value+will be much more precise than the current one, so we can consider it as the+actual result.++We know that the exact value of a function at one of it's zeroes is 0. So,+@ferror@ can be computed exactly as @abs (f a - f 0) == abs (f a)@++> estimateError :: Solution Double -> Result+> estimateError s =+>   let a:a':_ = toList s in+>   let f = asks function s in+>   Result { value = a,+>            xerror = abs $ a - a',+>            ferror = abs $ f a+>          }++To get a sense of when the algorithm is making any progress, we can sample the+future and check if the result improves at all.++> estimateOutlook :: Int -> Solution Result -> Outlook+> estimateOutlook sampleSize solution =+>   let sample = map ferror $ take sampleSize $ tail $ toList solution in+>   let result = extract solution in+>   Outlook { result = result,+>             progress = ferror result > minimum sample }++To compute the square root of @c@, we solve the equation @x*x - c = 0@. We will+stop whenever the accuracy of the result doesn't improve in the next 5 steps.++The starting value for our algorithm is @c@ itself. One could compute a better+estimate, but the algorithm converges fast enough that it's not really worth it.++> squareRoot :: Double -> Maybe Result+> squareRoot c = let problem = flip env c (Function { function = (\x -> x*x - c),+>                                                     derivative = (\x -> 2*x) })+>                in+>                fmap result $ find (not . progress) $+>                  newton problem =>> estimateError =>> estimateOutlook 5++This program will output the result together with the error.++> main :: IO ()+> main = putStrLn $ show $ squareRoot 3+

@@ -0,0 +1,86 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleContexts #-}+module Main where++import Control.Monad+import Control.Monad.Free+import Control.Monad.Free.TH+import Control.Monad.IO.Class+import Control.Monad.Trans.Maybe+import qualified Data.Foldable as F+import Text.Read (readMaybe)++-- | A data type representing basic commands for a retriable eDSL.+data RetryF next where+  -- | Simple output command.+  Output    :: String -> next -> RetryF next+  -- | Get anything readable from input.+  Input     :: Read a => (a -> next) -> RetryF next+  -- | Declare a retriable block.+  WithRetry :: Retry a -> (a -> next) -> RetryF next+  -- | Force retry command (retries innermost retriable block).+  Retry     :: RetryF next++-- | Unfortunately this Functor instance cannot yet be derived+-- automatically by GHC.+instance Functor RetryF where+  fmap f (Output s x) = Output s (f x)+  fmap f (Input g) = Input (f . g)+  fmap f (WithRetry block g) = WithRetry block (f . g)+  fmap _ Retry = Retry++-- | The monad for a retriable eDSL.+type Retry = Free RetryF++-- automacally generate convenience functions+makeFree ''RetryF++-- The following functions have been made available:+--+-- output     :: MonadFree RetryF m => String -> m ()+-- input      :: (MonadFree RetryF m, Read a) => m a+-- withRetry  :: MonadFree RetryF m => Retry a -> m a+-- retry      :: MonadFree RetryF m => m a++-- | We can run a retriable program in any MonadIO.+runRetry :: MonadIO m => Retry a -> m a+runRetry = iterM run+  where+    run :: MonadIO m => RetryF (m a) -> m a++    run (Output s next) = do+      liftIO $ putStrLn s+      next++    run (Input next) = do+      s <- liftIO getLine+      case readMaybe s of+        Just x  -> next x+        Nothing -> fail "invalid input"++    run (WithRetry block next) = do+      -- Here we use+      -- runRetry :: MonadIO m => Retry a -> MaybeT (m a)+      -- to control failure with MaybeT.+      -- We repeatedly run retriable block until we get it to work.+      Just x <- runMaybeT . F.msum $ repeat (runRetry block)+      next x++    run Retry = fail "forced retry"++-- | Sample program.+test :: Retry ()+test = do+  n <- withRetry $ do+    output "Enter any positive number: "+    n <- input+    when (n <= 0) $ do+      output "The number should be positive."+      retry+    return n+  output $ "You've just entered " ++ show (n :: Int)++main :: IO ()+main = runRetry test+

@@ -0,0 +1,104 @@+> {-# LANGUAGE DeriveFunctor, TemplateHaskell, FlexibleContexts #-} --++> import Control.Monad         (mfilter)+> import Control.Monad.Loops   (unfoldM)+> import Control.Monad.Free    (liftF, Free, iterM, MonadFree)+> import Control.Monad.Free.TH (makeFree)+> import Control.Applicative   ((<$>))+> import System.IO             (isEOF)+> import Control.Exception     (catch)+> import System.IO.Error       (ioeGetErrorString)+> import System.Exit           (exitSuccess)++First, we define a data type with the primitive actions of a teleprinter. The+@param@ will stand for the next action to execute.++> type Error = String+>+> data Teletype param = Halt                                  -- Abort (ignore all following instructions)+>                     | NL param                              -- Newline+>                     | Read (Char -> param)                  -- Get a character from the terminal+>                     | ReadOrEOF { onEOF  :: param,+>                                   onChar :: Char -> param } -- GetChar if not end of file+>                     | ReadOrError (Error -> param)+>                                   (Char -> param)           -- GetChar with error code+>                     | param :\^^ String                     -- Write a message to the terminal+>                     | (:%) param String [String]            -- String interpolation+>                     deriving (Functor)++By including a 'makeFree' declaration:++> makeFree ''Teletype++the following functions have been made available:++@+ halt        :: (MonadFree Teletype m) => m a+ nL          :: (MonadFree Teletype m) => m ()+ read        :: (MonadFree Teletype m) => m Char+ readOrEOF   :: (MonadFree Teletype m) => m (Maybe Char)+ readOrError :: (MonadFree Teletype m) => m (Either Error Char)+ (\\^^)      :: (MonadFree Teletype m) => String -> m ()+ (%)         :: (MonadFree Teletype m) => String -> [String] -> m ()+@++To make use of them, we need an instance of 'MonadFree Teletype'. Since 'Teletype' is a+'Functor', we can use the one provided in the 'Control.Monad.Free' package.++> type TeletypeM = Free Teletype++Programs can be run in different ways. For example, we can use the+system terminal through the @IO@ monad.++> runTeletypeIO :: TeletypeM a -> IO a+> runTeletypeIO = iterM run where+>   run :: Teletype (IO a) -> IO a+>   run Halt                      = do+>     putStrLn "This conversation can serve no purpose anymore. Goodbye."+>     exitSuccess+>+>   run (Read f)                  = getChar >>= f+>   run (ReadOrEOF eof f)         = isEOF >>= \b -> if b then eof+>                                                        else getChar >>= f+>+>   run (ReadOrError ferror f)    = catch (getChar >>= f) (ferror . ioeGetErrorString)+>   run (NL rest)                 = putChar '\n' >> rest+>   run (rest :\^^ str)           = putStr str >> rest+>   run ((:%) rest format tokens) = ttFormat format tokens >> rest+>+>   ttFormat :: String -> [String] -> IO ()+>   ttFormat []            _          = return ()+>   ttFormat ('\\':'%':cs) tokens     = putChar '%'  >> ttFormat cs tokens+>   ttFormat ('%':cs)      (t:tokens) = putStr t     >> ttFormat cs tokens+>   ttFormat (c:cs)        tokens     = putChar c    >> ttFormat cs tokens++Now, we can write some helper functions:++> readLine :: TeletypeM String+> readLine = unfoldM $ mfilter (/= '\n') <$> readOrEOF++And use them to interact with the user:++> hello :: TeletypeM ()+> hello = do+>           (\^^) "Hello! What's your name?"; nL+>           name <- readLine+>           "Nice to meet you, %." % [name]; nL+>           halt++We can transform any @TeletypeM@ into an @IO@ action, and run it:++> main :: IO ()+> main = runTeletypeIO hello++@+ Hello! What's your name?+ $ Dave+ Nice to meet you, Dave.+ This conversation can serve no purpose anymore. Goodbye.+@++When specifying DSLs in this way, we only need to define the semantics+for each of the actions; the plumbing of values is taken care of by+the generated monad instance.+

@@ -0,0 +1,112 @@+module Main where++import Control.Applicative+import Control.Applicative.Free+import Control.Monad.State++import Data.Monoid++import Text.Read (readEither)+import Text.Printf++import System.IO++-- | Field reader tries to read value or generates error message.+type FieldReader a = String -> Either String a++-- | Convenient synonym for field name.+type Name = String++-- | Convenient synonym for field help message.+type Help = String++-- | A single field of a form.+data Field a = Field+  { fName     :: Name           -- ^ Name.+  , fValidate :: FieldReader a  -- ^ Pure validation function.+  , fHelp     :: Help           -- ^ Help message.+  }++-- | Validation form is just a free applicative over Field.+type Form = Ap Field++-- | Build a form with a single field.+field :: Name -> FieldReader a -> Help -> Form a+field n f h = liftAp $ Field n f h++-- | Singleton form accepting any input.+string :: Name -> Help -> Form String+string n h = field n Right h++-- | Singleton form accepting anything but mentioned values.+available :: [String] -> Name -> Help -> Form String+available xs n h = field n check h+  where+    check x | x `elem` xs = Left "the value is not available"+            | otherwise   = Right x++-- | Singleton integer field form.+int :: Name -> Form Int+int name = field name readEither "an integer value"++-- | Generate help message for a form.+help :: Form a -> String+help = unlines . runAp_ (\f -> [fieldHelp f])++-- | Get help message for a field.+fieldHelp :: Field a -> String+fieldHelp (Field name _ msg) = printf "  %-15s - %s" name msg++-- | Count fields in a form.+count :: Form a -> Int+count = getSum . runAp_ (\_ -> Sum 1)++-- | Interactive input of a form.+-- Shows progress on each field.+-- Repeats field input until it passes validation.+-- Show help message on empty input.+input :: Form a -> IO a+input m = evalStateT (runAp inputField m) (1 :: Integer)+  where+    inputField f@(Field n g h) = do+      i <- get+      -- get field input with prompt+      x <- liftIO $ do+        putStr $ printf "[%d/%d] %s: " i (count m) n+        hFlush stdout+        getLine+      case words x of+        -- display help message for empty input+        [] -> do+          liftIO . putStrLn $ "help: " ++ h+          inputField f+        -- validate otherwise+        _ -> case g x of+               Right y -> do+                 modify (+ 1)+                 return y+               Left  e -> do+                 liftIO . putStrLn $ "error: " ++ e+                 inputField f++-- | User datatype.+data User = User+  { userName     :: String+  , userFullName :: String+  , userAge      :: Int }+  deriving (Show)++-- | Form for User.+form :: [String] -> Form User+form us = User+  <$> available us  "Username"  "any vacant username"+  <*> string        "Full name" "your full name (e.g. John Smith)"+  <*> int           "Age"++main :: IO ()+main = do+  putStrLn "Creating a new user."+  putStrLn "Please, fill the form:"+  user <- input (form ["bob", "alice"])+  putStrLn $ "Successfully created user \"" ++ userName user ++ "\"!"+

@@ -1,6 +1,6 @@ name:          free category:      Control, Monads-version:       4.7.1+version:       4.8 license:       BSD3 cabal-version: >= 1.10 license-file:  LICENSE@@ -42,6 +42,11 @@   HLint.hs   doc/proof/Control/Comonad/Cofree/*.md   doc/proof/Control/Comonad/Trans/Cofree/*.md+  examples/*.hs+  examples/*.lhs+extra-doc-files:+  examples/*.hs+  examples/*.lhs  source-repository head   type: git@@ -65,16 +70,18 @@     bifunctors           == 4.*,     comonad              == 4.*,     distributive         >= 0.2.1,-    mtl                  >= 2.0.1.0 && < 2.2,+    either               >= 4.1.1,+    mtl                  >= 2.0.1.0 && < 2.3,     prelude-extras       >= 0.4 && < 1,     profunctors          == 4.*,     semigroupoids        == 4.*,     semigroups           >= 0.8.3.1 && < 1,-    transformers         >= 0.2.0   && < 0.4,+    transformers         >= 0.2.0   && < 0.5,     template-haskell     >= 2.7.0.0 && < 3    exposed-modules:     Control.Applicative.Free+    Control.Applicative.Trans.Free     Control.Alternative.Free     Control.Comonad.Cofree     Control.Comonad.Cofree.Class

@@ -28,14 +28,19 @@      Ap(..)   , runAp+  , runAp_   , liftAp   , hoistAp   , retractAp++  -- * Examples+  -- $examples   ) where  import Control.Applicative import Data.Functor.Apply import Data.Typeable+import Data.Monoid  -- | The free 'Applicative' for a 'Functor' @f@. data Ap f a where@@ -52,6 +57,17 @@ runAp _ (Pure x) = pure x runAp u (Ap f x) = flip id <$> u f <*> runAp u x +-- | Perform a monoidal analysis over free applicative value.+--+-- Example:+--+-- @+-- count :: Ap f a -> Int+-- count = getSum . runAp_ (\\_ -> Sum 1)+-- @+runAp_ :: Monoid m => (forall a. f a -> m) -> Ap f b -> m+runAp_ f = getConst . runAp (Const . f)+ instance Functor (Ap f) where   fmap f (Pure a)   = Pure (f a)   fmap f (Ap x y)   = Ap x ((f .) <$> y)@@ -98,3 +114,9 @@ {-# NOINLINE apTyCon #-}  #endif++{- $examples++<examples/ValidationForm.hs Validation form>++-}

@@ -0,0 +1,217 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE GADTs #-}+#if __GLASGOW_HASKELL__ >= 707+{-# LANGUAGE DeriveDataTypeable #-}+#endif+{-# OPTIONS_GHC -Wall #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Applicative.Trans.Free+-- Copyright   :  (C) 2012-2013 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  provisional+-- Portability :  GADTs, Rank2Types+--+-- 'Applicative' functor transformers for free+----------------------------------------------------------------------------+module Control.Applicative.Trans.Free+  (+  -- | Compared to the free monad transformers, they are less expressive. However, they are also more+  -- flexible to inspect and interpret, as the number of ways in which+  -- the values can be nested is more limited.+  --+  -- See <http://paolocapriotti.com/assets/applicative.pdf Free Applicative Functors>,+  -- by Paolo Capriotti and Ambrus Kaposi, for some applications.+    ApT(..)+  , ApF(..)+  , liftApT+  , liftApO+  , runApT+  , runApF+  , runApT_+  , hoistApT+  , hoistApF+  , transApT+  , transApF+  -- * Free Applicative+  , Ap+  , runAp+  , runAp_+  , retractAp+  -- * Free Alternative+  , Alt+  , runAlt+  ) where++import Control.Applicative+import Data.Functor.Apply+import Data.Functor.Identity+import Data.Typeable+import Data.Monoid+import qualified Data.Foldable as F++-- | The free 'Applicative' for a 'Functor' @f@.+data ApF f g a where+  Pure :: a -> ApF f g a+  Ap   :: f a -> ApT f g (a -> b) -> ApF f g b+#if __GLASGOW_HASKELL__ >= 707+  deriving Typeable+#endif++-- | The free 'Applicative' transformer for a 'Functor' @f@ over+-- 'Applicative' @g@.+newtype ApT f g a = ApT { getApT :: g (ApF f g a) }+#if __GLASGOW_HASKELL__ >= 707+  deriving Typeable+#endif++instance Functor g => Functor (ApF f g) where+  fmap f (Pure a) = Pure (f a)+  fmap f (Ap x g) = x `Ap` fmap (f .) g++instance Functor g => Functor (ApT f g) where+  fmap f (ApT g) = ApT (fmap f <$> g)++instance Applicative g => Applicative (ApF f g) where+  pure = Pure+  {-# INLINE pure #-}+  Pure f   <*> y       = fmap f y      -- fmap+  y        <*> Pure a  = fmap ($ a) y  -- interchange+  Ap a f   <*> b       = a `Ap` (flip <$> f <*> ApT (pure b))+  {-# INLINE (<*>) #-}++instance Applicative g => Applicative (ApT f g) where+  pure = ApT . pure . pure+  {-# INLINE pure #-}+  ApT xs <*> ApT ys = ApT ((<*>) <$> xs <*> ys)+  {-# INLINE (<*>) #-}++instance Applicative g => Apply (ApF f g) where+  (<.>) = (<*>)+  {-# INLINE (<.>) #-}++instance Applicative g => Apply (ApT f g) where+  (<.>) = (<*>)+  {-# INLINE (<.>) #-}++instance Alternative g => Alternative (ApT f g) where+  empty = ApT empty+  {-# INLINE empty #-}+  ApT g <|> ApT h = ApT (g <|> h)+  {-# INLINE (<|>) #-}++-- | A version of 'lift' that can be used with no constraint for @f@.+liftApT :: Applicative g => f a -> ApT f g a+liftApT x = ApT (pure (Ap x (pure id)))++-- | Lift an action of the \"outer\" 'Functor' @g a@ to @'ApT' f g a@.+liftApO :: Functor g => g a -> ApT f g a+liftApO g = ApT (Pure <$> g)++-- | Given natural transformations @f ~> h@ and @g . h ~> h@ this gives+-- a natural transformation @ApF f g ~> h@.+runApF :: (Applicative h, Functor g) => (forall a. f a -> h a) -> (forall a. g (h a) -> h a) -> ApF f g b -> h b+runApF _ _ (Pure x) = pure x+runApF f g (Ap x y) = f x <**> runApT f g y++-- | Given natural transformations @f ~> h@ and @g . h ~> h@ this gives+-- a natural transformation @ApT f g ~> h@.+runApT :: (Applicative h, Functor g) => (forall a. f a -> h a) -> (forall a. g (h a) -> h a) -> ApT f g b -> h b+runApT f g (ApT a) = g (runApF f g <$> a)++-- | Perform a monoidal analysis over @'ApT' f g b@ value.+--+-- Examples:+--+-- @+-- height :: ('Functor' g, 'F.Foldable' g) => 'ApT' f g a -> 'Int'+-- height = 'getSum' . runApT_ (\_ -> 'Sum' 1) 'F.maximum'+-- @+--+-- @+-- size :: ('Functor' g, 'F.Foldable' g) => 'ApT' f g a -> 'Int'+-- size = 'getSum' . runApT_ (\_ -> 'Sum' 1) 'F.fold'+-- @+runApT_ :: (Functor g, Monoid m) => (forall a. f a -> m) -> (g m -> m) -> ApT f g b -> m+runApT_ f g = getConst . runApT (Const . f) (Const . g . fmap getConst)++-- | Given a natural transformation from @f@ to @f'@ this gives a monoidal natural transformation from @ApF f g@ to @ApF f' g@.+hoistApF :: Functor g => (forall a. f a -> f' a) -> ApF f g b -> ApF f' g b+hoistApF _ (Pure x) = Pure x+hoistApF f (Ap x y) = f x `Ap` hoistApT f y++-- | Given a natural transformation from @f@ to @f'@ this gives a monoidal natural transformation from @ApT f g@ to @ApT f' g@.+hoistApT :: Functor g => (forall a. f a -> f' a) -> ApT f g b -> ApT f' g b+hoistApT f (ApT g) = ApT (hoistApF f <$> g)++-- | Given a natural transformation from @g@ to @g'@ this gives a monoidal natural transformation from @ApF f g@ to @ApF f g'@.+transApF :: Functor g => (forall a. g a -> g' a) -> ApF f g b -> ApF f g' b+transApF _ (Pure x) = Pure x+transApF f (Ap x y) = x `Ap` transApT f y++-- | Given a natural transformation from @g@ to @g'@ this gives a monoidal natural transformation from @ApT f g@ to @ApT f g'@.+transApT :: Functor g => (forall a. g a -> g' a) -> ApT f g b -> ApT f g' b+transApT f (ApT g) = ApT $ f (transApF f <$> g)++-- | The free 'Applicative' for a 'Functor' @f@.+type Ap f = ApT f Identity++-- | Given a natural transformation from @f@ to @g@, this gives a canonical monoidal natural transformation from @'Ap' f@ to @g@.+--+-- prop> runAp t == retractApp . hoistApp t+runAp :: Applicative g => (forall x. f x -> g x) -> Ap f a -> g a+runAp f = runApT f runIdentity++-- | Perform a monoidal analysis over free applicative value.+--+-- Example:+--+-- @+-- count :: 'Ap' f a -> 'Int'+-- count = 'getSum' . runAp_ (\\_ -> 'Sum' 1)+-- @+runAp_ :: Monoid m => (forall x. f x -> m) -> Ap f a -> m+runAp_ f = runApT_ f runIdentity++-- | Interprets the free applicative functor over f using the semantics for+--   `pure` and `<*>` given by the Applicative instance for f.+--+--   prop> retractApp == runAp id+retractAp :: Applicative f => Ap f a -> f a+retractAp = runAp id++-- | The free 'Alternative' for a 'Functor' @f@.+type Alt f = ApT f []++-- | Given a natural transformation from @f@ to @g@, this gives a canonical monoidal natural transformation from @'Alt' f@ to @g@.+runAlt :: (Alternative g, F.Foldable t) => (forall x. f x -> g x) -> ApT f t a -> g a+runAlt f (ApT xs) = F.foldr (\x acc -> h x <|> acc) empty xs+  where+    h (Pure x) = pure x+    h (Ap x g) = f x <**> runAlt f g++#if __GLASGOW_HASKELL__ < 707+instance (Typeable1 f, Typeable1 g) => Typeable1 (ApT f g) where+  typeOf1 t = mkTyConApp apTTyCon [typeOf1 (f t)] where+    f :: ApT f g a -> g (f a)+    f = undefined++instance (Typeable1 f, Typeable1 g) => Typeable1 (ApF f g) where+  typeOf1 t = mkTyConApp apFTyCon [typeOf1 (f t)] where+    f :: ApF f g a -> g (f a)+    f = undefined++apTTyCon, apFTyCon :: TyCon+#if __GLASGOW_HASKELL__ < 704+apTTyCon = mkTyCon "Control.Applicative.Trans.Free.ApT"+apFTyCon = mkTyCon "Control.Applicative.Trans.Free.ApF"+#else+apTTyCon = mkTyCon3 "free" "Control.Applicative.Trans.Free" "ApT"+apFTyCon = mkTyCon3 "free" "Control.Applicative.Trans.Free" "ApF"+#endif+{-# NOINLINE apTTyCon #-}+{-# NOINLINE apFTyCon #-}+#endif

@@ -40,7 +40,7 @@   , unfold   -- * Cofree comonads   , ComonadCofree(..)-  -- * Example+  -- * Examples   -- $example   ) where @@ -207,111 +207,8 @@ coiterTDataType = mkDataType "Control.Comonad.Trans.Coiter.CoiterT" [coiterTConstr] {-# NOINLINE coiterTDataType #-} --- BEGIN Coiter.lhs {- $example-This is literate Haskell! To run the example, open the source and copy-this comment block into a new file with '.lhs' extension. -Many numerical approximation methods compute infinite sequences of results; each,-hopefully, more accurate than the previous one.--<https://en.wikipedia.org/wiki/Newton's_method Newton's method>-to find zeroes of a function is one such algorithm.- -@ \{\-\# LANGUAGE FlexibleInstances, MultiParamTypeClasses, UndecidableInstances \#\-\} @--> {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-}--> import Control.Comonad.Trans.Coiter-> import Control.Comonad.Env-> import Control.Applicative-> import Data.Foldable (toList, find)--> data Function = Function {->   -- Function to find zeroes of->   function   :: Double -> Double,->   -- Derivative of the function->   derivative :: Double -> Double-> }-> -> data Result = Result {->   -- Estimated zero of the function->   value  :: Double,->   -- Estimated distance to the actual zero->   xerror :: Double,->   -- How far is value from being an actual zero; that is,->   -- the difference between @0@ and @f value@->   ferror :: Double-> } deriving (Show)-> -> data Outlook = Outlook { result :: Result,->                          -- Whether the result improves in future steps->                          progress :: Bool } deriving (Show)--To make our lives easier, we will store the problem at hand using the Env-environment comonad.--> type Solution a = CoiterT (Env Function) a--Problems consist of a function and its derivative as the environment, and-an initial value.--> type Problem = Env Function Double--We can express an iterative algorithm using unfold over an initial environment.- -> newton :: Problem -> Solution Double-> newton = unfold (\wd ->->                     let  f  = asks function wd in->                     let df  = asks derivative wd in->                     let  x  = extract wd in->                     x - f x / df x)-> -> --To estimate the error, we look forward one position in the stream. The next value-will be much more precise than the current one, so we can consider it as the-actual result.--We know that the exact value of a function at one of it's zeroes is 0. So,-@ferror@ can be computed exactly as @abs (f a - f 0) == abs (f a)@--> estimateError :: Solution Double -> Result-> estimateError s =->   let a:a':_ = toList s in->   let f = asks function s in->   Result { value = a,->            xerror = abs $ a - a',->            ferror = abs $ f a->          }--To get a sense of when the algorithm is making any progress, we can sample the-future and check if the result improves at all.- -> estimateOutlook :: Int -> Solution Result -> Outlook-> estimateOutlook sampleSize solution =->   let sample = map ferror $ take sampleSize $ tail $ toList solution in->   let result = extract solution in->   Outlook { result = result,->             progress = ferror result > minimum sample } --To compute the square root of @c@, we solve the equation @x*x - c = 0@. We will-stop whenever the accuracy of the result doesn't improve in the next 5 steps.--The starting value for our algorithm is @c@ itself. One could compute a better-estimate, but the algorithm converges fast enough that it's not really worth it.--> squareRoot :: Double -> Maybe Result-> squareRoot c = let problem = flip env c (Function { function = (\x -> x*x - c),->                                                     derivative = (\x -> 2*x) })->                in ->                fmap result $ find (not . progress) $ ->                  newton problem =>> estimateError =>> estimateOutlook 5--This program will output the result together with the error.--> main :: IO ()-> main = putStrLn $ show $ squareRoot 4+<examples/NewtonCoiter.lhs Newton's method>  -}--- END Coiter.lhs

@@ -50,6 +50,7 @@ import Data.Semigroup.Foldable import Data.Semigroup.Traversable import Data.Data+import Prelude hiding (foldr) import Prelude.Extras  -- | The 'Free' 'Monad' for a 'Functor' @f@.@@ -210,6 +211,20 @@     go (Pure a) = f a     go (Free fa) = foldMap go fa   {-# INLINE foldMap #-}++  foldr f = go where+    go r free =+      case free of+        Pure a -> f a r+        Free fa -> foldr (flip go) r fa+  {-# INLINE foldr #-}++  foldl' f = go where+    go r free =+      case free of+        Pure a -> f r a+        Free fa -> foldl' go r fa+  {-# INLINE foldl' #-}  instance Foldable1 f => Foldable1 (Free f) where   foldMap1 f = go where

@@ -68,7 +68,9 @@ import Control.Monad.Cont.Class import Control.Monad.Trans.Class import Control.Monad.State.Class+import Data.Foldable import Data.Functor.Bind+import Prelude hiding (foldr)  -- | The Church-encoded free monad for a functor @f@. -- @@ -106,6 +108,14 @@   mfix f = a where     a = f (impure a)     impure (F x) = x id (error "MonadFix (F f): wrap")++instance (Foldable f, Functor f) => Foldable (F f) where+    foldr f r xs = runF xs f (foldr (.) id) r+    {-# INLINE foldr #-}++    foldl' f r xs = runF xs (flip f) (foldr (!>>>) id) r+      where (!>>>) f g = \r -> g $! f r+    {-# INLINE foldl' #-}  instance MonadPlus f => MonadPlus (F f) where   mzero = F (\_ kf -> kf mzero)

@@ -39,6 +39,7 @@ import Control.Monad.Trans.List import Control.Monad.Trans.Error import Control.Monad.Trans.Identity+import Control.Monad.Trans.Either import Data.Monoid  -- |@@ -134,6 +135,9 @@  instance (Functor f, MonadFree f m, Error e) => MonadFree f (ErrorT e m) where   wrap = ErrorT . wrap . fmap runErrorT++instance (Functor f, MonadFree f m) => MonadFree f (EitherT e m) where+  wrap = EitherT . wrap . fmap runEitherT  -- | A version of lift that can be used with just a Functor for f. liftF :: (Functor f, MonadFree f m) => f a -> m a

@@ -17,8 +17,8 @@    makeFree    -- $doc -   -- ** Example-   -- $example+   -- ** Examples+   -- $examples   ) where  import Control.Arrow@@ -132,8 +132,8 @@ unifyCaptured _ [x, y]   = unifyT x y unifyCaptured _ _ = fail "can't unify more than 2 arguments that use type parameter" -liftCon' :: Type -> Name -> [Name] -> Name -> [Type] -> Q [Dec]-liftCon' f n ns cn ts = do+liftCon' :: [TyVarBndr] -> Cxt -> Type -> Name -> [Name] -> Name -> [Type] -> Q [Dec]+liftCon' tvbs cx f n ns cn ts = do   -- prepare some names   opName <- mkName <$> mkOpName (nameBase cn)   m      <- newName "m"@@ -154,31 +154,31 @@   let pat  = map VarP xs                      -- this is LHS       exprs = zipExprs (map VarE xs) es args  -- this is what ctor would be applied to       fval = foldl AppE (ConE cn) exprs       -- this is RHS without liftF-      q = map PlainTV $ qa ++ m : ns+      q = tvbs ++ map PlainTV (qa ++ m : ns)       qa = case retType of VarT b | a == b -> [a]; _ -> []       f' = foldl AppT f (map VarT ns)   return #if MIN_VERSION_template_haskell(2,10,0)-    [ SigD opName (ForallT q [ConT monadFree `AppT` f' `AppT` VarT m] opType)+    [ SigD opName (ForallT q (cx ++ [ConT monadFree `AppT` f' `AppT` VarT m]) opType) #else-    [ SigD opName (ForallT q [ClassP monadFree [f', VarT m]] opType)+    [ SigD opName (ForallT q (cx ++ [ClassP monadFree [f', VarT m]]) opType) #endif     , FunD opName [ Clause pat (NormalB $ AppE (VarE liftF) fval) [] ] ]  -- | Provide free monadic actions for a single value constructor.-liftCon :: Type -> Name -> [Name] -> Con -> Q [Dec]-liftCon f n ns con =+liftCon :: [TyVarBndr] -> Cxt -> Type -> Name -> [Name] -> Con -> Q [Dec]+liftCon ts cx f n ns con =   case con of-    NormalC cName fields -> liftCon' f n ns cName $ map snd fields-    RecC    cName fields -> liftCon' f n ns cName $ map (\(_, _, ty) -> ty) fields-    InfixC  (_,t1) cName (_,t2) -> liftCon' f n ns cName [t1, t2]-    _ -> fail $ "liftCon: Don't know how to lift " ++ show con+    NormalC cName fields -> liftCon' ts cx f n ns cName $ map snd fields+    RecC    cName fields -> liftCon' ts cx f n ns cName $ map (\(_, _, ty) -> ty) fields+    InfixC  (_,t1) cName (_,t2) -> liftCon' ts cx f n ns cName [t1, t2]+    ForallC ts' cx' con' -> liftCon (ts ++ ts') (cx ++ cx') f n ns con'  -- | Provide free monadic actions for a type declaration. liftDec :: Dec -> Q [Dec] liftDec (DataD _ tyName tyVarBndrs cons _)   | null tyVarBndrs = fail $ "Type " ++ show tyName ++ " needs at least one free variable"-  | otherwise = concat <$> mapM (liftCon con nextTyName (init tyNames)) cons+  | otherwise = concat <$> mapM (liftCon [] [] con nextTyName (init tyNames)) cons     where       tyNames    = map tyVarBndrName tyVarBndrs       nextTyName = last tyNames@@ -196,7 +196,7 @@  {- $doc  To generate free monadic actions from a @Type@, it must be a @data@- declaration with at least one free variable. For each constructor of the type, a+ declaration (maybe GADT) with at least one free variable. For each constructor of the type, a  new function will be declared.   Consider the following generalized definitions:@@ -207,6 +207,7 @@  >                            | t1 :* t2  >                            | t1 `Bar` t2  >                            | Baz { x :: t1, y :: t2, …, z :: tJ }+ >                            | forall b1 b2 … bN. cxt => Qux t1 t2 … tJ  >                            | …   where each of the constructor arguments @t1, …, tJ@ is either:@@ -231,7 +232,9 @@  > …  > fooBar :: (MonadFree Type m) => t1' -> … -> tK' -> m ret  > (+)    :: (MonadFree Type m) => t1' -> … -> tK' -> m ret+ > bar    :: (MonadFree Type m) => t1  -> … -> tK' -> m ret  > baz    :: (MonadFree Type m) => t1' -> … -> tK' -> m ret+ > qux    :: (MonadFree Type m, cxt) => t1' -> … -> tK' -> m ret  > …   The @t1', …, tK'@ are those @t1@ … @tJ@ that only depend on the@@ -259,118 +262,10 @@  -} --- BEGIN Teletype.lhs-{- $example--This is literate Haskell! To run this example, open the source of this-module and copy the whole comment block into a file with '.lhs'-extension. For example, @Teletype.lhs@.--@\{\-\# LANGUAGE DeriveFunctor, TemplateHaskell, FlexibleContexts \#\-\}@--> {-# LANGUAGE DeriveFunctor, TemplateHaskell, FlexibleContexts #-} ----> import Control.Monad         (mfilter)-> import Control.Monad.Loops   (unfoldM)-> import Control.Monad.Free    (liftF, Free, iterM, MonadFree)-> import Control.Monad.Free.TH (makeFree)-> import Control.Applicative   ((<$>))-> import System.IO             (isEOF)-> import Control.Exception     (catch)-> import System.IO.Error       (ioeGetErrorString)-> import System.Exit           (exitSuccess)--First, we define a data type with the primitive actions of a teleprinter. The-@param@ will stand for the next action to execute.--> type Error = String->-> data Teletype param = Halt                                  -- Abort (ignore all following instructions)->                 | NL param                              -- Newline->                 | Read (Char -> param)                  -- Get a character from the terminal->                 | ReadOrEOF { onEOF  :: param,->                               onChar :: Char -> param } -- GetChar if not end of file->                 | ReadOrError (Error -> param)->                               (Char -> param)           -- GetChar with error code->                 | param :\^^ String                     -- Write a message to the terminal->                 | (:%) param String [String]            -- String interpolation->                 deriving (Functor)--By including a 'makeFree' declaration:--> makeFree ''Teletype--the following functions have been made available:--@- halt        :: (MonadFree Teletype m) => m a- nL          :: (MonadFree Teletype m) => m ()- read        :: (MonadFree Teletype m) => m Char- readOrEOF   :: (MonadFree Teletype m) => m (Maybe Char)- readOrError :: (MonadFree Teletype m) => m (Either Error Char)- (\\^^)       :: (MonadFree Teletype m) => String -> m ()- (%)         :: (MonadFree Teletype m) => String -> [String] -> m ()-@--To make use of them, we need an instance of 'MonadFree Teletype'. Since 'Teletype' is a-'Functor', we can use the one provided in the 'Control.Monad.Free' package.--> type TeletypeM = Free Teletype--Programs can be run in different ways. For example, we can use the-system terminal through the @IO@ monad.--> runTeletypeIO :: TeletypeM a -> IO a-> runTeletypeIO = iterM run where->   run :: Teletype (IO a) -> IO a->   run Halt                      = do->     putStrLn "This conversation can serve no purpose anymore. Goodbye."->     exitSuccess->->   run (Read f)                  = getChar >>= f->   run (ReadOrEOF eof f)         = isEOF >>= \b -> if b then eof->                                                        else getChar >>= f->->   run (ReadOrError ferror f)    = catch (getChar >>= f) (ferror . ioeGetErrorString)->   run (NL rest)                 = putChar '\n' >> rest->   run (rest :\^^ str)           = putStr str >> rest->   run ((:%) rest format tokens) = ttFormat format tokens >> rest->->   ttFormat :: String -> [String] -> IO ()->   ttFormat []            _          = return ()->   ttFormat ('\\':'%':cs) tokens     = putChar '%'  >> ttFormat cs tokens->   ttFormat ('%':cs)      (t:tokens) = putStr t     >> ttFormat cs tokens->   ttFormat (c:cs)        tokens     = putChar c    >> ttFormat cs tokens--Now, we can write some helper functions:--> readLine :: TeletypeM String-> readLine = unfoldM $ mfilter (/= '\n') <$> readOrEOF--And use them to interact with the user:--> hello :: TeletypeM ()-> hello = do->           (\^^) "Hello! What's your name?"; nL->           name <- readLine->           "Nice to meet you, %." % [name]; nL->           halt--We can transform any @TeletypeM@ into an @IO@ action, and run it:--> main :: IO ()-> main = runTeletypeIO hello+{- $examples -@- Hello! What's your name?- $ Dave- Nice to meet you, Dave.- This conversation can serve no purpose anymore. Goodbye.-@+<examples/Teletype.lhs Teletype> (regular data type declaration) -When specifying DSLs in this way, we only need to define the semantics-for each of the actions; the plumbing of values is taken care of by-the generated monad instance.+<examples/RetryTH.hs Retry> (GADT declaration)  -}--- END Teletype.lhs

@@ -58,8 +58,8 @@   , foldM   -- * IterT ~ FreeT Identity   , MonadFree(..)-  -- * Example-  -- $example+  -- * Examples+  -- $examples   ) where  import Control.Applicative@@ -414,149 +414,8 @@ iterDataType = mkDataType "Control.Monad.Iter.IterT" [iterConstr] {-# NOINLINE iterDataType #-} --- BEGIN MandelbrotIter.lhs-{- $example-This is literate Haskell! To run the example, open the source and copy-this comment block into a new file with '.lhs' extension. Compiling to an executable-file with the @-O2@ optimization level is recomended.--For example: @ghc -o 'mandelbrot_iter' -O2 MandelbrotIter.lhs ; ./mandelbrot_iter@--@ \{\-\# LANGUAGE PackageImports \#\-\} @--> {-# LANGUAGE PackageImports #-}--> import Control.Arrow-> import Control.Monad.Trans.Iter-> import "mtl" Control.Monad.Reader-> import "mtl" Control.Monad.List-> import "mtl" Control.Monad.Identity-> import Control.Monad.IO.Class-> import Data.Complex-> import Graphics.HGL (runGraphics, Window, withPen,->                      line, RGB (RGB), RedrawMode (Unbuffered, DoubleBuffered), openWindowEx,->                      drawInWindow, mkPen, Style (Solid))--Some fractals can be defined by infinite sequences of complex numbers. For example,-to render the <https://en.wikipedia.org/wiki/Mandelbrot_set Mandelbrot set>,-the following sequence is generated for each point @c@ in the complex plane:--@-z₀ = c      --z₁ = z₀² + c       --z₂ = z₁² + c        --…-@--If, after some iterations, |z_i| ≥ 2, the point is not in the set. We-can compute if a point is not in the Mandelbrot set this way:--@- escaped :: Complex Double -> Int- escaped c = loop 0 0 where-   loop z n = if (magnitude z) >= 2 then n-                                    else loop (z*z + c) (n+1)-@--If @c@ is not in the Mandelbrot set, we get the number of iterations required to-prove that fact. But, if @c@ is in the mandelbrot set, 'escaped' will-run forever.--We can use the 'Iter' monad to delimit this effect. By applying-'delay' before the recursive call, we decompose the computation into-terminating steps.--> escaped :: Complex Double -> Iter Int-> escaped c = loop 0 0 where->   loop z n = if (magnitude z) >= 2 then return n->                                    else delay $ loop (z*z + c) (n+1)->--If we draw each point on a canvas after it escapes, we can get a _negative_-image of the Mandelbrot set. Drawing pixels is a side-effect, so it-should happen inside the IO monad. Also, we want to have an-environment to store the size of the canvas, and the target window.--By using 'IterT', we can add all these behaviours to our non-terminating-computation.--> data Canvas = Canvas { width :: Int, height :: Int, window :: Window }->-> type FractalM a = IterT (ReaderT Canvas IO) a--Any simple, non-terminating computation can be lifted into a richer environment.--> escaped' :: Complex Double -> IterT (ReaderT Canvas IO) Int-> escaped' = liftIter . escaped--Then, to draw a point, we can just retrieve the number of iterations until it-finishes, and draw it. The color will depend on the number of iterations.--> mandelbrotPoint :: (Int, Int) -> FractalM ()-> mandelbrotPoint p = do->   c <- scale p->   n <- escaped' c->   let color =  if (even n) then RGB   0   0 255 -- Blue->                            else RGB   0   0 127 -- Darker blue->   drawPoint color p--The pixels on the screen don't match the region in the complex plane where the-fractal is; we need to map them first. The region we are interested in is-Im z = [-1,1], Re z = [-2,1].--> scale :: (Int, Int) -> FractalM (Complex Double)-> scale (xi,yi) = do->   (w,h) <- asks $ (fromIntegral . width) &&& (fromIntegral . height)->   let (x,y) = (fromIntegral xi, fromIntegral yi)->   let im = (-y + h / 2     ) / (h/2)->   let re = ( x - w * 2 / 3 ) / (h/2)->   return $ re :+ im--Drawing a point is equivalent to drawing a line of length one.--> drawPoint :: RGB -> (Int,Int) -> FractalM ()-> drawPoint color p@(x,y) = do->   w <- asks window->   let point = line (x,y) (x+1, y+1)->   liftIO $ drawInWindow w $ mkPen Solid 1 color (flip withPen point)--We may want to draw more than one point. However, if we just sequence the computations-monadically, the first point that is not a member of the set will block the whole-process. We need advance all the points at the same pace, by interleaving the-computations.--> drawMandelbrot :: FractalM ()-> drawMandelbrot = do->   (w,h) <- asks $ width &&& height->   let ps = [mandelbrotPoint (x,y) | x <- [0 .. (w-1)], y <- [0 .. (h-1)]]->   interleave_ ps--To run this computation, we can just use @retract@, which will run indefinitely:--> runFractalM :: Canvas -> FractalM a -> IO a-> runFractalM canvas  = flip runReaderT canvas . retract--Or, we can trade non-termination for getting an incomplete result,-by cutting off after a certain number of steps.--> runFractalM' :: Integer -> Canvas -> FractalM a -> IO (Maybe a)-> runFractalM' n canvas  = flip runReaderT canvas . retract . cutoff n--Thanks to the 'IterT' transformer, we can separate timeout concerns from-computational concerns.+{- $examples -> main :: IO ()-> main = do->   let windowWidth = 800->   let windowHeight = 480->   runGraphics $ do->     w <- openWindowEx "Mandelbrot" Nothing (windowWidth, windowHeight) DoubleBuffered (Just 1)->     let canvas = Canvas windowWidth windowHeight w->     runFractalM' 100 canvas drawMandelbrot->     putStrLn $ "Fin"+<examples/MandelbrotIter.lhs Mandelbrot>  -}--- END MandelbrotIter.lhs