quickfailparser.hs

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

module Main where

import Lib

import Control.Applicative
import Data.ByteString (ByteString)
import qualified Data.Attoparsec.ByteString as A

newtype QuickFailParser a = QFParser { unQF :: A.Parser (Either String a) }

instance Functor QuickFailParser where
    fmap f (QFParser parser) = QFParser (fmap (fmap f) parser)

instance Applicative QuickFailParser where
    pure = QFParser . return . Right
    (QFParser f) <*> (QFParser x) = QFParser $ do
        f' <- f
        case f' of
            Right f'' -> do
                x' <- x
                case x' of
                    Right x'' -> return (Right (f'' x''))
                    Left err -> return (Left err)
            Left err -> return (Left err)

instance Alternative QuickFailParser where
    empty = QFParser empty
    QFParser left <|> QFParser right = QFParser (left <|> right)

instance Monad QuickFailParser where
    return = pure
    fail = QFParser . fail
    (QFParser x) >>= f = QFParser $ do
        input <- x
        case input of
            Left err -> return (Left err)
            Right r -> unQF (f r)

liftQF = QFParser . fmap Right

quickFail :: String -> QuickFailParser a
quickFail = QFParser . return . fail 

string :: ByteString -> QuickFailParser ByteString
string = liftQF . A.string

parseOnly :: QuickFailParser a -> ByteString -> Either String a
parseOnly p s = collapseL (A.parseOnly (unQF p) s)
    where
        collapseL :: Either l (Either l r) -> Either l r
        collapseL (Right result) = result
        collapseL (Left l) = Left l


myThing :: QuickFailParser ByteString
myThing = (string "hell" >> string "o" >> quickFail "nooo") <|> string "hello"

main :: IO ()
main = print $ parseOnly myThing "hello"