Parser.hs

{-# LANGUAGE CPP                   #-}
{-# LANGUAGE DeriveFunctor         #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}

module Language.SexpGrammar.Parser where

import Control.Applicative
#if MIN_VERSION_mtl(2, 2, 0)
import Control.Monad.Except
#else
import Control.Monad.Error
#endif

data Result a
  = Success a
  | Failure String
  deriving (Functor)

instance Applicative Result where
  pure = Success
  Success f <*> Success a = Success (f a)
  Failure a <*> Success _ = Failure a
  Success _ <*> Failure b = Failure b
  Failure a <*> Failure b = Failure $ a ++ "\n" ++ b

instance Monad Result where
  return = Success
  Failure a >>= _ = Failure a
  Success a >>= f = f a

instance Alternative Result where
  empty = Failure "empty"
  Success a <|> _ = Success a
  Failure _ <|> Success b = Success b
  Failure a <|> Failure b = Failure (a ++ "\n" ++ b)

instance MonadPlus Result where
  mzero = empty
  mplus = (<|>)

instance MonadError [Char] Result where
  throwError = Failure
  catchError res handle =
    case res of
      Success a -> Success a
      Failure b -> handle b

runR :: (a -> Result b) -> a -> Either String b
runR parser a =
  case parser a of
    Success a -> Right a
    Failure b -> Left $ "List of failures:\n" ++ b