-- | Notes taken by Deimantė Davidavičiūtė
{-# LANGUAGE InstanceSigs #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Lessons.Lesson10 where

import Control.Monad.Trans.State.Strict (State, StateT, get, put, runState, runStateT)
import Control.Monad.Trans.Except (ExceptT, throwE, runExceptT)
import Control.Monad.Trans.Class(lift)
import Control.Monad.IO.Class(liftIO)

import Control.Monad
import Data.Foldable

import Control.Applicative


import Test.QuickCheck (Arbitrary, arbitrary, quickCheckResult)
import Test.QuickCheck.Gen

import Data.Char

-- | Basic types for the parser.
--
-- @Parser a@ is an `ExceptT` over `State`.
--
-- @State Input@ carries the remaining input string.
--
-- @ExceptT ErrorMsg@ allows failure with an error message.

type ErrorMsg = String
type Input = String
type Parser a = ExceptT ErrorMsg (State Input) a

-- | Parse a single alphabetic character.
--
-- Consumes one character from the input state or fails with an error message.
--
-- >>> parse parseLetter "a1"
-- (Right 'a',"1")
-- >>> parse parseLetter "1a"
-- (Left "A letter is expected, but got 1","1a")
-- >>> parse parseLetter ""
-- (Left "A letter is expected but got empty input","")
parseLetter :: Parser Char
parseLetter :: Parser Char
parseLetter = do
	String
input <- State String String -> ExceptT String (State String) String
forall (m :: * -> *) a. Monad m => m a -> ExceptT 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 (m :: * -> *) e a. Monad m => e -> ExceptT e m 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 () -> ExceptT String (State String) ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT 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 -> ExceptT String (State String) a
forall (m :: * -> *) a. Monad m => a -> m a
return Char
h
		else String -> Parser Char
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m 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 using 'do' notation.
--
-- >>> parse parseTwoLetters "ds"
-- (Right "ds","")
-- >>> parse parseTwoLetters "d5"
-- (Left "A letter is expected, but got 5","5")
parseTwoLetters :: Parser String
parseTwoLetters :: ExceptT String (State String) String
parseTwoLetters = do
	Char
a <- Parser Char
parseLetter
	Char
b <- Parser Char
parseLetter
	String -> ExceptT String (State String) String
forall a. a -> ExceptT String (State String) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char
a, Char
b]

-- | Same as 'parseTwoLetters', but using applicative style.
--
-- >>> parse parseTwoLetters' "ab"
-- (Right "ab","")
parseTwoLetters' :: Parser String
parseTwoLetters' :: ExceptT String (State String) String
parseTwoLetters' = (\Char
a Char
b -> [Char
a, Char
b]) (Char -> Char -> String)
-> Parser Char -> ExceptT String (State String) (Char -> String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Char
parseLetter ExceptT String (State String) (Char -> String)
-> Parser Char -> ExceptT String (State String) String
forall a b.
ExceptT String (State String) (a -> b)
-> ExceptT String (State String) a
-> ExceptT String (State String) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Char
parseLetter


-- | Running the parser:
--
-- >>> :t runExceptT parseTwoLetters
-- runExceptT parseTwoLetters :: State Input (Either ErrorMsg String)
--
-- >>> :t runState (runExceptT parseTwoLetters)
-- runState (runExceptT parseTwoLetters) :: Input -> (Either ErrorMsg String, Input)
--
-- >>> parse parseTwoLetters ""
-- (Left "A letter is expected but got empty input","")
-- >>> parse parseTwoLetters "ds"
-- (Right "ds","")
-- >>> parse parseTwoLetters "545435"
-- (Left "A letter is expected, but got 5","545435")

-- | Helper to run a 'Parser' on an input string.
parse :: Parser a -> Input -> (Either ErrorMsg a, Input)
parse :: forall a. Parser a -> String -> (Either String a, String)
parse Parser a
p = State String (Either String a)
-> String -> (Either String a, String)
forall s a. State s a -> s -> (a, s)
runState (Parser a -> State String (Either String a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT Parser a
p)

-- | A more complex monad stack: IO + State + Except.
--
-- @Weird a@ fails with an Int, keeps a String state, and can do IO.
type Weird a = ExceptT Int (StateT String IO) a

-- | Version using nested 'lift' calls.
-- Interacts with the console and stores the last answer in state.
--
-- >>> :t runStateT (runExceptT weird) "init"
-- runStateT (runExceptT weird) "init" :: IO (Either Int Double, String)
weird :: Weird Double
weird :: Weird Double
weird = do
	StateT String IO () -> ExceptT Int (StateT String IO) ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT Int m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT String IO () -> ExceptT Int (StateT String IO) ())
-> StateT String IO () -> ExceptT Int (StateT String IO) ()
forall a b. (a -> b) -> a -> b
$ IO () -> StateT String IO ()
forall (m :: * -> *) a. Monad m => m a -> StateT String m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> StateT String IO ()) -> IO () -> StateT String IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"Hello?"
	String
answer <- StateT String IO String -> ExceptT Int (StateT String IO) String
forall (m :: * -> *) a. Monad m => m a -> ExceptT Int m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT String IO String -> ExceptT Int (StateT String IO) String)
-> StateT String IO String -> ExceptT Int (StateT String IO) String
forall a b. (a -> b) -> a -> b
$ IO String -> StateT String IO String
forall (m :: * -> *) a. Monad m => m a -> StateT String m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO String -> StateT String IO String)
-> IO String -> StateT String IO String
forall a b. (a -> b) -> a -> b
$ IO String
getLine
	StateT String IO () -> ExceptT Int (StateT String IO) ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT Int m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT String IO () -> ExceptT Int (StateT String IO) ())
-> StateT String IO () -> ExceptT Int (StateT String IO) ()
forall a b. (a -> b) -> a -> b
$ String -> StateT String IO ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put String
answer
	Double -> Weird Double
forall a. a -> ExceptT Int (StateT String IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return Double
3.14
--
-- >>> :t weird
-- weird :: Weird Double
-- >>> :t runExceptT weird
-- runExceptT weird :: StateT String IO (Either Int Double)
-- >>> :t runStateT (runExceptT weird) "fsd"
-- runStateT (runExceptT weird) "fsd" :: IO (Either Int Double, String)

-- | Same behavior, but with 'liftIO' for cleaner IO lifting.
weird' :: Weird Double
weird' :: Weird Double
weird' = do
	IO () -> ExceptT Int (StateT String IO) ()
forall a. IO a -> ExceptT Int (StateT String IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT Int (StateT String IO) ())
-> IO () -> ExceptT Int (StateT String IO) ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"Hello?"
	String
answer <- IO String -> ExceptT Int (StateT String IO) String
forall a. IO a -> ExceptT Int (StateT String IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> ExceptT Int (StateT String IO) String)
-> IO String -> ExceptT Int (StateT String IO) String
forall a b. (a -> b) -> a -> b
$ IO String
getLine
	StateT String IO () -> ExceptT Int (StateT String IO) ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT Int m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT String IO () -> ExceptT Int (StateT String IO) ())
-> StateT String IO () -> ExceptT Int (StateT String IO) ()
forall a b. (a -> b) -> a -> b
$ String -> StateT String IO ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put String
answer
	Double -> Weird Double
forall a. a -> ExceptT Int (StateT String IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return Double
3.14

-- | A simple sum type used with QuickCheck.
data SomeData = Foo String | Bar Integer deriving Int -> SomeData -> String -> String
[SomeData] -> String -> String
SomeData -> String
(Int -> SomeData -> String -> String)
-> (SomeData -> String)
-> ([SomeData] -> String -> String)
-> Show SomeData
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> SomeData -> String -> String
showsPrec :: Int -> SomeData -> String -> String
$cshow :: SomeData -> String
show :: SomeData -> String
$cshowList :: [SomeData] -> String -> String
showList :: [SomeData] -> String -> String
Show

-- | Arbitrary instance for SomeData.
--
-- Generates Foo with a random string or Bar with a random integer.
instance Arbitrary SomeData where
	arbitrary :: Gen SomeData
	arbitrary :: Gen SomeData
arbitrary = [Gen SomeData] -> Gen SomeData
forall a. [Gen a] -> Gen a
oneof [(String -> SomeData) -> Gen String -> Gen SomeData
forall a b. (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> SomeData
Foo Gen String
forall a. Arbitrary a => Gen a
arbitrary, (Integer -> SomeData) -> Gen Integer -> Gen SomeData
forall a b. (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Integer -> SomeData
Bar Gen Integer
forall a. Arbitrary a => Gen a
arbitrary]