Week 3 Lecture 1

1
import Control.Applicative (Alternative (..), asum)
2
import Control.Monad (ap, liftM, void)
3
import Data.Char (isDigit, isSpace, ord)
4
5
stringToInt1 :: String -> Int
6
stringToInt1 s = loop 0 s
7
 where
8
  loop acc [] = acc
9
  loop acc (c : cs) =
10
    let c' = ord c - ord '0'
11
     in loop (acc * 10 + c') cs
12
13
stringToInt2 :: String -> Maybe Int
14
stringToInt2 s = loop 0 s
15
 where
16
  loop acc [] = Just acc
17
  look acc (c : cs) =
18
    if isDigit c
19
      then
20
        let c' = ord c - ord '0'
21
         in loop (acc * 10 + c') cs
22
      else Nothing
23
24
-- where did stringToInt3 go???
25
26
stringToInt4 :: String -> Maybe (Int, String)
27
stringToInt4 "" = Nothing
28
stringToInt4 (c : cs) = if isDigit c then loop 0 (c : cs) else Nothing
29
 where
30
  loop acc "" = Just (acc, "")
31
  loop acc (c : cs) = if isDigit c then loop ((ord c - ord '0') + acc * 10) cs else Just (acc, c : cs)
32
33
hasLeadingSpace :: String -> Maybe String
34
hasLeadingSpace (c : cs) = if c == ' ' then Just cs else Nothing
35
36
stringToInts :: String -> Maybe ((Int, Int), String)
37
stringToInts s =
38
  case stringToInt4 s of
39
    Nothing -> Nothing
40
    Just (x, s') -> case hasLeadingSpace s' of
41
      Just s'' -> case stringToInt4 s'' of
42
        Just (y, s''') -> Just ((x, y), s''')
43
        Nothing -> Nothing
44
      _ -> Nothing
45
46
stringToInts2 :: String -> Maybe ((Int, Int), String)
47
stringToInts2 s = do
48
  (x, s') <- stringToInt4 s
49
  s'' <- hasLeadingSpace s'
50
  (y, s''') <- stringToInt4 s''
51
  pure ((x, y), s''')
52
53
data Parser a = Parser ((Int, String) -> Either (Int, String) (a, (Int, String)))
54
55
instance Functor Parser where
56
  fmap :: (a -> b) -> Parser a -> Parser b
57
  fmap = liftM
58
59
instance Applicative Parser where
60
  pure a = Parser $ \s -> Right (a, s)
61
  (<*>) = ap
62
63
instance Monad Parser where
64
  Parser a >>= f = Parser $ \s -> do
65
    (a', s') <- a s
66
    let (Parser b) = f a'
67
    b s'
68
69
runParser :: Parser a -> String -> Either String a
70
runParser (Parser f) s = case f (0, s) of
71
  Left (pos, err) -> Left ("Parse error at " ++ show pos ++ ": " ++ err)
72
  Right (a, _) -> pure a
73
74
satisfy :: (Char -> Bool) -> Parser Char
75
satisfy p = Parser $ \(pos, s) ->
76
  case s of
77
    "" -> Left (pos, "Empty input")
78
    c : (cs) ->
79
      if p c
80
        then
81
          pure (c, (pos + 1, cs))
82
        else Left (pos, "Invalid character: " ++ [c])
83
84
threeDigits :: Parser (Char, Char, Char)
85
threeDigits = let s = satisfy isDigit in (,,) <$> s <*> s <*> s
86
87
instance Alternative Parser where
88
  empty = Parser $ \(pos, s) -> Left (pos, "All branches exhausted")
89
  (Parser p1) <|> (Parser p2) = Parser $ \s -> case p1 s of
90
    Left err -> p2 s
91
    Right a -> pure a
92
93
choice :: [Parser a] -> Parser a
94
choice = asum
95
96
(<?>) :: Parser a -> String -> Parser a
97
Parser p <?> e = Parser $ \s -> case p s of
98
  Left (o, _) -> Left (o, e)
99
  a -> a
100
101
try :: Parser a -> Parser (Maybe a)
102
try (Parser p) = Parser $ \(pos, s) -> case p (pos, s) of
103
  Right (a, (pos', s')) -> Right $ (Just a, (pos', s'))
104
  Left e -> Right $ (Nothing, (pos, s))
105
106
mymany :: Parser a -> Parser [a]
107
mymany p =
108
  choice
109
    [ do
110
        x <- p
111
        xs' <- mymany p
112
        pure (x : xs')
113
    , pure []
114
    ]
115
116
parseDigit :: Parser Int
117
parseDigit = (\c -> ord c - ord '0') <$> satisfy isDigit
118
119
parseInt :: Parser Int
120
-- parseInt = do
121
--   xs <- some parseDigit
122
--   pure $ foldl' (\acc x -> acc * 10 + x) 0 xs
123
parseInt = foldl' (\acc x -> acc * 10 + x) 0 <$> some parseDigit
124
125
skipSpaces :: Parser ()
126
skipSpaces = void $ many (satisfy isSpace)
127
128
parseTwoInts :: Parser (Int, Int)
129
parseTwoInts = do
130
  x <- parseInt
131
  skipSpaces
132
  y <- parseInt
133
  pure (x, y)
134
135
getTwoInts :: String -> Either String (Int, Int)
136
getTwoInts s = runParser (skipSpaces *> parseTwoInts) s
137
138
-- I guess it is halloween
139
-- We are getting sugars thrown at us at random <*
140
-- 🫳🍬🍬🍬
141
142
postfix :: Parser a -> Parser b -> Parser a
143
postfix p1 p2 = p1 <* p2
144
145
parseInts :: Parser [Int]
146
parseInts = many parseIntThenSpace
147
 where
148
  parseIntThenSpace = do
149
    x <- parseInt
150
    skipSpaces
151
    pure x
152
153
eof :: Parser ()
154
eof = Parser end
155
 where
156
  end :: (Int, String) -> Either (Int, String) ((), (Int, String))
157
  end s@(_, "") = pure ((), s)
158
  end (pos, _) = Left (pos, "EOF expected")
159
160
instance MonadFail Parser where
161
  fail s = Parser (\(pos, _) -> Left (pos, s))
162
163
-- I don't provide invalid data to a program so I'm unfamiliar with the situation (thug life)
164
165
-- Spaaace
166