module HW7_1 where

import Debug.Trace
import Data.Char

type Pos = (Int, Int)

data State = State {inp :: String, pos :: Pos}
  deriving Show

data Message = Message {posM::Pos, strM::String,  fset::[String]}
instance Show Message where
    show (Message (x,y) unexpected expected) =
        "parse error at (column "++(show x)++", line "++(show y)++"):\n"++
        "unexpected "++unexpected++"\n"++
        "expecting "++(myshow expected)
      where
        myshow [] = ""
        myshow [x] = x
        myshow [x,y] = x++" or "++y
        myshow (x:xs) = x++", "++(myshow xs)

data Reply a = Ok a State Message | Error Message 
instance Show a => Show (Reply a) where
    show (Ok x _ _) = "Ok: "++(show x)
    show (Error msg) = show msg

data Consumed a = Consumed (Reply a) | Empty (Reply a) 
instance Show a => Show (Consumed a) where
    show (Consumed x) = show x
    show (Empty x) = show x

newtype Parser a = Parser {runParser :: State -> Consumed a}

run p inp = runParser p $ State inp (0,0)

instance Monad Parser where
    return x = Parser $ \st -> Empty $ Ok x st (Message (pos st) "" []) 

    {--- !!!! provide definition of bind !!!! ---}
    p >>= f = 


satisfy test = Parser $ \ (State inp pos@(x,y)) -> case inp of
    (c:cs) | test c -> 
        let newPos = if c == '\n' then (0,y+1) else (x+1,y)
            newState = State cs newPos
        in seq newPos $ Consumed $ Ok c newState $ Message pos "" []
    (c:cs) -> Empty $ Error $ Message pos [c] []
    [] -> Empty $ Error $ Message pos "end of input" []

p <|> q = Parser $ \st ->
    case runParser p st of
        Empty (Error msg1) -> case runParser q st of
            Empty (Error msg2) -> mergeErr msg1 msg2
            Empty (Ok x st' msg2) -> mergeOk x st' msg1 msg2
            consumed -> consumed
        Empty (Ok x st' msg1) -> case runParser q st' of
            Empty (Error msg2) -> mergeOk x st' msg1 msg2
            Empty (Ok _ _ msg2) -> mergeOk x st' msg1 msg2
            consumed -> consumed
        consumed -> consumed

mergeOk x inp msg1 msg2 = Empty $ Ok x inp $ merge msg1 msg2

mergeErr msg1 msg2 = Empty $ Error $ merge msg1 msg2

---
--- Note change to merge to use longest unexpected input
---
merge (Message pos inp1 exp1) (Message _ inp2 exp2) = 
    Message pos inp (exp1 ++ exp2) where
        inp = if length inp1 > length inp2 then inp1 else inp2

p <?> exp = Parser $ \st -> case runParser p st of
    Empty (Error msg) -> Empty $ Error $ expect msg exp
    Empty (Ok x st' msg) -> Empty $ Ok x st' $ expect msg exp
    other -> other
  where
    expect (Message pos inp _) exp = Message pos inp [exp]

{--- !!!!

  Provide alternate error message label combinator which works as follows.

  p <?!> label if parser p is invoked at position (x0,y0) and an error
  occurs at position (x1,y1) during the execution of p, then the
  position of the error with the given label should be (x0,y0) and the
  unexpected input should be only the input from (x0,y0) to (x1,y1).

  Examples:
    run ((do char 'h'; char 'e'; char 'l') <?!> "chars") "healing"
    ==>
        parse error at (column 0, line 0):
        unexpected hea
        expecting chars

    run (string "help" <|> string "heal" <|> string "half") "hall of kings"
    ==>
        parse error at (column 0, line 0):
        unexpected hall
        expecting "help", "heal" or "half"

!!!! ---}

P <?!> exp = 


try p = Parser $ \st -> case runParser p st of
    Consumed (Error msg) -> Empty $ Error msg
    other -> other


char c = satisfy (== c) <?> (show c)
letter = satisfy isAlpha <?> "letter"
digit = satisfy isDigit <?> "digit"
whiteSpace = satisfy isSpace <?> "white space"

--- 
--- Note string uses <?!> combinator
---
string s = str s <?!> show s where
    str "" = return ()
    str (c:cs) = do char c; str cs

many1 p = do
    x <- p
    xs <- many1 p <|> return []
    return $ x:xs

many p = many1 p <|> return []

identifier = do 
    x <- letter <|> char '_' 
    xs <- many (letter <|> digit <|> char '_' <|> char '\'')
    return $ x:xs 
  <?> "identifier"


expr0 = do{ string "let"; many1 whiteSpace} <|> identifier
expr1 = do{ try $ string "let"; many1 whiteSpace} <|> identifier
expr2 = try (do string "let"; many1 whiteSpace) <|> identifier

test = do digit <|> (return '0'); letter