• API
• FAQ
• Tools
• Archive
SHARE
TWEET

# Propositional Formula Parser Condiamond  Mar 21st, 2020 (edited) 130 Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
1. module Main where
2.
3. import Control.Applicative
4. import Data.Char
5.
6. newtype Parser a = Parser { runParser :: String -> [(a, String)] }
7. -- The return type of a function wrapped inside a Parser data type is not `Maybe`,
8. -- but rather a list to provide flexibility to the Parsing object.
9.
10. item :: Parser Char
11. item = Parser \$ \input -> case input of
12.                               []     -> []
13.                               (x:xs) -> [(x,xs)]
14.
15. instance Functor Parser where
16. --  fmap :: (a -> b) -> Parser a -> Parser b
17.     fmap f p = Parser \$ \input -> case runParser p input of
18.                                       []          -> []
19.                                       [(v, rest)] -> [(f v, rest)]
20.
21. instance Applicative Parser where
22. --  pure :: a -> Parser a
23.     pure x = Parser \$ \input -> [(x, input)]
24. --     <*> :: Parser (a -> b) -> Parser a -> Parser b
25.     pf <*> pa = Parser \$ \input -> case runParser pf input of
26.                                        []          -> []
27.                                        [(f, rest)] -> runParser (fmap f pa) rest
28.
30. --  return :: a -> Parser a
31.     return = pure
32. --   (>>=) :: Parser a -> (a -> Parser b) -> Parser b
33.     p >>= f = Parser \$ \input -> case runParser p input of
34.                                      []          -> []
35.                                      [(x, rest)] -> runParser (f x) rest
36.
37. instance Alternative Parser where
38. --  empty :: Parser a
39.     empty = Parser \$ \input -> []
40.
41. --   (<|>) :: Parser a -> Parser a -> Parser a
42.     p <|> q = Parser \$ \input -> case runParser p input of
43.                                      []         -> runParser q input
44.                                      [(x, out)] -> [(x, out)]
45.
46. predicate :: (Char -> Bool) -> Parser Char
47. predicate p = do
48.     x <- item
49.     if p x then return x else empty
50.
51. upper :: Parser Char
52. upper = predicate isUpper
53.
54. alphanum :: Parser Char
55. alphanum = predicate isAlphaNum
56.
57. restVariable :: Parser Char
58. restVariable = predicate (\c -> isUpper c || isDigit c || c == '\'')
59.
60. character :: Char -> Parser Char
61. character x = predicate (== x)
62.
63. string :: String -> Parser String
64. string []     = return []
65. string (x:xs) = do
66.     character x
67.     string xs
68.     return \$ x:xs
69.
70. chain :: Parser a -> Parser s -> Parser [a]
71. chain item separator = do
72.     i  <- item
73.     is <- many (do
74.         separator
75.         item)
76.     return \$ i:is
77.
78. leftAssociative :: (a -> a -> a) -> Parser a -> Parser s -> Parser a
79. leftAssociative f item separator = do
80.     is <- chain item separator
81.     return \$ foldl1 f is
82.
83. rightAssociative :: (a -> a -> a) -> Parser a -> Parser s -> Parser a
84. rightAssociative f item separator = do
85.     is <- chain item separator
86.     return \$ foldr1 f is
87.
88. -- =========================================== --
89.
90. data Tree
91.     = Var String
92.     | Not Tree
93.     | Conj Tree Tree
94.     | Disj Tree Tree
95.     | Impl Tree Tree
96.
97. instance Show Tree where
98.     show (Var v)    = v
99.     show (Not t)    = "(!"   ++ show t ++ ")"
100.     show (Conj x y) = "(&,"  ++ show x ++ "," ++ show y ++ ")"
101.     show (Disj x y) = "(|,"  ++ show x ++ "," ++ show y ++ ")"
102.     show (Impl x y) = "(->," ++ show x ++ "," ++ show y ++ ")"
103.
104. implication :: Parser Tree
105. implication = rightAssociative Impl disjunction (string "->")
106.
107. disjunction :: Parser Tree
108. disjunction = leftAssociative Disj conjunction (character '|')
109.
110. conjunction :: Parser Tree
111. conjunction = leftAssociative Conj negation (character '&')
112.
113. negation :: Parser Tree
114. negation = do
115.         character '!'
116.         y <- negation
117.         return \$ Not y
118.     <|> variable
119.     <|> do
120.         character '('
121.         x <- implication
122.         character ')'
123.         return x
124.
125. variable :: Parser Tree
126. variable = do
127.     x  <- upper
128.     xs <- many restVariable
129.     return . Var \$ x:xs
130.
131. -- =========================================== --
132.
133. parse :: String -> Tree
134. parse given
135.     = fst