From 82f3548f441ea2ee89b4af5ac1fd25e929638ed9 Mon Sep 17 00:00:00 2001
From: Jaro Reinders <jaro.reinders@gmail.com>
Date: Mon, 12 Jun 2023 12:21:24 +0200
Subject: [PATCH] Add tests

---
 gigaparsec.cabal       | 20 +++++++----
 src/Gigaparsec/Core.hs | 19 +++++-----
 tests/test.hs          | 78 ++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 100 insertions(+), 17 deletions(-)
 create mode 100644 tests/test.hs

diff --git a/gigaparsec.cabal b/gigaparsec.cabal
index 4fc618c..9568bd9 100644
--- a/gigaparsec.cabal
+++ b/gigaparsec.cabal
@@ -25,17 +25,25 @@ source-repository head
     location: https://github.com/noughtmare/gigaparsec
 
 common common
-    build-depends:            base >= 4.14 && <5, mtl, template-haskell
-    ghc-options:              -Wall
-    default-language:         GHC2021
+    build-depends:    base >= 4.14 && <5
+    ghc-options:      -Wall
+    default-language: GHC2021
 
 library
     import:           common
-    exposed-modules:          Gigaparsec, Gigaparsec.Core
-    hs-source-dirs:           src
+    exposed-modules:  Gigaparsec, Gigaparsec.Core
+    hs-source-dirs:   src
+    build-depends:    mtl, template-haskell        
 
 executable gpc-examples
     import:           common
     main-is:          Main.hs
     hs-source-dirs:   examples
-    build-depends:    gigaparsec
\ No newline at end of file
+    build-depends:    gigaparsec
+
+test-suite gpc-test
+  import:             common
+  type:               exitcode-stdio-1.0
+  hs-source-dirs:     tests
+  main-is:            test.hs
+  build-depends:      tasty, tasty-hunit, gigaparsec
\ No newline at end of file
diff --git a/src/Gigaparsec/Core.hs b/src/Gigaparsec/Core.hs
index 25a9c66..5b1385b 100644
--- a/src/Gigaparsec/Core.hs
+++ b/src/Gigaparsec/Core.hs
@@ -1,18 +1,16 @@
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE TemplateHaskellQuotes #-}
+{-# LANGUAGE ExplicitNamespaces #-}
 
 module Gigaparsec.Core where
 
 import Control.Monad.State
-import Data.Foldable (traverse_)
 import Control.Applicative
-import Data.Type.Equality
+import Data.Type.Equality ( type (:~:)(Refl) )
 import Data.Bifunctor (first)
-import Unsafe.Coerce
+import Unsafe.Coerce ( unsafeCoerce )
 import qualified Debug.Trace
-import Data.Char
 import Language.Haskell.TH (Name)
 
 traceShow _ = id
@@ -49,12 +47,11 @@ instance Alternative Parser where
   Parser ps <|> Parser qs = Parser (ps <> qs)
 
 instance Monad Parser where
-    Parser xs >>= k0 = Parser (xs >>= go (alts . k0)) where
-        go :: (a -> [P b]) -> P a -> [P b]
-        go k (Success x) = k x
-        go k (T c p) = [T c (Parser (concatMap (go k) (alts p)))]
-        go k (NT n p q) = [NT n p (Parser . concatMap (go k) . alts . q)]
-
+  Parser xs >>= k0 = Parser (xs >>= go (alts . k0)) where
+    go :: (a -> [P b]) -> P a -> [P b]
+    go k (Success x) = k x
+    go k (T c p) = [T c (Parser (concatMap (go k) (alts p)))]
+    go k (NT n p q) = [NT n p (Parser . concatMap (go k) . alts . q)]
 
 data SelfCont a = forall b. SelfCont (Stack b a) (a -> Parser b)
 
diff --git a/tests/test.hs b/tests/test.hs
new file mode 100644
index 0000000..8c8f088
--- /dev/null
+++ b/tests/test.hs
@@ -0,0 +1,78 @@
+{-# LANGUAGE TemplateHaskellQuotes #-}
+import Test.Tasty
+-- import Test.Tasty.SmallCheck as SC
+-- import Test.Tasty.QuickCheck as QC
+import Test.Tasty.HUnit
+
+import Gigaparsec
+import Data.Foldable (traverse_)
+import Control.Applicative (Alternative((<|>)), asum)
+import Data.Char (intToDigit)
+
+main :: IO ()
+main = defaultMain tests
+
+digit :: Int -> Parser Int
+digit b = asum [i <$ char (intToDigit i) | i <- [0..b - 1]]
+
+number :: Int -> Parser Int
+number b = 'number
+  ::= (\x y -> b * x + y) <$> number b <*> digit b
+  <|> digit b
+
+expr :: Parser Int
+expr = 'expr
+  ::= (*) <$> expr <* char '*' <*> expr
+  <|> (+) <$> expr <* char '+' <*> expr 
+  <|> number 10
+
+ndots :: Parser ()
+ndots = number 10 >>= go where
+  go 0 = pure ()
+  go n = char '.' *> go (n - 1)
+
+
+tests :: TestTree
+tests = testGroup "Tests" [unitTests]
+
+unitTests :: TestTree
+unitTests = testGroup "Unit tests"
+  [ testCase "base 2 number positive" $
+    traverse_ (\(x, y) -> parse (number 2) x @?= [y])
+      [ ("0",     0)
+      , ("1",     1)
+      , ("00",    0)
+      , ("01",    1)
+      , ("11",    3)
+      , ("00000", 0)
+      , ("01011", 11)
+      , ("11111", 31)
+      ]
+  , testCase "base 2 number negative" $
+    traverse_ (\x -> parse (number 2) x @?= [])
+      [ ""
+      , "X"
+      , "01X00"
+      , "1001X"
+      , "X1101"
+      ]
+  , testCase "expression positive" $
+    traverse_ (\(x, y) -> parse expr x @?= y)
+      [ ("1+1", [2])
+      , ("1+2+3", [6,6])
+      , ("1+2*3", [9,7])
+      ]
+  , testCase "ndots positive" $
+    traverse_ (\x -> parse ndots x @?= [()])
+      [ "5....."
+      , "3..."
+      , "10.........."
+      ]
+  , testCase "ndots negative" $
+    traverse_ (\x -> parse ndots x @?= [])
+      [ "5...."
+      , "5......"
+      , "3....."
+      , "10........"
+      ]
+  ]
\ No newline at end of file