{----
 - Generic.hs - generalized parser with state, error propogation,
 -              backtracking.
 ----
 - Author: Jesse Rudolph <jesse.rudolph@gmail.com>
 - See LICENSE for licensing details
 ----------------------------------------------------------------- -}


-- |GParser is a generalized backtracking parser combinator with state, error propogation and easy to use associativity primitves.
module Language.Noodle.Parsing.Generic where

-- |'Result' encompases error propogation, parameterized over 'st' state type, 'tok' token type, and 'res' the monadic return value
data Result st tok res
    = Success res st [tok]
    -- ^'Success result state token_stream'
    | Failure String st
    -- ^'Failure error_message state'

instance (Show st, Show tok, Show res) => Show (Result st tok res) where
    show (Success res st toks) = "Ok: " ++ show res ++ show st ++ show toks
    show (Failure msg st) = "Error: " ++ msg ++ "\n" ++ "state dump: " ++ show st

-- |a 'GParser' computes some result 'res', based on a stream of tokens 'tok' having a state of type 'st'
newtype GParser st tok res = P ((st,[tok]) -> Result st tok res)


-- monad instance for parsers applied to state and token types
instance Monad (GParser s t) where
  return value     = P (\(state,tokens) -> Success value state tokens)
  fail message     = P (\(state,_) -> Failure message state)
  (>>=) (P f) cont = P body where
      body (state,tokens)
            = let first = f (state,tokens)
              in case first of
                (Failure msg fstate)             -> Failure msg fstate -- encountered failure, propogate
                (Success result sstate stokens)  -> appcont result sstate stokens -- ok, apply continuation
      appcont result state tokens
            = let (P rest) = cont result in rest (state,tokens)



{-- TOKEN PARSING PRIMATIVES --}

-- |consume one token and return it
getTok :: GParser st tok tok
getTok = P body
    where body (state,c:cs) = Success c state cs
          body (fstate,[])  = Failure "unexpected end of input" fstate


-- |lookahead at the rest of the tokens left in the input
lookToks :: GParser st tok [tok]
lookToks = P body
    where body (state,cs) = Success cs state cs


-- |consume one token and return it if the result of applying the predicate to it is true, otherwise fail with 'unexpected token'
getTokIf :: (tok -> Bool) -> GParser st tok tok
getTokIf pred
    = do tok <- getTok
         case pred tok of
            True  -> return tok
            False -> fail "unexpected token"


-- |succeed if all of the input has been consumed, otherwise complain about expecting the end of the input
inputEnd :: GParser st tok ()
inputEnd = do rest <- lookToks
              case rest of
                [] -> return ()
                _  -> fail "expected end of input"


{-- STATE PRIMATIVES --}

-- |return the current state
getSt :: GParser st tok st
getSt = P body where
    body (state,tokens) = Success state state tokens


-- |change the value of the current state
putSt :: st -> GParser st tok ()
putSt st = P body where
    body (_,cs) = Success () st cs


-- |apply some update function to the current state
modSt :: (st -> st) -> GParser st tok ()
modSt f = do st <- getSt
             putSt $ f st



{-- DECISION AND REPETITION COMBINATORS --}

-- |apply the parser as many times as is possible, and return a list of the results
many :: GParser st tok res -> GParser st tok [res]
many p = many1 p <|> return []



-- |apply the parser one or more times, and return a list of the results. Fails the first application fails
many1 :: GParser st tok res -> GParser st tok [res]
many1 p = do first <- p
             rest <- many p
             return (first:rest)


-- |parse many1 p's seperated by sep
sepBy1 :: GParser st tok res -> GParser st tok b -> GParser st tok [res]
sepBy1 p sep =
    do first <- p
       rest  <- many (sep >> p)
       return (first:rest)


-- |parse many p's seperated by sep
sepBy :: GParser st tok res -> GParser st tok b -> GParser st tok [res]
sepBy p sep = do v <- pMaybe $ sepBy1 p sep
                 case v of
                    Just v' -> return v'
                    Nothing -> return []


-- |if the left operand <|> results in failure, apply the right operand. state and token stream changes are not carried over to right operand
(<|>) :: GParser st tok res -> GParser st tok res -> GParser st tok res
(P p) <|> other = P body where
    body input = case p input of
                      Failure m st -> let (P next) = other in next input
                      success      -> success


-- |the first successful parser to succeed is parsed, if none, fail
choice :: [GParser st tok res] -> GParser st tok res
choice []     = error "violation of invariant: 'choice []' has undefined behavior" -- only reachable if intentionally invoked with an empty list
choice [p]    = p
choice (p:ps) = p <|> choice ps


-- |try to apply parser p, return Just res on success, or Nothing on fail
pMaybe :: GParser st tok res -> GParser st tok (Maybe res)
pMaybe p = pJust <|> return Nothing where
    pJust = do v <- p
               return $ Just v


-- |try to parse either p1 or p2, returning Left a for p1, or Right b for p2
pEither :: GParser st tok a -> GParser st tok b -> GParser st tok (Either a b)
pEither p1 p2 =
    do v <- pMaybe p1
       case v of
            Just a -> return $ Left a
            Nothing ->
                do v <- p2
                   return $ Right v


{-- PARSER APPLICATION --}

-- |apply a 'GParser' computation to state and a token stream, returning a value of type 'Result'
runp :: GParser st tok res -> st -> [tok] -> Result st tok res
runp (P parser) state toks = parser (state,toks)