{-# LANGUAGE
        DeriveGeneric, FlexibleInstances, MultiParamTypeClasses,
        OverloadedStrings, TypeFamilies
  #-}

module GardGround.Utils.SteParser (
    Parser(..),
    ParserError(..),

    -- creating and running parsers
    runParser,
    makeParser,

    -- parser combinators
    flatMaybe,
    flatEither,
) where

import Control.Applicative (Alternative(..), (<|>))
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.State.Strict

-- misc failure conditions
class (Semigroup e, Show e) => ParserError s e where
    -- | an unknown error (the state might indicate where the error happened)
    perrUnknown :: s -> e

-- a generic parser monad
newtype Parser s e a = Parser { runP :: StateT s (Either e) a }

-- | lift an unwrapped parser into our structures
makeParser :: ((s1 -> Either e1 (a, s1)) -> (s2 -> Either e2 (b, s2))) -> Parser s1 e1 a -> Parser s2 e2 b
makeParser f (Parser (StateT origp)) = Parser . StateT $ f origp

instance Functor (Parser s e) where
    fmap f = Parser . (fmap f) . runP
    {-# INLINE fmap #-}

instance Applicative (Parser s e) where
    pure = Parser . pure
    {-# INLINE pure #-}
    Parser a <*> Parser b = Parser $ a <*> b
    {-# INLINE (<*>) #-}

instance ParserError s e => Alternative (Parser s e) where
    empty = Parser $ StateT (Left . perrUnknown)
    Parser (StateT p1) <|> Parser (StateT p2) = Parser . StateT $ \st ->
      case (p1 st, p2 st) of
        (Right y, _) -> Right y
        (_, Right y) -> Right y
        (Left e1, Left e2) -> Left $ e1 <> e2

instance Monad (Parser s e) where
    return = pure
    Parser a >>= fb = Parser $ a >>= (runP . fb)
    {-# INLINE (>>=) #-}

instance MonadState s (Parser s e) where
    state = Parser . state
    {-# INLINE state #-}

instance MonadError e (Parser s e) where
    throwError e = Parser . StateT . const $ Left e
    catchError (Parser (StateT m)) eh = Parser . StateT $ \st -> case m st of
      Left err -> let (Parser (StateT ehp)) = eh err in ehp st
      Right x -> Right x

runParser :: s -> Parser s e a -> Either e (a, s)
runParser st (Parser p) = runStateT p st

-- some simple parser combinators

-- | shave an maybe from the parser result and throw an unknown error if it got Nothing
flatMaybe :: ParserError s e => Maybe a -> Parser s e a
flatMaybe mb = Parser . StateT $ case mb of
    Nothing -> Left . perrUnknown
    Just x -> \st -> Right (x, st)

-- | shave an either from the parser result and possibly throw errors into the parser itself
flatEither :: Either e a -> Parser s e a
flatEither eith = Parser . StateT $ \st -> fmap (\y -> (y, st)) eith