Week 3 Lecture 2

1
import Control.Applicative (Alternative (empty, many, some), asum)
2
import Control.Monad (ap, liftM, void)
3
import Data.Char (isAlpha, isSpace)
4
import GHC.Exts.Heap (StgTSOProfInfo)
5
import GHC.Internal.Base (Alternative ((<|>)))
6
7
data BExp
8
  = Lit Bool
9
  | Not BExp
10
  | Var String
11
  | And BExp BExp
12
  | Or BExp BExp
13
  deriving (Eq, Ord, Show)
14
15
-- var = ? any non empty sequence of alphabhetic characters ?
16
-- bexp ::= "true"
17
--        | "false"
18
--        | var
19
--        | "not" bexp
20
--        | bexp "and" bexp
21
--        | bexp "or" bexp
22
23
data Parser a = Parser ((Int, String) -> Either (Int, String) (a, (Int, String)))
24
25
instance Functor Parser where
26
  fmap :: (a -> b) -> Parser a -> Parser b
27
  fmap = liftM
28
29
instance Applicative Parser where
30
  pure a = Parser $ \s -> Right (a, s)
31
  (<*>) = ap
32
33
instance Monad Parser where
34
  Parser a >>= f = Parser $ \s -> do
35
    (a', s') <- a s
36
    let (Parser b) = f a'
37
    b s'
38
39
instance Alternative Parser where
40
  empty = Parser $ \(pos, s) -> Left (pos, "All branches exhausted")
41
  (Parser p1) <|> (Parser p2) = Parser $ \s -> case p1 s of
42
    Left err -> p2 s
43
    Right a -> pure a
44
45
satisfy :: (Char -> Bool) -> Parser Char
46
satisfy p = Parser $ \(pos, s) ->
47
  case s of
48
    "" -> Left (pos, "Empty input")
49
    c : (cs) ->
50
      if p c
51
        then
52
          pure (c, (pos + 1, cs))
53
        else Left (pos, "Invalid character: " ++ [c])
54
55
eof :: Parser ()
56
eof = Parser end
57
 where
58
  end :: (Int, String) -> Either (Int, String) ((), (Int, String))
59
  end s@(_, "") = pure ((), s)
60
  end (pos, _) = Left (pos, "EOF expected")
61
62
instance MonadFail Parser where
63
  fail s = Parser (\(pos, _) -> Left (pos, s))
64
65
spaces :: Parser ()
66
spaces = (many $ satisfy isSpace) *> pure ()
67
68
lexeme :: Parser a -> Parser a
69
lexeme p = do
70
  x <- p
71
  spaces
72
  pure x
73
74
parseString :: String -> Parser ()
75
parseString "" = pure ()
76
parseString (c : cs) = do
77
  satisfy (== c)
78
  parseString cs
79
80
lString :: String -> Parser ()
81
lString s = lexeme $ loop s
82
 where
83
  loop "" = pure ()
84
  loop (c : cs) = satisfy (== c) *> loop cs
85
86
parseBool :: Parser Bool
87
parseBool =
88
  do
89
    parseString "true"
90
    spaces
91
    pure True
92
    <|> do
93
      parseString "false"
94
      spaces
95
      pure False
96
97
fails :: (Alternative f) => f a -> f Bool
98
fails a = (False <$ a) <|> (pure True)
99
100
notFollowedBy :: (Alternative m, MonadFail m) => m a -> m b -> m a
101
notFollowedBy a b = do
102
  ra <- a
103
  rb <- fails b
104
  if rb then pure ra else fail "notFollowedBy violation"
105
106
-- notFollowedBy2 :: Parser a -> Parser ()
107
-- notFollowedBy2 a = do
108
--     a' <- a
109
--     Parser (\b -> )
110
111
lKeyword :: String -> Parser ()
112
lKeyword s = lexeme $ notFollowedBy (loop s) (satisfy isAlpha)
113
 where
114
  loop "" = pure ()
115
  loop (c : cs) = satisfy (== c) *> loop cs
116
117
pTrue :: Parser ()
118
pTrue = lKeyword "true"
119
120
pFalse :: Parser ()
121
pFalse = lKeyword "false"
122
123
pAnd :: Parser ()
124
pAnd = lKeyword "and"
125
126
pOr :: Parser ()
127
pOr = lKeyword "or"
128
129
pNot :: Parser ()
130
pNot = lKeyword "not"
131
132
pBool :: Parser Bool
133
pBool = (pTrue *> pure True) <|> (pFalse *> pure False)
134
135
keywords :: [String]
136
keywords = ["true", "false", "and", "or", "not"]
137
138
pVar :: Parser String
139
pVar = lexeme $ do
140
  s <- some $ satisfy isAlpha
141
  if elem s keywords
142
    then
143
      fail ""
144
    else pure s
145
146
-- atom :== "true"
147
--       |  "false"
148
--       |  var
149
--       |  not bexp
150
151
-- bexp' ::= epsilon
152
--         | "and" atom bexp'
153
--         | "or" atom bexp'
154
--
155
-- bexp ::= atom bexp'
156
157
-- delim? either, or he just does- this, yes
158
-- for now, yes, also assoc is not mentioned yet
159
160
lLParen :: Parser ()
161
lLParen = lexeme $ void $ satisfy (== '(')
162
lRParen :: Parser ()
163
lRParen = lexeme $ void $ satisfy (== '(')
164
165
parens :: Parser a -> Parser a
166
parens a = lLParen *> a <* lRParen
167
168
pAtom :: Parser BExp
169
pAtom =
170
  asum
171
    [ (pBool >>= pure . Lit)
172
    , (pVar >>= pure . Var)
173
    , (Not <$> (pNot *> pAtom))
174
    , -- ( :3 ) -- Invalid character: :
175
      parens pBExp
176
    ]
177
178
pBExp' :: BExp -> Parser BExp
179
pBExp' x =
180
  asum
181
    [ (And x <$> (pAnd *> pAtom))
182
    , (Or x <$> (pOr *> pAtom))
183
    , pure x
184
    ]
185
186
-- pAtom < pAnd < pOr
187
188
pBExpAnd :: BExp -> Parser BExp
189
pBExpAnd x =
190
  ( do
191
      y <- pAnd *> pAtom
192
      pBExpAnd (And x y)
193
  )
194
    <|> pure x
195
196
pBExpOr :: BExp -> Parser BExp
197
pBExpOr x =
198
  ( do
199
      y <- pOr *> pBExpAnd x
200
      pBExpOr (Or x y)
201
  )
202
    <|> pure x
203
204
pBExp :: Parser BExp
205
pBExp = do
206
  x <- pAtom
207
  -- pBExp' x
208
  pBExpOr x