Propositional Formula Parser

module Main where

import Control.Applicative
import Data.Char

newtype Parser a = Parser { runParser :: String -> [(a, String)] }
-- The return type of a function wrapped inside a Parser data type is not `Maybe`,
-- but rather a list to provide flexibility to the Parsing object.

item :: Parser Char
item = Parser $ \input -> case input of
                              []     -> []
                              (x:xs) -> [(x,xs)]

instance Functor Parser where
--  fmap :: (a -> b) -> Parser a -> Parser b
    fmap f p = Parser $ \input -> case runParser p input of
                                      []          -> []
                                      [(v, rest)] -> [(f v, rest)]

instance Applicative Parser where
--  pure :: a -> Parser a
    pure x = Parser $ \input -> [(x, input)]
--     <*> :: Parser (a -> b) -> Parser a -> Parser b
    pf <*> pa = Parser $ \input -> case runParser pf input of
                                       []          -> []
                                       [(f, rest)] -> runParser (fmap f pa) rest

instance Monad Parser where
--  return :: a -> Parser a
    return = pure
--   (>>=) :: Parser a -> (a -> Parser b) -> Parser b
    p >>= f = Parser $ \input -> case runParser p input of
                                     []          -> []
                                     [(x, rest)] -> runParser (f x) rest

instance Alternative Parser where
--  empty :: Parser a
    empty = Parser $ \input -> []

--   (<|>) :: Parser a -> Parser a -> Parser a
    p <|> q = Parser $ \input -> case runParser p input of
                                     []         -> runParser q input
                                     [(x, out)] -> [(x, out)]

predicate :: (Char -> Bool) -> Parser Char
predicate p = do
    x <- item
    if p x then return x else empty

upper :: Parser Char
upper = predicate isUpper

alphanum :: Parser Char
alphanum = predicate isAlphaNum

restVariable :: Parser Char
restVariable = predicate (\c -> isUpper c || isDigit c || c == '\'')

character :: Char -> Parser Char
character x = predicate (== x)

string :: String -> Parser String
string []     = return []
string (x:xs) = do
    character x
    string xs
    return $ x:xs

chain :: Parser a -> Parser s -> Parser [a]
chain item separator = do
    i  <- item
    is <- many (do
        separator
        item)
    return $ i:is

leftAssociative :: (a -> a -> a) -> Parser a -> Parser s -> Parser a
leftAssociative f item separator = do
    is <- chain item separator
    return $ foldl1 f is

rightAssociative :: (a -> a -> a) -> Parser a -> Parser s -> Parser a
rightAssociative f item separator = do
    is <- chain item separator
    return $ foldr1 f is

-- =========================================== --

data Tree
    = Var String
    | Not Tree
    | Conj Tree Tree
    | Disj Tree Tree
    | Impl Tree Tree

instance Show Tree where
    show (Var v)    = v
    show (Not t)    = "(!"   ++ show t ++ ")"
    show (Conj x y) = "(&,"  ++ show x ++ "," ++ show y ++ ")"
    show (Disj x y) = "(|,"  ++ show x ++ "," ++ show y ++ ")"
    show (Impl x y) = "(->," ++ show x ++ "," ++ show y ++ ")"

implication :: Parser Tree
implication = rightAssociative Impl disjunction (string "->")

disjunction :: Parser Tree
disjunction = leftAssociative Disj conjunction (character '|')

conjunction :: Parser Tree
conjunction = leftAssociative Conj negation (character '&')

negation :: Parser Tree
negation = do
        character '!'
        y <- negation
        return $ Not y
    <|> variable
    <|> do
        character '('
        x <- implication
        character ')'
        return x

variable :: Parser Tree
variable = do
    x  <- upper
    xs <- many restVariable
    return . Var $ x:xs

-- =========================================== --

parse :: String -> Tree
parse given
    = fst
    . head
    . runParser implication
    . filter (not . isSpace)
    $ given

main :: IO ()
main = do
    given <- getLine
    print . parse $ given