Use instances of Alternative with parsers

Author: evturn

13-monadic-parsing/13.07-handling-space.hs

@@ -12,34 +12,6 @@ item = P $ \inp ->
     []     -> []
     (x:xs) -> [(x, xs)]
 
-instance Functor Parser where
-  fmap f p = P $ \inp ->
-    case parse p inp of
-      []         -> []
-      [(v, out)] -> [(f v, out)]
-
-instance Applicative Parser where
-  pure v = P $ \inp -> [(v, inp)]
-
-  pf <*> px = P $ \inp ->
-    case parse pf inp of
-      []         -> []
-      [(f, out)] -> parse (fmap f px) out
-
-instance Monad Parser where
-  p >>= f = P $ \inp ->
-    case parse p inp of
-      []         -> []
-      [(v, out)] -> parse (f v) out
-
-instance Alternative Parser where
-  empty = P $ \inp -> []
-
-  p <|> q = P $ \inp ->
-    case parse p inp of
-      []         -> parse q inp
-      [(v, out)] -> [(v, out)]
-
 sat :: (Char -> Bool) -> Parser Char
 sat p = do
   x <- item
@@ -94,6 +66,8 @@ int = do
   n <- nat
   return (-n) <|> nat
 
+-- | The `token` function defines a new primitive that ignores any space before
+-- and after applying a parser for a token.
 token :: Parser a -> Parser a
 token p = do
   space
@@ -113,6 +87,8 @@ integer = token int
 symbol :: String -> Parser String
 symbol xs = token (string xs)
 
+-- | The `nats` parser is defined for a non-empty list of natural numbers that
+-- ignores spacing around tokens.
 nats :: Parser [Int]
 nats = do
   symbol "["
@@ -122,3 +98,31 @@ nats = do
     natural
   symbol "]"
   return (n:ns)
+
+instance Functor Parser where
+  fmap f p = P $ \inp ->
+    case parse p inp of
+      []         -> []
+      [(v, out)] -> [(f v, out)]
+
+instance Applicative Parser where
+  pure v = P $ \inp -> [(v, inp)]
+
+  pf <*> px = P $ \inp ->
+    case parse pf inp of
+      []         -> []
+      [(f, out)] -> parse (fmap f px) out
+
+instance Monad Parser where
+  p >>= f = P $ \inp ->
+    case parse p inp of
+      []         -> []
+      [(v, out)] -> parse (f v) out
+
+instance Alternative Parser where
+  empty = P $ \inp -> []
+
+  p <|> q = P $ \inp ->
+    case parse p inp of
+      []         -> parse q inp
+      [(v, out)] -> [(v, out)]

13-monadic-parsing/13.08-arithmetic-expressions.hs

@@ -0,0 +1,160 @@
+import           Control.Applicative
+import           Data.Char
+
+newtype Parser a = P (String -> [(a, String)])
+
+-----------------------------------------------------------------------------
+-- expr   ::=  term (+ expr | ∊)
+-- term   ::=  factor (* term | ∊)
+-- factor ::=  ( expr ) | nat
+-- nat    ::=  0 | 1 | 2 | ...
+-----------------------------------------------------------------------------
+
+expr :: Parser Int
+expr = do
+  t <- term
+  do
+    symbol "+"
+    e <- expr
+    return (t + e) <|> return t
+
+term :: Parser Int
+term = do
+  f <- factor
+  do
+    symbol "*"
+    t <- term
+    return (f * t) <|> return f
+
+factor :: Parser Int
+factor = do
+  symbol "("
+  e <- expr
+  symbol ")"
+  return e <|> natural
+
+eval :: String -> Int
+eval xs = case (parse expr xs) of
+  [(n, [])]  -> n
+  [(_, out)] -> error ("Unused input " ++ out)
+  []         -> error "Invalid input"
+
+parse :: Parser a -> String -> [(a, String)]
+parse (P p) inp = p inp
+
+item :: Parser Char
+item = P $ \inp ->
+  case inp of
+    []     -> []
+    (x:xs) -> [(x, xs)]
+
+sat :: (Char -> Bool) -> Parser Char
+sat p = do
+  x <- item
+  if p x
+  then return x
+  else empty
+
+digit :: Parser Char
+digit = sat isDigit
+
+lower :: Parser Char
+lower = sat isLower
+
+upper :: Parser Char
+upper = sat isUpper
+
+letter :: Parser Char
+letter = sat isAlpha
+
+alphanum :: Parser Char
+alphanum = sat isAlphaNum
+
+char :: Char -> Parser Char
+char x = sat (== x)
+
+string :: String -> Parser String
+string [] = return []
+string (x:xs) = do
+  char x
+  string xs
+  return (x:xs)
+
+ident :: Parser String
+ident = do
+  x <- lower
+  xs <- many alphanum
+  return (x:xs)
+
+nat :: Parser Int
+nat = do
+  xs <- some digit
+  return (read xs)
+
+space :: Parser ()
+space = do
+  many (sat isSpace)
+  return ()
+
+int :: Parser Int
+int = do
+  char '-'
+  n <- nat
+  return (-n) <|> nat
+
+token :: Parser a -> Parser a
+token p = do
+  space
+  v <- p
+  space
+  return v
+
+identifier :: Parser String
+identifier = token ident
+
+natural :: Parser Int
+natural = token nat
+
+integer :: Parser Int
+integer = token int
+
+symbol :: String -> Parser String
+symbol xs = token (string xs)
+
+nats :: Parser [Int]
+nats = do
+  symbol "["
+  n <- natural
+  ns <- many $ do
+    symbol ","
+    natural
+  symbol "]"
+  return (n:ns)
+
+instance Functor Parser where
+  fmap f p = P $ \inp ->
+    case parse p inp of
+      []         -> []
+      [(v, out)] -> [(f v, out)]
+
+instance Applicative Parser where
+  pure v = P $ \inp -> [(v, inp)]
+
+  pf <*> px = P $ \inp ->
+    case parse pf inp of
+      []         -> []
+      [(f, out)] -> parse (fmap f px) out
+
+instance Monad Parser where
+  p >>= f = P $ \inp ->
+    case parse p inp of
+      []         -> []
+      [(v, out)] -> parse (f v) out
+
+instance Alternative Parser where
+  empty = P $ \inp -> []
+
+  p <|> q = P $ \inp ->
+    case parse p inp of
+      []         -> parse q inp
+      [(v, out)] -> [(v, out)]