Tests

7 files changed, 241 insertions, 15 deletions

diff --git a/fun.cabal b/fun.cabal
index 0d343f5..480200f 100644
--- a/fun.cabal
+++ b/fun.cabal
@@ -25,6 +25,7 @@ library
   exposed-modules:
       Fun
       Fun.Compiler
+      Fun.Grammar
       Fun.Parser
       Fun.Tree
   other-modules:
@@ -49,13 +50,15 @@ executable fun-exe
 
 test-suite fun-test
   type: exitcode-stdio-1.0
-  main-is: Spec.hs
+  main-is: Fun.hs
   other-modules:
+      FunTests.Parser
       Paths_fun
   hs-source-dirs:
       test
   ghc-options: -threaded -rtsopts -with-rtsopts=-N
   build-depends:
-      base >=4.7 && <5
+      HUnit
+    , base >=4.7 && <5
     , fun
   default-language: Haskell2010
diff --git a/package.yaml b/package.yaml
index 2490e20..70001aa 100644
--- a/package.yaml
+++ b/package.yaml
@@ -37,11 +37,12 @@ executables:
 
 tests:
   fun-test:
-    main:                Spec.hs
+    main:                Fun.hs
     source-dirs:         test
     ghc-options:
     - -threaded
     - -rtsopts
     - -with-rtsopts=-N
     dependencies:
+    - HUnit
     - fun
diff --git a/stack.yaml b/stack.yaml
index 7ffdea0..d2d4d13 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -40,8 +40,6 @@ packages:
 # - git: https://github.com/commercialhaskell/stack.git
 #   commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
 #
-extra-deps:
-  - data-tree-print-0.1.0.2@sha256:d845e99f322df70e0c06d6743bf80336f5918d5423498528beb0593a2afc1703,1620
 
 # Override default flag values for local packages and extra-deps
 # flags: {}
diff --git a/stack.yaml.lock b/stack.yaml.lock
index 0152bd5..2f61f7f 100644
--- a/stack.yaml.lock
+++ b/stack.yaml.lock
@@ -3,14 +3,7 @@
 # For more information, please see the documentation at:
 #   https://docs.haskellstack.org/en/stable/lock_files
 
-packages:
-- completed:
-    hackage: data-tree-print-0.1.0.2@sha256:d845e99f322df70e0c06d6743bf80336f5918d5423498528beb0593a2afc1703,1620
-    pantry-tree:
-      size: 272
-      sha256: b8778eb1b16fddb91b2eed2b25f33a89d1e4f7a533160de4ccbf226f82456135
-  original:
-    hackage: data-tree-print-0.1.0.2@sha256:d845e99f322df70e0c06d6743bf80336f5918d5423498528beb0593a2afc1703,1620
+packages: []
 snapshots:
 - completed:
     size: 587393
diff --git a/test/Fun.hs b/test/Fun.hs
new file mode 100644
index 0000000..ea9dbf8
--- /dev/null
+++ b/test/Fun.hs
@@ -0,0 +1,8 @@
+module Main where
+
+import           FunTests.Parser
+import           Test.HUnit
+
+main :: IO Counts
+main = do
+  parserTest
diff --git a/test/FunTests/Parser.hs b/test/FunTests/Parser.hs
new file mode 100644
index 0000000..2339a82
--- /dev/null
+++ b/test/FunTests/Parser.hs
@@ -0,0 +1,225 @@
+module FunTests.Parser
+  ( parserTest
+  ) where
+
+import           Fun.Parser
+import           Test.HUnit
+
+isLeft :: Either a b -> Bool
+isLeft (Left  _) = True
+isLeft (Right _) = False
+
+isRight :: Either a b -> Bool
+isRight (Right _) = True
+isRight (Left  _) = False
+
+----
+
+testIsDigit :: Test
+testIsDigit = test
+  [ isDigit '0' ~=? True
+  , isDigit '9' ~=? True
+  , isDigit 'A' ~=? False
+  , isDigit 'z' ~=? False
+  ]
+
+testIsAlpha :: Test
+testIsAlpha = test
+  [ isAlpha 'A' ~=? True
+  , isAlpha 'z' ~=? True
+  , isAlpha '0' ~=? False
+  , isAlpha '9' ~=? False
+  ]
+
+testIsLower :: Test
+testIsLower = test
+  [ isLower 'a' ~=? True
+  , isLower 'z' ~=? True
+  , isLower 'A' ~=? False
+  , isLower '9' ~=? False
+  ]
+
+testIsUpper :: Test
+testIsUpper = test
+  [ isUpper 'A' ~=? True
+  , isUpper 'Z' ~=? True
+  , isUpper '9' ~=? False
+  , isUpper 'a' ~=? False
+  ]
+
+testChar :: Test
+testChar = test
+  [ char "abc" ~=? Right ('a', "bc")
+  , char "a" ~=? Right ('a', "")
+  , isLeft (char "") ~=? True
+  ]
+
+testDigit :: Test
+testDigit = test
+  [ digit "123" ~=? Right ('1', "23")
+  , digit "9abc" ~=? Right ('9', "abc")
+  , isLeft (digit "a123") ~=? True
+  ]
+
+testDigits :: Test
+testDigits = test
+  [ digits "123" ~=? Right ("123", "")
+  , digits "98abc" ~=? Right ("98", "abc")
+  , isLeft (digits "a123") ~=? True
+  ]
+
+testNumber :: Test
+testNumber = test
+  [ number "-123" ~=? Right (-123, "")
+  , number "98abc" ~=? Right (98, "abc")
+  , isLeft (number "--123") ~=? True
+  , isLeft (number "a123") ~=? True
+  ]
+
+testSpace :: Test
+testSpace = test
+  [ space " ab" ~=? Right (' ', "ab")
+  , space "  a" ~=? Right (' ', " a")
+  , isLeft (space "a b") ~=? True
+  ]
+
+testNotSpace :: Test
+testNotSpace = test
+  [ notSpace "~b" ~=? Right ('~', "b")
+  , notSpace "8b" ~=? Right ('8', "b")
+  , notSpace "ab" ~=? Right ('a', "b")
+  , isLeft (notSpace " b") ~=? True
+  ]
+
+testNewline :: Test
+testNewline = test
+  [ newline "\nab" ~=? Right ('\n', "ab")
+  , newline "\n\na" ~=? Right ('\n', "\na")
+  --, newline "\r\na" ~=? Right ('\r', "\na") -- or sth TODO
+  , isLeft (newline "a\nb") ~=? True
+  ]
+
+testLetter :: Test
+testLetter = test
+  [ letter "abc" ~=? Right ('a', "bc")
+  , letter "a123" ~=? Right ('a', "123")
+  , isLeft (letter "1abc") ~=? True
+  ]
+
+testLetters :: Test
+testLetters = test
+  [ letters "abc" ~=? Right ("abc", "")
+  , letters "ab123" ~=? Right ("ab", "123")
+  , isLeft (letters "1abc") ~=? True
+  ]
+
+testAlphanum :: Test
+testAlphanum = test
+  [ alphanum "abc" ~=? Right ('a', "bc")
+  , alphanum "a123" ~=? Right ('a', "123")
+  , alphanum "1234" ~=? Right ('1', "234")
+  , isLeft (alphanum "_abc") ~=? True
+  , isLeft (alphanum "*123") ~=? True
+  ]
+
+testSpecial :: Test
+testSpecial = test
+  [ special "*123" ~=? Right ('*', "123")
+  , special "#abc" ~=? Right ('#', "abc")
+  , isLeft (special "abc") ~=? True
+  , isLeft (special "123") ~=? True
+  ]
+
+testOneOf :: Test
+testOneOf = test
+  [ oneOf "abcd" "d123" ~=? Right ('d', "123")
+  , oneOf "#(!" "#abc" ~=? Right ('#', "abc")
+  , isLeft (oneOf "abcde" "fu") ~=? True
+  , isLeft (oneOf "123" "a123") ~=? True
+  ]
+
+testString :: Test
+testString = test
+  [ string "\"hallo\"naa" ~=? Right ("hallo", "naa")
+  , string "\"\"ah" ~=? Right ("", "ah")
+  , isLeft (string "\"hallo naa") ~=? True
+  , isLeft (string "na\"hallo\"") ~=? True
+  ]
+
+testLiteral :: Test
+testLiteral = test
+  [ literal 'a' "abc" ~=? Right ('a', "bc")
+  , literal '~' "~12" ~=? Right ('~', "12")
+  , isLeft (literal 'a' "123abc") ~=? True
+  , isLeft (literal '1' " 123") ~=? True
+  ]
+
+testResult :: Test
+testResult = test
+  [result 'a' "abc" ~=? Right ('a', "abc"), result ' ' "" ~=? Right (' ', "")]
+
+testOneOrMore :: Test
+testOneOrMore = test
+  [ oneOrMore (literal 'a') "abc" ~=? Right ("a", "bc")
+  , oneOrMore (literal '1') "111234" ~=? Right ("111", "234")
+  , isLeft (oneOrMore (literal 'a') "1234") ~=? True
+  ]
+
+testIter :: Test
+testIter = test
+  [ iter (literal 'a') "abc" ~=? Right ("a", "bc")
+  , iter (literal '1') "111234" ~=? Right ("111", "234")
+  , iter (literal 'a') "1234" ~=? Right ("", "1234")
+  ]
+
+testIterFull :: Test
+testIterFull = test
+  [ iterFull (literal 'a') "aaa" ~=? Right ("aaa", "")
+  , iterFull (literal '1') "1" ~=? Right ("1", "")
+  , isLeft (iterFull (literal 'a') "abc") ~=? True
+  , isLeft (iterFull (literal 'a') "1234") ~=? True
+  ]
+
+testToken :: Test
+testToken = test
+  [ token (literal 'a') "a b" ~=? Right ('a', "b")
+  , token (literal ' ') "  a" ~=? Right (' ', "a")
+  , isLeft (token (literal 'a') "ab") ~=? True
+  , isLeft (token (literal 'a') "ba ") ~=? True
+  ]
+
+testAccept :: Test
+testAccept = test
+  [ accept "abc" "abc 123" ~=? Right ("abc", "123")
+  , accept "1" "1 1 23" ~=? Right ("1", "1 23")
+  , isLeft (accept " " "  a") ~=? True
+  , isLeft (accept "abc" "aabc ") ~=? True
+  ]
+
+parserTest :: IO Counts
+parserTest = runTestTT $ TestList
+  [ testIsDigit
+  , testIsAlpha
+  , testIsLower
+  , testIsUpper
+  , testChar
+  , testDigit
+  , testDigits
+  , testNumber
+  , testSpace
+  , testNotSpace
+  , testNewline
+  , testLetter
+  , testLetters
+  , testAlphanum
+  , testSpecial
+  , testOneOf
+  , testString
+  , testLiteral
+  , testResult
+  , testOneOrMore
+  , testIter
+  , testIterFull
+  , testToken
+  , testAccept
+  ]
diff --git a/test/Spec.hs b/test/Spec.hs
deleted file mode 100644
index cd4753f..0000000
--- a/test/Spec.hs
+++ /dev/null
@@ -1,2 +0,0 @@
-main :: IO ()
-main = putStrLn "Test suite not yet implemented"