-- Example Parser Combinators as described in https://tgdwyer.github.io/parsercombinators/
--
import qualified Numeric as N

data ParseError
  = UnexpectedEof
  | ExpectedEof Input
  | UnexpectedChar Char
  | UnexpectedString String
  deriving (Eq, Show)

data ParseResult a
  = Error ParseError
  | Result Input a
  deriving (Eq)

type Input = String

newtype Parser a = P {parse :: Input -> ParseResult a}

-- Result Instances

instance (Show a) => Show (ParseResult a) where
  show (Result i a) = "Result >" ++ i ++ "< " ++ show a
  show (Error UnexpectedEof) = "Unexpected end of stream"
  show (Error (UnexpectedChar c)) = "Unexpected character: " ++ show [c]
  show (Error (UnexpectedString s)) = "Unexpected string: " ++ show s
  show (Error (ExpectedEof i)) =
    "Expected end of stream, but got >" ++ show i ++ "<"

instance Functor ParseResult where
  fmap f (Result i a) = Result i (f a)
  fmap _ (Error e) = Error e

-- Parser Instances

instance Functor Parser where
  fmap f (P p) = P (fmap f . p)

instance Applicative Parser where
  -- creates a Parser that always succeeds with the given input
  pure x = P (`Result` x)

  (<*>) p q = p >>= (\f -> q >>= (pure . f))

instance Monad Parser where
  (>>=) (P p) f =
    P
      ( \i -> case p i of
          Result rest x -> parse (f x) rest
          Error e -> Error e
      )

-- Support functions

isErrorResult :: ParseResult a -> Bool
isErrorResult (Error _) = True
isErrorResult _ = False

readFloats :: (RealFrac a) => String -> Maybe (a, String)
readFloats str =
  case N.readSigned N.readFloat str of
    ((a, s) : _) -> Just (a, s)
    _ -> Nothing

readHex :: (Num a, Eq a) => String -> Maybe (a, String)
readHex str = case N.readHex str of
  ((a, s) : _) -> Just (a, s)
  _ -> Nothing

readInt :: String -> Maybe (Int, String)
readInt s = case reads s of
  [(x, rest)] -> Just (x, rest)
  _ -> Nothing
  
-- | Produces a parser that always fails with 'UnexpectedChar' using the given
-- character.
unexpectedCharParser :: Char -> Parser a
unexpectedCharParser = P . const . Error . UnexpectedChar

-- | Return a parser that produces the given character but fails if:
--   * the input is empty; or
--   * the produced character is not equal to the given character.
-- >>> parse (is 'c') "c"
-- Result >< 'c'
-- >>> isErrorResult (parse (is 'c') "")
-- True
-- >>> isErrorResult (parse (is 'c') "b")
-- True
is :: Char -> Parser Char
is c = do
  v <- character
  let next = if v == c then pure else const $ unexpectedCharParser v
  next c

-- | Return a parser that succeeds with a character off the input or fails with
-- an error if the input is empty.
-- >>> parse character "abc"
-- Result >bc< 'a'
-- >>> isErrorResult (parse character "")
-- True
character :: Parser Char
character = P parseit
  where
    parseit "" = Error UnexpectedEof
    parseit (c : s) = Result s c

-- | Return a parser that tries the first parser for a successful value, then:
--   * if the first parser succeeds then use this parser; or
--   * if the first parser fails, try the second parser.
--
-- >>> parse (character ||| pure 'v') ""
-- Result >< 'v'
-- >>> parse (failed UnexpectedEof ||| pure 'v') ""
-- Result >< 'v'
-- >>> parse (character ||| pure 'v') "abc"
-- Result >bc< 'a'
-- >>> parse (failed UnexpectedEof ||| pure 'v') "abc"
-- Result >abc< 'v'
(|||) :: Parser a -> Parser a -> Parser a
p1 ||| p2 =
  P
    ( \i ->
        let f (Error _) = parse p2 i
            f r = r
         in f $ parse p1 i
    )

-- chain p op parses 1 or more instances of p
-- separated by op
-- (see chainl1 from Text.Parsec)
chain :: Parser a -> Parser (a -> a -> a) -> Parser a
chain p op = p >>= rest
  where
    rest a =
      ( do
          f <- op
          b <- p
          rest (f a b)
      )
        ||| pure a

-- Parser for Australian land-line phone numbers

phoneNumber :: Parser [Char]
phoneNumber = fullNumber ||| (("03" ++) <$> basicNumber)

fullNumber :: Parser [Char]
fullNumber = do
  ac <- areaCode
  n <- basicNumber
  pure (ac ++ n)

basicNumber :: Parser [Char]
basicNumber = do
  spaces
  first <- fourDigits
  spaces
  second <- fourDigits
  pure (first ++ second)

fourDigits :: Parser [Char]
fourDigits = do
  a <- digit
  b <- digit
  c <- digit
  d <- digit
  pure [a, b, c, d]

areaCode :: Parser [Char]
areaCode = do
  spaces
  is '('
  a <- digit
  b <- digit
  is ')'
  pure [a, b]

spaces :: Parser ()
spaces = (is ' ' >> spaces) ||| pure ()

digit :: Parser Char
digit = is '0' ||| is '1' ||| is '2' ||| is '3' ||| is '4' ||| is '5' ||| is '6' ||| is '7' ||| is '8' ||| is '9'

-- | Parse an expression of integers, +, -, *
--
-- BNF Grammar:
-- <expr> ::= <term> { <add> <term> }
-- <term> ::= <number> { "*" <number> }
-- <add> ::= "+" | "-"
--
-- >>> parseCalc " 1 + 2* 3 "
-- Result > < Plus (Number 1) (Times (Number 2) (Number 3))
--
-- >>> parseCalc " 6 *4 + 3- 8 *  2"
-- Result >< Minus (Plus (Times (Number 6) (Number 4)) (Number 3)) (Times (Number 8) (Number 2))
parseCalc :: String -> ParseResult Expr
parseCalc = parse expr

data Expr = Plus Expr Expr | Minus Expr Expr | Times Expr Expr | Number Integer
  deriving (Show)
  
eval :: Expr -> Integer
eval (Number i) = i
eval (Plus x y) = (eval x) + (eval y)
eval (Minus x y) = (eval x) - (eval y)
eval (Times x y) = (eval x) * (eval y)

add :: Parser (Expr -> Expr -> Expr)
add = (op '+' >> pure Plus) ||| (op '-' >> pure Minus)

times :: Parser (Expr -> Expr -> Expr)
times = op '*' >> pure Times

expr :: Parser Expr
expr = chain term add

term :: Parser Expr
term = chain number times

-- | parse a single char operator
op :: Char -> Parser Char
op c = do
  spaces
  is c
  pure c

-- | parse a single digit Number
number :: Parser Expr
number = spaces >> Number . read . (: []) <$> digit

main = do
  putStrLn "PARSER EXAMPLES"
  putStrLn "==============="
  putStrLn ""
  putStrLn "Parsing Australian land-line phone numbers:"
  putStrLn ""
  putStrLn "A full number with area code:"
  let full = " (02) 9583 1762"
  putStrLn $ ">" ++ full ++ "<"
  putStrLn $ show $ parse phoneNumber full
  putStrLn ""
  putStrLn "Should default a basicNumber to (03) area code:"
  let basic = "9583  1762 "
  putStrLn $ ">" ++ basic ++ "<"
  putStrLn $ show $ parse phoneNumber basic
  putStrLn ""
  putStrLn "Basic calculator:"
  putStrLn ""
  let expr1 = " 1 + 2* 3 "
  putStrLn $ ">" ++ expr1 ++ "<"
  let (Result _ r1) = parseCalc expr1
  putStrLn $ show r1
  putStrLn $ "Evaluates to: " ++ (show $ eval r1)
  putStrLn ""
  let expr2 = " 6 *4 + 3- 8 *  2"
  putStrLn $ ">" ++ expr2 ++ "<"
  let (Result _ r2) = parseCalc expr2
  putStrLn $ show r2
  putStrLn $ "Evaluates to: " ++ (show $ eval r2)