From 7303a43f5badb0d4d7a9fb9d81fdccbe0686e027 Mon Sep 17 00:00:00 2001
From: Joshua Potter <jrpotter2112@gmail.com>
Date: Mon, 20 Dec 2021 09:01:27 -0500
Subject: [PATCH] Add initial encoding tests.

---
 parser-initial/parser-initial.cabal    | 15 ++++++
 parser-initial/src/Parser.hs           |  6 ++-
 parser-initial/test/Driver.hs          |  1 +
 parser-initial/test/Test/ParserTest.hs | 67 ++++++++++++++++++++++++++
 4 files changed, 87 insertions(+), 2 deletions(-)
 create mode 100644 parser-initial/test/Driver.hs
 create mode 100644 parser-initial/test/Test/ParserTest.hs

diff --git a/parser-initial/parser-initial.cabal b/parser-initial/parser-initial.cabal
index b8bcc97..79efce3 100644
--- a/parser-initial/parser-initial.cabal
+++ b/parser-initial/parser-initial.cabal
@@ -24,3 +24,18 @@ library
   hs-source-dirs:     src
   default-language:   Haskell2010
   exposed-modules:    Parser
+
+test-suite parser-initial-test
+  type:               exitcode-stdio-1.0
+  main-is:            Driver.hs
+  hs-source-dirs:     test
+  build-depends:      base ^>=4.14.3.0,
+                      HUnit,
+                      hspec,
+                      megaparsec,
+                      parser-initial,
+                      tasty,
+                      tasty-discover,
+                      tasty-hspec,
+                      text
+  other-modules:      Test.ParserTest
diff --git a/parser-initial/src/Parser.hs b/parser-initial/src/Parser.hs
index 7cddf56..f684fda 100644
--- a/parser-initial/src/Parser.hs
+++ b/parser-initial/src/Parser.hs
@@ -3,7 +3,9 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 module Parser
-( eval
+( Expr(..)
+, Parser
+, eval
 , memConsExpr
 , mulPassExpr
 , naiveExpr
@@ -42,7 +44,7 @@ data Expr
   | ESub  Expr Expr
   | EAnd  Expr Expr
   | EOr   Expr Expr
-  deriving (Show)
+  deriving (Eq, Show)
 
 eval :: Expr -> Either Text Expr
 eval e@(EInt  _) = pure e
diff --git a/parser-initial/test/Driver.hs b/parser-initial/test/Driver.hs
new file mode 100644
index 0000000..327adf4
--- /dev/null
+++ b/parser-initial/test/Driver.hs
@@ -0,0 +1 @@
+{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --tree-display #-}
diff --git a/parser-initial/test/Test/ParserTest.hs b/parser-initial/test/Test/ParserTest.hs
new file mode 100644
index 0000000..354bdf6
--- /dev/null
+++ b/parser-initial/test/Test/ParserTest.hs
@@ -0,0 +1,67 @@
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Test.ParserTest
+( spec_parser,
+) where
+
+import qualified Text.Megaparsec as M
+
+import Data.Text (Text, pack)
+import Parser
+import Test.Hspec (Expectation, Spec, describe, it, shouldBe)
+
+runParser :: Parser Expr -> Text -> IO (Either Text Expr)
+runParser m input = pure case M.parse (m <* M.eof) "ParserTest" input of
+  Left e -> Left . pack $ M.errorBundlePretty e
+  Right a -> eval a
+
+runParsers :: Text -> IO [Either Text Expr]
+runParsers input =
+  mapM (`runParser` input) [naiveExpr, mulPassExpr, memConsExpr]
+
+allEqual :: forall a. Eq a => [a] -> Bool
+allEqual [] = True
+allEqual [x] = True
+allEqual [x, y] = x == y
+allEqual (x:y:xs) = x == y && allEqual (y : xs)
+
+shouldParse :: Text -> Expr -> Expectation
+shouldParse input expected = do
+  res@(x : _) <- runParsers input
+  shouldBe x $ Right expected
+  shouldBe True $ allEqual res
+
+shouldNotParse :: Text -> Text -> Expectation
+shouldNotParse input expected = do
+  res@(x : _) <- runParsers input
+  shouldBe x $ Left expected
+
+spec_parser :: Spec
+spec_parser = do
+  describe "literals" do
+    it "1" do
+      shouldParse "1" (EInt 1)
+    it "true" do
+      shouldParse "true" (EBool True)
+    it "false" do
+      shouldParse "false" (EBool False)
+  describe "addition/subtraction" do
+    it "binary" do
+      shouldParse "1 + 1" (EInt 2)
+    it "left associative" do
+      shouldParse "1 - 3 + 4" (EInt 2)
+    it "precedence" do
+      shouldParse "1 - (3 + 4)" (EInt (-6))
+  describe "conjunction/disjunction" do
+    it "binary" do
+      shouldParse "true && false" (EBool False)
+      shouldParse "true && true" (EBool True)
+      shouldParse "true || true" (EBool True)
+      shouldParse "true || false" (EBool True)
+      shouldParse "false || false" (EBool False)
+  describe "invalid types" do
+    it "mismatch" do
+      shouldNotParse "true && 1" "Expected two booleans."
+      shouldNotParse "1 + true" "Expected two integers."