WeberLogic-0.1.2: WeberLogic/Parser.lhs

> module WeberLogic.Parser (
>   Letter(Name, Variable), 
>   LogicExp(
>     Not, Or, Xor, And, Implies, Iff, Nand, Nor, Predicate, Universal,
>     Existential),
>   readExp, readArg) 
> where 

> import Prelude hiding (and, or)
> import Data.List (union)
> import Text.Printf
> import Text.Parsec as Parsec
> import Text.Parsec hiding (Error)
> import Text.Parsec.String
> import Text.Parsec.Expr
> import Text.Parsec.Token
> import Text.Parsec.Language
> import qualified Data.List as List

> data Letter
>     = Name Char
>     | Variable Char

> data LogicExp
>     = Not LogicExp
>     | Or LogicExp LogicExp
>     | Xor LogicExp LogicExp
>     | And LogicExp LogicExp
>     | Implies LogicExp LogicExp
>     | Iff LogicExp LogicExp
>     | Nand LogicExp LogicExp
>     | Nor LogicExp LogicExp
>     | Predicate Char [Letter]
>     | Universal Letter LogicExp
>     | Existential LogicExp

> readExp :: String -> Either String LogicExp
> readExp str = case parse parseExp0 "readExp" str of 
>       Right val -> Right val
>       Left val -> Left $ show val

> readArg :: String -> Either String [LogicExp]
> readArg str = case parse parseArg "readArg" str of 
>       Right val -> Right val
>       Left val -> Left $ show val

> parseExp0 :: Parser LogicExp
> parseExp0 = do 
>               x <- parseExp1
>               eof
>               return x

> parseExp1 :: Parser LogicExp
> parseExp1 = try $ do
>            x  <- parseExp2
>            x' <- parseExp1' x
>            return x'

> parseExp1' :: LogicExp -> Parser LogicExp
> parseExp1' x = try $ do
>            string "<->"
>            y <- parseExp2
>            return $ Iff x y
>         <|> do
>            return x

> parseExp2 :: Parser LogicExp
> parseExp2 = try $ do
>             x  <- parseExp3
>             x' <- parseExp2' x
>             return x'

> parseExp2' :: LogicExp -> Parser LogicExp
> parseExp2' x = try $ do
>                string "->"
>                y <- parseExp2
>                return $ Implies x y
>             <|> do
>                return x
 
> parseExp3 :: Parser LogicExp
> parseExp3 = try $ do 
>             lhs <- parseExp4
>             rhs <- parseExp3' lhs
>             return rhs
>          <|> do 
>             lhs <- parseExp4
>             return lhs
 
 
> parseOperator3 :: (LogicExp -> LogicExp -> LogicExp) -> 
>                     String -> LogicExp -> Parser (LogicExp)
> parseOperator3 connective symbol lhs
>     = try $ do
>         string symbol
>         rhs <- parseExp4
>         exp2 <- parseExp3' $ connective lhs rhs
>         return exp2
 
> parseExp3' :: LogicExp -> Parser (LogicExp)
> parseExp3' lhs =  parseOperator3 And "&" lhs
>               <|> parseOperator3 Or "+" lhs
>               <|> parseOperator3 Nand "|" lhs
>               <|> parseOperator3 Nor  "/" lhs
>               <|> parseOperator3 Xor "⊕" lhs
>               <|> do
>                     return lhs
 
> parseExp4 :: Parser LogicExp
> parseExp4 = try $ do
>             string "~"
>             x <- parseExp4
>             return $ Not x
>          <|> (try $ do
>             p <- upper
>             xs <- parsePredicateLetters
>             return $ Predicate p xs)
>          <|> do
>             char '('
>             x <- parseExp1
>             char ')'
>             return $ x
 
> parsePredicateLetters :: Parser ([Letter])
> parsePredicateLetters
>           = try $ do
>               x <- oneOf "abcefghijklmnopqrst"
>               xs <- parsePredicateLetters 
>               return ((Name x):xs)
>          <|> (try $ do
>               x <- oneOf "uvwxyz"
>               xs <- parsePredicateLetters 
>               return ((Variable x):xs))
>          <|> do
>               return []

> parseArg :: Parser [LogicExp]
> parseArg = try $ do
>              xs <- parseArg'
>              return xs
>          <|> do 
>              x <- parseExp1
>              spaces
>              xs <- parseArg'
>              return $ x : xs

> parseArg' :: Parser [LogicExp]
> parseArg' = try $ do
>              string "|-"
>              spaces
>              x <- parseExp1
>              return [x]
>          <|> do 
>              char ','
>              spaces
>              x <- parseExp1
>              spaces
>              xs <- parseArg'
>              return $ x : xs