resolution/app/Parser.hs

module Parser (parseFormula, parseFormulaE) where

import Lexer
    ( comma,
      dot,
      identifier,
      parens,
      reserved,
      reservedOp,
      whiteSpace )
import FOLSyntax ( Formula(..), Term(..) )
import Text.Parsec ( sepBy, eof, (<?>), (<|>), parse, try )
import Text.Parsec.String (Parser)
import Data.Functor ( ($>) )

import Prelude hiding (pred, all)
import Data.Either.Extra (mapLeft)


term :: Parser Term
term = try fun <|> var

fun :: Parser Term
fun =
    Fun
        <$> identifier
        <*> parens (term `sepBy` comma)

var :: Parser Term
var = Var <$> identifier


formula :: Parser Formula
formula = neg <|> impl <|> all <|> exists <|> pred <|> true <|> false <?> "formula"

pred :: Parser Formula
pred =
    Pred
        <$> identifier
        <*> parens (term `sepBy` comma)

neg :: Parser Formula
neg =
    Neg
        <$> (reservedOp "!" *> negFormula)
    where negFormula = neg <|> all <|> exists <|> true <|> false <|> parens formula <|> pred <?> "formula under neg"

impl :: Parser Formula
impl = foldr1 Impl <$> implFormula `sepBy` reservedOp "->"
    where implFormula = neg <|> disj <|> conj <|> all <|> exists <|> true <|> false <|> parens formula <|> pred <?> "formula under impl"

disj :: Parser Formula
disj = foldr1 Disj <$> disjFormula `sepBy` reservedOp "\\/"
    where disjFormula = neg <|> conj <|> all <|> exists <|> true <|> false <|> parens formula <|> pred <?> "formula under disj"

conj :: Parser Formula
conj = foldr1 Conj <$> conjFormula `sepBy` reservedOp "/\\"
    where conjFormula = neg <|> all <|> exists <|> true <|> false <|> parens formula <|> pred <?> "formula under conj"

all :: Parser Formula
all =
    All
        <$> (reserved "forall" *> identifier)
        <*> (dot *> formula)

exists :: Parser Formula
exists =
    Exists
        <$> (reserved "exists" *> identifier)
        <*> (dot *> formula)

true :: Parser Formula
true = reserved "true" $> T

false :: Parser Formula
false = reserved "false" $> F

-- runners
contents :: Parser a -> Parser a
contents p = do
  whiteSpace
  r <- p
  eof
  return r


fromRight :: Either a b -> b
fromRight (Left _) = error "fromRight called on left value!"
fromRight (Right b) = b

parseFormulaE :: String -> Either String Formula
parseFormulaE str = mapLeft show (parse (contents formula) "stdin" str)

parseFormula :: String -> Formula
parseFormula = fromRight . parse (contents formula) "stdin"