-- | Notes taken by Lukas Zujevas
--
-- This lesson introduces a simple parser built using monad transformers.
-- The goal is to combine:
--
-- * 'State String' for input consumption
-- * 'Either String' for error reporting
--
-- via the 'EitherT' transformer.
--
-- This demonstrates how multiple effects can be composed into a single monad.

{-# LANGUAGE InstanceSigs #-}
module Lessons.Lesson15 where
import qualified Data.List as L

import Data.Char (isAlpha)

import Control.Monad.Trans.Class (MonadTrans, lift)
import Control.Monad.Trans.State.Strict (State, get, put, runState)

-- | A monad transformer that adds error handling to an existing monad
--
-- @EitherT e m a@ represents a computation in monad @m@ that can either:
--
-- * succeed with a value of type @a@
-- * fail with an error of type @e@
--
-- Internally, this is just a wrapper around @m (Either e a)@
newtype EitherT e m a = EitherT {
  forall e (m :: * -> *) a. EitherT e m a -> m (Either e a)
runEitherT :: m (Either e a)
}

-- | Functor instance propagates errors and applies functions only to successful values.
instance Monad m => Functor (EitherT e m) where
  fmap :: (a -> b) -> EitherT e m a -> EitherT e m b
  fmap :: forall a b. (a -> b) -> EitherT e m a -> EitherT e m b
fmap a -> b
f EitherT e m a
ta = m (Either e b) -> EitherT e m b
forall e (m :: * -> *) a. m (Either e a) -> EitherT e m a
EitherT (m (Either e b) -> EitherT e m b)
-> m (Either e b) -> EitherT e m b
forall a b. (a -> b) -> a -> b
$ do
    Either e a
a <- EitherT e m a -> m (Either e a)
forall e (m :: * -> *) a. EitherT e m a -> m (Either e a)
runEitherT EitherT e m a
ta
    case Either e a
a of
      Left e
e -> Either e b -> m (Either e b)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either e b -> m (Either e b)) -> Either e b -> m (Either e b)
forall a b. (a -> b) -> a -> b
$ e -> Either e b
forall a b. a -> Either a b
Left e
e
      Right a
r -> Either e b -> m (Either e b)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either e b -> m (Either e b)) -> Either e b -> m (Either e b)
forall a b. (a -> b) -> a -> b
$ b -> Either e b
forall a b. b -> Either a b
Right (b -> Either e b) -> b -> Either e b
forall a b. (a -> b) -> a -> b
$ a -> b
f a
r

-- | Applicative instance executes computations one by one and stops at the first error encountered.
instance Monad m => Applicative (EitherT e m) where
  pure :: a -> EitherT e m a
  pure :: forall a. a -> EitherT e m a
pure a
a = m (Either e a) -> EitherT e m a
forall e (m :: * -> *) a. m (Either e a) -> EitherT e m a
EitherT (m (Either e a) -> EitherT e m a)
-> m (Either e a) -> EitherT e m a
forall a b. (a -> b) -> a -> b
$ Either e a -> m (Either e a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either e a -> m (Either e a)) -> Either e a -> m (Either e a)
forall a b. (a -> b) -> a -> b
$ a -> Either e a
forall a b. b -> Either a b
Right a
a
  (<*>) :: EitherT e m (a -> b) -> EitherT e m a -> EitherT e m b
  EitherT e m (a -> b)
tf <*> :: forall a b. EitherT e m (a -> b) -> EitherT e m a -> EitherT e m b
<*> EitherT e m a
ta = m (Either e b) -> EitherT e m b
forall e (m :: * -> *) a. m (Either e a) -> EitherT e m a
EitherT (m (Either e b) -> EitherT e m b)
-> m (Either e b) -> EitherT e m b
forall a b. (a -> b) -> a -> b
$ do
    Either e (a -> b)
f <- EitherT e m (a -> b) -> m (Either e (a -> b))
forall e (m :: * -> *) a. EitherT e m a -> m (Either e a)
runEitherT EitherT e m (a -> b)
tf
    case Either e (a -> b)
f of
      Left e
e1 -> Either e b -> m (Either e b)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either e b -> m (Either e b)) -> Either e b -> m (Either e b)
forall a b. (a -> b) -> a -> b
$ e -> Either e b
forall a b. a -> Either a b
Left e
e1
      Right a -> b
r1 -> do
        Either e a
a <- EitherT e m a -> m (Either e a)
forall e (m :: * -> *) a. EitherT e m a -> m (Either e a)
runEitherT EitherT e m a
ta
        case Either e a
a of
          Left e
e2 -> Either e b -> m (Either e b)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either e b -> m (Either e b)) -> Either e b -> m (Either e b)
forall a b. (a -> b) -> a -> b
$ e -> Either e b
forall a b. a -> Either a b
Left e
e2
          Right a
r2 -> Either e b -> m (Either e b)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either e b -> m (Either e b)) -> Either e b -> m (Either e b)
forall a b. (a -> b) -> a -> b
$ b -> Either e b
forall a b. b -> Either a b
Right (a -> b
r1 a
r2)

-- | Monad instance enables sequencing computations using @do@-notation. Errors short-circuit the computation.
instance Monad m => Monad (EitherT e m) where
  (>>=) :: EitherT e m a -> (a -> EitherT e m b) -> EitherT e m b
  EitherT e m a
m >>= :: forall a b. EitherT e m a -> (a -> EitherT e m b) -> EitherT e m b
>>= a -> EitherT e m b
k = m (Either e b) -> EitherT e m b
forall e (m :: * -> *) a. m (Either e a) -> EitherT e m a
EitherT (m (Either e b) -> EitherT e m b)
-> m (Either e b) -> EitherT e m b
forall a b. (a -> b) -> a -> b
$ do
    Either e a
a <- EitherT e m a -> m (Either e a)
forall e (m :: * -> *) a. EitherT e m a -> m (Either e a)
runEitherT EitherT e m a
m
    case Either e a
a of
      Left e
e -> Either e b -> m (Either e b)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either e b -> m (Either e b)) -> Either e b -> m (Either e b)
forall a b. (a -> b) -> a -> b
$ e -> Either e b
forall a b. a -> Either a b
Left e
e
      Right a
r -> EitherT e m b -> m (Either e b)
forall e (m :: * -> *) a. EitherT e m a -> m (Either e a)
runEitherT (a -> EitherT e m b
k a
r)

-- | A simple parser type.
--
-- * 'State String' stores the remaining input
-- * 'Either String' represents parsing failure
--
-- Running a parser produces a result and the leftover input.
type Parser a = EitherT String (State String) a

-- | Immediately fail with an error message.
--
-- The parser state is not modified.
throwE :: String -> Parser a
throwE :: forall a. String -> Parser a
throwE String
msg = State String (Either String a) -> EitherT String (State String) a
forall e (m :: * -> *) a. m (Either e a) -> EitherT e m a
EitherT (State String (Either String a) -> EitherT String (State String) a)
-> State String (Either String a)
-> EitherT String (State String) a
forall a b. (a -> b) -> a -> b
$ Either String a -> State String (Either String a)
forall a. a -> StateT String Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String a -> State String (Either String a))
-> Either String a -> State String (Either String a)
forall a b. (a -> b) -> a -> b
$ String -> Either String a
forall a b. a -> Either a b
Left String
msg

-- | Allows lifting actions from the inner monad into 'EitherT'.
--
-- Here used to lift 'State' operations.
instance MonadTrans (EitherT e) where
  lift :: Monad m => m a -> EitherT e m a
  lift :: forall (m :: * -> *) a. Monad m => m a -> EitherT e m a
lift m a
ma = m (Either e a) -> EitherT e m a
forall e (m :: * -> *) a. m (Either e a) -> EitherT e m a
EitherT (m (Either e a) -> EitherT e m a)
-> m (Either e a) -> EitherT e m a
forall a b. (a -> b) -> a -> b
$ (a -> Either e a) -> m a -> m (Either e a)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Either e a
forall a b. b -> Either a b
Right m a
ma

-- | Parse a single alphabetic character.
--
-- Rules:
--
-- * If input is empty, parsing fails.
-- * If the first character is alphabetic, it is consumed and returned.
-- * Otherwise, parsing fails without consuming input.
--
-- Examples:
--
-- >>> :t runEitherT parseLetter
-- runEitherT parseLetter :: State String (Either String Char)
-- >>> :t runState (runEitherT parseLetter)
-- runState (runEitherT parseLetter) :: String -> (Either String Char, String)
-- >>> runState (runEitherT parseLetter) ""
-- (Left "A letter is expected but got empty input","")
-- >>> runState (runEitherT parseLetter) "13123"
-- (Left "A letter is expected, but got 1","13123")
-- >>> runState (runEitherT parseLetter) "abba"
-- (Right 'a',"bba")
parseLetter :: Parser Char
parseLetter :: Parser Char
parseLetter = do
  String
input <- State String String -> EitherT String (State String) String
forall (m :: * -> *) a. Monad m => m a -> EitherT String m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift State String String
forall (m :: * -> *) s. Monad m => StateT s m s
get
  case String
input of
    [] -> String -> Parser Char
forall a. String -> Parser a
throwE String
"A letter is expected but got empty input"
    (Char
h:String
t) -> if Char -> Bool
isAlpha Char
h
    then do
      State String () -> EitherT String (State String) ()
forall (m :: * -> *) a. Monad m => m a -> EitherT String m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (String -> State String ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put String
t)
      Char -> Parser Char
forall a. a -> EitherT String (State String) a
forall (m :: * -> *) a. Monad m => a -> m a
return Char
h
    else String -> Parser Char
forall a. String -> Parser a
throwE (String -> Parser Char) -> String -> Parser Char
forall a b. (a -> b) -> a -> b
$ String
"A letter is expected, but got " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
h]

-- | Parse two letters sequentially using monadic composition.
--
-- Example:
--
-- >>> runState (runEitherT twoLettersM) "abba"
-- (Right ('a','b'),"ba")
twoLettersM :: Parser (Char, Char)
twoLettersM :: Parser (Char, Char)
twoLettersM = do
  Char
a <- Parser Char
parseLetter
  Char
b <- Parser Char
parseLetter
  (Char, Char) -> Parser (Char, Char)
forall a. a -> EitherT String (State String) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
a, Char
b)

-- | Parse two letters using Applicative composition.
--
-- Equivalent to 'twoLettersM', but expressed without explicit binding.
--
-- Example:
--
-- >>> runState (runEitherT twoLettersA) "abba"
-- (Right ('a','b'),"ba")
twoLettersA :: Parser (Char, Char)
twoLettersA :: Parser (Char, Char)
twoLettersA = (,) (Char -> Char -> (Char, Char))
-> Parser Char
-> EitherT String (State String) (Char -> (Char, Char))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Char
parseLetter EitherT String (State String) (Char -> (Char, Char))
-> Parser Char -> Parser (Char, Char)
forall a b.
EitherT String (State String) (a -> b)
-> EitherT String (State String) a
-> EitherT String (State String) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Char
parseLetter