Monads

Example 1a

this example shows how alternative results (sum type, algebraic type, see type A, B and C in the example) can be handled and propagated in a computation by means of 'case' / 'of' constructions
it works but it is quite some code

Code:

main :: IO ()
main = 
    do
        putStrLn $ show (fAListToC [(A 12), (A 7), (A 11), (A 5)] fAToB)
        putStrLn $ show (fAListToC [(A 7), (A 13), (A 11), (A 5)] fAToB)
        putStrLn $ show (fAListToC [(A (-1)), (A 7), (A 11), (A 5)] fAToB)
        putStrLn $ show (fAListToC [(A 7), (A 11), (A 5), (A 13)] fAToB)
 
data A a = A a | AError | ANone
    deriving Show
 
data B a = B a | BError | BNone
    deriving Show
 
data C a = C a | CError | CNone
    deriving Show
 
fAToB :: A Int -> B Int
fAToB (A n) 
    | n <= 0 = BNone
    | n < 13 = B (23 `div` n)
    | otherwise = BError
fAToB AError = BError
fAToB ANone = BNone
 
fAListToC :: [A a] -> (A a -> B a) -> C [a]
fAListToC [] _ = C []
fAListToC (a@(A _):lrAList) fAToB' = 
    do
        case fAToB' a of
            B b -> 
                let
                    c = (fAListToC lrAList fAToB')
                in
                    case c of
                        C lb -> C (b : lb)
                        CNone -> CNone
                        CError -> CError
            BError -> CError
            BNone -> CNone
fAListToC (AError:_) _ = CError
fAListToC (ANone:_) _ = CNone

Output:
```
C [1,3,2,4]
CError
CNone
CError
```

Example 1b

this example does not explain monads but an alternative solution where monads usually apply
it shows how alternative results (sum type, algebraic type, see type A, B and C in the example) can be handled and propagated in a computation by means of a function that handles such alternative results
that function handles such results by function 'ifC' and makes the job for a 'Monad' of type 'C'

more detailed description of the program
- the function 'fAListToC' takes a list of 'A's (e.g. '[(A 12), (A 7), (A 11), (A 5)]') and transforms it to 'C' with a list of transformed data
- the transformation of data is according to function 'fAToB'
- 'fAToB' divides 23 by the number to be transformed, unless the number is 13 or greater then an error propagates ('BError'), and unless the number is 0 or smaler then no data propagates ('BNone')
- in 'fAListToC' 'BError' propagates to 'CError' and 'BNone' propagates to 'CNone'

this example compile warning free with GHC 9.2.7 using -Wall

Code:

main :: IO ()
main = 
    do
        putStrLn $ show (fAListToC [(A 12), (A 7), (A 11), (A 5)] fAToB)
        putStrLn $ show (fAListToC [(A 7), (A 13), (A 11), (A 5)] fAToB)
        putStrLn $ show (fAListToC [(A (-1)), (A 7), (A 11), (A 5)] fAToB)
        putStrLn $ show (fAListToC [(A 7), (A 11), (A 5), (A 13)] fAToB)
 
data A a = A a | AError | ANone
    deriving Show
 
data B a = B a | BError | BNone
    deriving Show
 
data C a = C a | CError | CNone
    deriving Show
 
fAToB :: A Int -> B Int
fAToB (A n) 
    | n <= 0 = BNone
    | n < 13 = B (23 `div` n)
    | otherwise = BError
fAToB AError = BError
fAToB ANone = BNone
 
fAListToC :: [A a] -> (A a -> B a) -> C [a]
fAListToC [] _ = C []
fAListToC (a@(A _):lrAList) fAToB' = 
    do
        case fAToB' a of
            B b -> ifC (fAListToC lrAList fAToB' ) (\lb -> C (b : lb)) CNone CError
            BError -> CError
            BNone -> CNone
fAListToC (AError:_) _ = CError
fAListToC (ANone:_) _ = CNone
 
ifC :: C a -> (a -> b) -> b -> b -> b
ifC (C x) fThen _ _ = fThen x
ifC CNone _ bNone _ = bNone
ifC CError _ _ bError = bError

Output:
```
C [1,3,2,4]
CError
CNone
CError
```

Example 1c

this example uses the instances for Functor, Applicative and Monad
this way the operator '»=' can be used

Code:

import qualified Control.Monad as M (liftM, ap)
 
instance Functor C where
    fmap = M.liftM
 
instance Applicative C where
    pure = C
    (<*>) = M.ap
 
instance Monad C where
    CError  >>= _   = CError
    CNone   >>= _   = CNone
    (C x)   >>= f   = f x
    return          =  pure
 
main :: IO ()
main = 
    do
        putStrLn $ show (fAListToC [(A 12), (A 7), (A 11), (A 5)] fAToB)
        putStrLn $ show (fAListToC [(A 7), (A 13), (A 11), (A 5)] fAToB)
        putStrLn $ show (fAListToC [(A (-1)), (A 7), (A 11), (A 5)] fAToB)
        putStrLn $ show (fAListToC [(A 7), (A 11), (A 5), (A 13)] fAToB)
 
data A a = A a | AError | ANone
    deriving Show
 
data B a = B a | BError | BNone
    deriving Show
 
data C a = C a | CError | CNone
    deriving Show
 
fAToB :: A Int -> B Int
fAToB (A n) 
    | n <= 0 = BNone
    | n < 13 = B (23 `div` n)
    | otherwise = BError
fAToB AError = BError
fAToB ANone = BNone
 
fAListToC :: [A a] -> (A a -> B a) -> C [a]
fAListToC [] _ = C []
fAListToC (a@(A _):lrAList) fAToB' = 
    do
        case fAToB' a of
            B b -> fAListToC lrAList fAToB' >>= \lb -> return (b : lb)
            BError -> CError
            BNone -> CNone
fAListToC (AError:_) _ = CError
fAListToC (ANone:_) _ = CNone

Output:
```
C [1,3,2,4]
CError
CNone
CError
```

Example 2

inspired from https://wiki.haskell.org/All_About_Monads#A_physical_analogy_for_monads
examples compile warning free with GHC 8.10.4 using -Wall

Code:

module Main where
 
-- import liftM, and ap to create a Tray monad
import qualified Control.Monad as M (liftM, ap)
 
main :: IO ()
main = do
    -- execute the assemply line and print the result starting with a log that is 300 mm in diameter, and 250 mm long
    print $ assemblyLine (Log 300 250)
    -- the same with other diameter, and length
    print $ assemblyLine (Log 200 250)
    -- the same with other diameter, and length
    print $ assemblyLine (Log 24 250)
    -- the same with other diameter, and length
    print $ assemblyLine (Log 250 99)
    -- the same with other diameter, and length
    print $ assemblyLine (Log 22 201)
    -- the same with other diameter, and length
    print $ assemblyLine (Log 29 201)
 
-- vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv --
-- the analogy of an assambly line
assemblyLine :: Wood -> Tray Packed
assemblyLine w = 
    do
        c   <- makeChopsticks w    -- Wood to Chopsticks
        c'  <- polishChopsticks c  -- ...to polished Chopsticks
        c'' <- wrapChopsticks c'   -- ...to packed Chopsticks
        return c''
-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ --
 
--------------------------------------------------------------------------------
--  Basic types
 
--------------------------------------------------------------------------------
--  Wood
 
data Wood = Log { nDiameterInMM :: Float,  nLengthInMM :: Float }
    deriving Show
 
--------------------------------------------------------------------------------
--  Chopsticks and its Quality
 
data Quality =  Sawn | Polished
    deriving Show
 
data Chopsticks = Chopsticks { nPieces :: Integer, nQuality :: Quality }
    deriving Show
 
--------------------------------------------------------------------------------
--  Packed with Wrapper or in a StorageBin
 
data Packed = Wrapper Chopsticks | StorageBin Chopsticks
    deriving Show
 
--------------------------------------------------------------------------------
--  worker functions of the basic types
-- NOTE: All of them can have different in put, but the output is always a Tray.
-- NOTE: See the data type Tray.
 
-- makes roughly shaped chopsticks out of wood
makeChopsticks :: Wood -> Tray Chopsticks
makeChopsticks w 
    | nGain > 0 = Contains (Chopsticks nGain Sawn)
    | (nLengthInMM w) < 200 = Empty "to short" 
    | otherwise = Empty "to small in diameter"
    where
         nGain 
            | (nLengthInMM w) >= 200 = (round ((((nDiameterInMM w) - 20) * (nLengthInMM w)) / (220 * 5)))
            | otherwise = 0
 
-- polishes chopsticks
polishChopsticks :: Chopsticks -> Tray Chopsticks
polishChopsticks c 
    | amount >= 1 = Contains (Chopsticks amount Polished)
    | otherwise = Empty "no chopsticks after polishing"
    where
        amount = floor (((fromIntegral (nPieces c)) :: Double) * 0.9)
 
-- wraps chopsticks
wrapChopsticks :: Chopsticks -> Tray Packed
wrapChopsticks c 
    | amount >= 50 = Contains (Wrapper (Chopsticks amount (nQuality c)))
    | amount <= 0 = Empty "no chopsticks at packing"
    | otherwise = Contains (StorageBin (Chopsticks amount (nQuality c)))
    where
        amount = floor (((fromIntegral (nPieces c)) :: Double) * 0.95)
 
 
--------------------------------------------------------------------------------
--  Tray
 
-- trays are either empty or contain a single item
data Tray x = Empty String | Contains x
    deriving Show
 
--------------------------------------------------------------------------------
--  Tray as instance of Monad
 
-- Tray is a monad
instance Functor Tray where
    fmap = M.liftM
 
instance Applicative Tray where
    pure = return
    (<*>) = M.ap
 
instance Monad Tray where
    Empty s       >>= _      = Empty s
    (Contains x) >>= worker = worker x
    return                  = Contains

Output:

Contains (Wrapper (Chopsticks {nPieces = 54, nQuality = Polished}))
Contains (StorageBin (Chopsticks {nPieces = 34, nQuality = Polished}))
Empty "no chopsticks after polishing"
Empty "to short"
Empty "to small in diameter"
Empty "no chopsticks at packing"

Table of Contents

Monads

Example 1a

Example 1b

Example 1c

Example 2