“Maybe a” emulation: monadic properties

-- "Maybe a" emulation: monadic properties

data OptionType a
  = Empty
  | NonEmpty a
  deriving (Show, Eq)

instance Functor OptionType where
  fmap _ Empty = Empty
  fmap f (NonEmpty a) = NonEmpty $ f a

instance Applicative OptionType where
  pure = NonEmpty
  (<*>) (NonEmpty a) (NonEmpty b) = NonEmpty $ a b

instance Monad OptionType where
  return = NonEmpty
-- the 'bind' operator is the >>= thingy :-)
  (>>=) Empty f = Empty
  (>>=) (NonEmpty a) f = f a

increment :: Int -> OptionType Int
increment x = NonEmpty (x + 1)

feedingEmptyOptionalValue :: OptionType Int
feedingEmptyOptionalValue = Empty >>= increment

singleFeeding :: OptionType Int
singleFeeding = NonEmpty 7 >>= increment

doubleFeeding :: OptionType Int
doubleFeeding = NonEmpty 7 >>= increment >>= increment

fuckUpPipeline :: OptionType Int
fuckUpPipeline = NonEmpty 7 >>= increment >>= (\_ -> Empty) >>= increment

outputText =
  [ "1. An empty optional value: "
  , show (Empty :: OptionType Int)
  , "2. An non-empty optional value: "
  , show (NonEmpty 7)
  , "3. Feeding an empty optional value to the increment function:"
  , "Empty >>= increment → "
  , show feedingEmptyOptionalValue
  , "4. Feeding an non-empty optional value to the increment function:"
  , "NonEmpty 7 >>= increment → "
  , show singleFeeding
  , "5. A two-section pipeline with the increment function:"
  , "NonEmpty 7 >>= increment >>= increment → "
  , show doubleFeeding
  , "6. A three-section pipeline showcasing failure propagation:"
  , "NonEmpty 7 >>= increment >>= (\\_ -> Empty) >>= increment → "
  , show fuckUpPipeline
  , "7. The first monadic law: return a >>= h ≡ h a:"
  , "(return 7 >>= increment) == increment 7 →"
  , show $ (return 7 >>= increment) == increment 7
  , "8. The second monadic law: m >>= return ≡ m:"
  , "(NonEmpty 7 >>= return) == NonEmpty 7 →"
  , show $ (NonEmpty 7 >>= return) == NonEmpty 7
  , "9. The third monadic law: (m >>= g) >>= h ≡ m >>= (\\x -> g x >>= h):"
  , "((NonEmpty 7 >>= (\\_ -> Empty)) >>= increment) == (NonEmpty 7 >>= (\\x -> (\\_ -> Empty) x >>= increment)) →"
  , show $ ((NonEmpty 7 >>= (\_ -> Empty)) >>= increment) == (NonEmpty 7 >>= (\x -> (\_ -> Empty) x >>= increment))
  ]

main :: IO ()
main = mapM_ putStrLn outputText

-- 1. An empty optional value:
-- Empty
-- 2. An non-empty optional value:
-- NonEmpty 7
-- 3. Feeding an empty optional value to the increment function:
-- Empty >>= increment →
-- Empty
-- 4. Feeding an non-empty optional value to the increment function:
-- NonEmpty 7 >>= increment →
-- NonEmpty 8
-- 5. A two-section pipeline with the increment function:
-- NonEmpty 7 >>= increment >>= increment →
-- NonEmpty 9
-- 6. A three-section pipeline showcasing failure propagation:
-- NonEmpty 7 >>= increment >>= (\_ -> Empty) >>= increment →
-- Empty
-- 7. The first monadic law: return a >>= h ≡ h a:
-- (return 7 >>= increment) == increment 7 →
-- True
-- 8. The second monadic law: m >>= return ≡ m:
-- (NonEmpty 7 >>= return) == NonEmpty 7 →
-- True
-- 9. The third monadic law: (m >>= g) >>= h ≡ m >>= (\x -> g x >>= h):
-- ((NonEmpty 7 >>= (\_ -> Empty)) >>= increment) == (NonEmpty 7 >>= (\x -> (\_ -> Empty) x >>= increment)) →
-- True