content: -- D. Sannella. M Fourman, H. Peng and P. Wadler
  -- Introduction to Computation: Haskell, Logic and Automata
  -- Undergraduate Topics in Computer Science, Springer (2021)
  -- ISBN 978-3-030-76907
  
  -- Required to allow type signatures in type class instance declarations
  
  {-# LANGUAGE InstanceSigs #-}
  
  -- Chapter 30 : Input/Output and Monads
  
  module Chap30_input_output_and_monads where
         
  import Data.Char (toUpper, isDigit)
  
  import Control.Monad (liftM, ap)
  
  import Control.Applicative (Alternative, empty, (<|>))
  
  -- Commands
  
  c0 = putChar 'a' >> putChar 'b'
  
  -- The following function definition is commented out because it is already in the Prelude.
  -- You can hide that definition to allow it to be re-defined by putting the following at the top of this module:
  -- import Prelude hiding (putStr)
  
  -- putStr :: String -> IO ()
  -- putStr []     = done
  -- putStr (x:xs) = putChar x >> putStr xs
  
  -- The following function definition is commented out because it is already in the Prelude.
  -- You can hide that definition to allow it to be re-defined by putting the following at the top of this module:
  -- import Prelude hiding (putStrLn)
  
  -- putStrLn :: String -> IO ()
  -- putStrLn cs = putStr cs >> putChar '\n'
  
  -- Performing commands
  
  c1 = putStrLn "Hello World!"
  
  c2 = putStr "Boing" >> putStr "Boing"
  
  c2' = m >> m
          where m = putStr "Boing"
  
  -- Commands that return a value
  
  c3 = getChar >>= \x -> putChar (toUpper x)
  
  -- The following function definition is commented out because it is already in the Prelude.
  -- You can hide that definition to allow it to be re-defined by putting the following at the top of this module:
  -- import Prelude hiding (getLine)
  
  -- getLine :: IO String
  -- getLine =
  --   getChar                         -- read a character
  --     >>= \x ->                     -- and call it x
  --           if x == '\n'            -- if it's newline, we're done
  --             then return ""        -- so return the empty string
  --           else                    -- otherwise
  --             getLine               -- read the rest of the line
  --               >>= \xs ->          -- and call it xs
  --                     return (x:xs) -- and then return x:xs
  
  echo :: IO ()
  echo =
    getLine
      >>= \line ->
            if line == "" then
              return ()
            else
              putStrLn (map toUpper line)
                >> echo
  
  done :: IO ()
  done = return ()
  
  -- The following function definition is commented out because it is already in the Prelude.
  -- You can hide that definition to allow it to be re-defined by putting the following at the top of this module:
  -- import Prelude hiding ( (>>) )
  -- But then, in order to get later code to typecheck, you will need to give it the more general type
  -- (>>) :: Monad m => m a -> m b -> m b
  
  -- (>>) :: IO () -> IO () -> IO ()
  -- m >> n = m >>= \_ -> n
  
  -- do notation
  
  getLine' :: IO String
  getLine' = do {
               x <- getChar;
               if x == '\n' then
                 return ""
               else do {
                 xs <- getLine;
                 return (x:xs)
                    }
             }
  
  putStr' :: String -> IO ()
  putStr' []     = done
  putStr' (x:xs) = do {
                     putChar x;
                     putStr' xs
                   }
  
  -- Monads
  
  -- The following type class definition and its instance for [] are commented out because they are already
  -- in the Prelude.
  -- You can hide that definition and its instances to allow them to be re-defined by putting the following at the
  -- top of this module:
  -- import Prelude hiding (Monad, return, (>>=), (>>))
  -- but then the earlier definitions using the IO monad won't compile unless you re-define it too.
  
  -- class Monad m where
  --   return :: a -> m a
  --   (>>=)  :: m a -> (a -> m b) -> m b
  --   -- default
  --   (>>)   :: m a -> m b -> m b
  --   x >> y = x >>= \_ -> y
  
  -- Lists as a monad
  
  -- instance Monad [] where
  --   return  :: a -> [a]
  --   return x = [ x ]
  --  
  --   (>>=)   :: [a] -> (a -> [b]) -> [b]
  --   m >>= k = [ y | x <- m, y <- k x ]
  
  -- alternative definition of >>=
  -- [] >>= k     = []
  -- (x:xs) >>= k = (k x) ++ (xs >>= k)
  
  -- another alternative definition of >>=
  -- m >>= k = concat (map k m)
  
  pairs :: Int -> [(Int, Int)]
  pairs n = do {
              i <- [1..n];
              j <- [(i+1)..n];
              return (i,j)
            }
  
  ps0 = pairs 4
  
  pairs' :: Int -> [(Int, Int)]
  pairs' n = [ (i,j) | i <- [1..n], j <- [(i+1)..n] ]
  
  class Monad m => MonadPlus m where
    mzero :: m a
    mplus :: m a -> m a -> m a
  
  instance MonadPlus [] where
    mzero :: [a]
    mzero = []
  
    mplus :: [a] -> [a] -> [a]
    mplus = (++)
  
  guard :: MonadPlus m => Bool -> m ()
  guard False = mzero
  guard True  = return ()
  
  l0 = guard (1 > 3) :: [()]
  
  l1 = guard (3 > 1) :: [()]
  
  l2 = guard (1 > 3) >> return 1 :: [Int]
  
  l3 = guard (3 > 1) >> return 1 :: [Int]
  
  pairs'' :: Int -> [(Int, Int)]
  pairs'' n = do {
                i <- [1..n];
                j <- [1..n];
                guard (i < j);
                return (i,j)
              }
  ps1 = pairs'' 4
  
  pairs''' :: Int -> [(Int, Int)]
  pairs''' n = [ (i,j) | i <- [1..n], j <- [1..n], i < j ]
  
  -- Parsers as a monad
  
  data Exp = Lit Int
           | Add Exp Exp
           | Mul Exp Exp
    deriving (Eq, Show)
  
  -- showExp is from Chapter 16
  -- we can't simply import it because Exp has been re-defined
  
  showExp :: Exp -> String
  showExp (Lit n)   = show n
  showExp (Add e f) = par (showExp e ++ " + " ++ showExp f)
  showExp (Mul e f) = par (showExp e ++ " * " ++ showExp f)
  
  par :: String -> String
  par s = "(" ++ s ++ ")"
  
  s0 = showExp (Add (Lit 1) (Mul (Lit 2) (Lit 3)))
  
  s1 = showExp (Mul (Add (Lit 1) (Lit 2)) (Lit 3))
  
  data Parser a = Parser (String -> [(a, String)])
  
  apply :: Parser a -> String -> [(a, String)]
  apply (Parser f) s = f s
  
  parse :: Parser a -> String -> a
  parse p s = one [ x | (x,"") <- apply p s ]
    where one []                 = error "no parse"
          one [x]                = x
          one xs | length xs > 1 = error "ambiguous parse"
  
  char :: Parser Char
  char = Parser f
    where f []    = []
          f (c:s) = [(c,s)]
  
  spot :: (Char -> Bool) -> Parser Char
  spot p = Parser f
    where f []                = []
          f (c:s) | p c       = [(c, s)]
                  | otherwise = []
  
  token :: Char -> Parser Char
  token c = spot (== c)
  
  ps2 = apply (spot isDigit) "123"
  
  ps3 = apply (spot isDigit) "(1+2)"
  
  ps4 = apply (token '(') "(1+2)"
  
  instance Monad Parser where
    return x = Parser (\s -> [(x,s)])
    m >>= k  = Parser (\s ->
                 [ (y, u) |
                   (x, t) <- apply m s,
                   (y, u) <- apply (k x) t ])
  
  -- from Haskell 7.10, need to add instances for Functor and Applicative
  
  instance Functor Parser where
    fmap = liftM
  
  instance Applicative Parser where
    pure  = return
    (<*>) = ap
  
  match :: String -> Parser String
  match []     = return []
  match (x:xs) = do {
                   y <- token x;
                   ys <- match xs;
                   return (y:ys)
                 }
  
  ps5 = apply (match "abc") "abcdef"
  
  ps6 = apply (do {x <- match "abc"; y <- match "de"; return (x++y) }) "abcdef"
  
  instance MonadPlus Parser where
    mzero     = Parser (\s -> [])
    mplus m n = Parser (\s -> apply m s ++ apply n s)
  
  -- ** from Haskell 7.10, need to add instance for Alternative
  
  instance Alternative Parser where
    empty = mzero
    (<|>) = mplus
  
  spot' :: (Char -> Bool) -> Parser Char
  spot' p = do {
              c <- char;
              guard (p c);
              return c
            }
  
  star :: Parser a -> Parser [a]
  star p = plus p `mplus` return []
  
  plus :: Parser a -> Parser [a]
  plus p = do {
             x <- p;
             xs <- star p;
             return (x:xs)
           }
  
  parseInt :: Parser Int
  parseInt = parseNat `mplus` parseNeg
    where parseNat = do {
                       s <- plus (spot isDigit);
                       return (read s)
                     }
          parseNeg = do {
                       token '-';
                       n <- parseNat;
                       return (-n)
                     }
  
  ps7 = apply parseInt "-123+4"
  
  parseExp :: Parser Exp
  parseExp = parseLit `mplus` parseAdd `mplus` parseMul
    where parseLit = do {
                       n <- parseInt;
                       return (Lit n)
                     }
          parseAdd = do {
                       token '(';
                       d <- parseExp;
                       token '+';
                       e <- parseExp;
                       token ')';
                       return (Add d e)
                     }
          parseMul = do {
                       token '(';
                       d <- parseExp;
                       token '*';
                       e <- parseExp;
                       token ')';
                       return (Mul d e)
                     }
  
  ps8 = parse parseExp "(-142+(26*3))"
  
  ps9 = parse parseExp "((-142+26)*3)"
  
  ps10 = parse parseExp "(-142+26)*3"
  