(#801) Extract HyperNerd.Parser module

Author: rexim

HyperNerd.cabal

@@ -92,6 +92,7 @@ executable HyperNerd
                      , Entity
                      , HyperNerd.Comonad
                      , HyperNerd.Functor
+                     , HyperNerd.Parser
                      , Markov
                      , Property
                      , Reaction
@@ -160,6 +161,7 @@ executable Fuzzy
   main-is:             FuzzyMain.hs
 
   other-modules:       Bot.Expr
+                     , HyperNerd.Parser
 
   build-depends:       base
                      , text
@@ -264,6 +266,7 @@ test-suite HyperNerdTest
                      , Data.Either.Extra
                      , Free
                      , Bot.Expr
+                     , HyperNerd.Parser
 
   other-extensions:    OverloadedStrings
 

src/Bot/Expr.hs

@@ -1,12 +1,13 @@
-{-# LANGUAGE DeriveFunctor #-}
 {-# LANGUAGE OverloadedStrings #-}
 
 module Bot.Expr where
 
 import Control.Applicative
+import Data.Tuple
 import Data.Char
 import qualified Data.Text as T
-import Data.Tuple
+
+import HyperNerd.Parser
 
 data Expr
   = TextExpr T.Text
@@ -17,37 +18,6 @@ data Expr
 
 type NameTable = ()
 
-data ParserStop
-  = EOF
-  | SyntaxError T.Text
-  deriving (Eq, Show)
-
-newtype Parser a = Parser
-  { runParser :: T.Text -> Either ParserStop (T.Text, a)
-  } deriving (Functor)
-
-instance Applicative Parser where
-  pure x = Parser $ \text -> Right (text, x)
-  (Parser f) <*> (Parser x) =
-    Parser $ \input1 -> do
-      (input2, f') <- f input1
-      (input3, x') <- x input2
-      return (input3, f' x')
-
-instance Monad Parser where
-  Parser a >>= f =
-    Parser $ \input1 -> do
-      (input2, b) <- a input1
-      runParser (f b) input2
-
-instance Alternative Parser where
-  empty = Parser $ const $ Left EOF
-  (Parser p1) <|> (Parser p2) =
-    Parser $ \input ->
-      case (p1 input, p2 input) of
-        (Left _, x) -> x
-        (x, _) -> x
-
 symbol :: Parser T.Text
 symbol = notNull "Symbol name cannot be empty" $ takeWhileP isAlphaNum
 
@@ -58,12 +28,6 @@ stringLiteral = do
   _ <- charP '"'
   return $ TextExpr value
 
-sepBy :: Parser a -> Parser b -> Parser [a]
-sepBy element sep = do
-  arg <- element
-  args <- many (sep >> element)
-  return (arg : args)
-
 funcallarg :: Parser Expr
 funcallarg = funcall <|> var <|> stringLiteral
 
@@ -77,28 +41,6 @@ funcall = do
   _ <- whitespaces >> charP ')'
   return $ FunCallExpr name args
 
-charP :: Char -> Parser Char
-charP a =
-  Parser $ \input ->
-    case T.uncons input of
-      Just (b, rest)
-        | a == b -> Right (rest, b)
-      _ -> Left $ SyntaxError ("Expected `" <> T.pack [a] <> "`")
-
-takeWhileP :: (Char -> Bool) -> Parser T.Text
-takeWhileP p = Parser $ \input -> return $ swap $ T.span p input
-
-syntaxError :: T.Text -> Parser a
-syntaxError message = Parser $ \_ -> Left $ SyntaxError message
-
-notNull :: T.Text -> Parser T.Text -> Parser T.Text
-notNull message next =
-  next >>=
-  (\value ->
-     if T.null value
-       then syntaxError message
-       else return value)
-
 whitespaces :: Parser T.Text
 whitespaces = takeWhileP isSpace
 

src/FuzzyMain.hs

@@ -13,6 +13,7 @@ import System.Environment
 import System.Random
 import Text.Printf
 import qualified Data.ByteString.Lazy as BS
+import HyperNerd.Parser
 
 data FuzzParams = FuzzParams
   { fpFuzzCount :: Int

src/HyperNerd/Parser.hs

@@ -0,0 +1,67 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DeriveFunctor #-}
+
+module HyperNerd.Parser where
+
+import Control.Applicative
+import qualified Data.Text as T
+import Data.Tuple
+
+data ParserStop
+  = EOF
+  | SyntaxError T.Text
+  deriving (Eq, Show)
+
+newtype Parser a = Parser
+  { runParser :: T.Text -> Either ParserStop (T.Text, a)
+  } deriving (Functor)
+
+instance Applicative Parser where
+  pure x = Parser $ \text -> Right (text, x)
+  (Parser f) <*> (Parser x) =
+    Parser $ \input1 -> do
+      (input2, f') <- f input1
+      (input3, x') <- x input2
+      return (input3, f' x')
+
+instance Monad Parser where
+  Parser a >>= f =
+    Parser $ \input1 -> do
+      (input2, b) <- a input1
+      runParser (f b) input2
+
+instance Alternative Parser where
+  empty = Parser $ const $ Left EOF
+  (Parser p1) <|> (Parser p2) =
+    Parser $ \input ->
+      case (p1 input, p2 input) of
+        (Left _, x) -> x
+        (x, _) -> x
+
+sepBy :: Parser a -> Parser b -> Parser [a]
+sepBy element sep = do
+  arg <- element
+  args <- many (sep >> element)
+  return (arg : args)
+
+takeWhileP :: (Char -> Bool) -> Parser T.Text
+takeWhileP p = Parser $ \input -> return $ swap $ T.span p input
+
+charP :: Char -> Parser Char
+charP a =
+  Parser $ \input ->
+    case T.uncons input of
+      Just (b, rest)
+        | a == b -> Right (rest, b)
+      _ -> Left $ SyntaxError ("Expected `" <> T.pack [a] <> "`")
+
+notNull :: T.Text -> Parser T.Text -> Parser T.Text
+notNull message next =
+  next >>=
+  (\value ->
+     if T.null value
+       then syntaxError message
+       else return value)
+
+syntaxError :: T.Text -> Parser a
+syntaxError message = Parser $ \_ -> Left $ SyntaxError message