add tests

bonlang.cabal

@@ -61,13 +61,18 @@ test-suite bonlang-test
   main-is:             Spec.hs
   build-depends:       base
                      , bonlang
+                     , directory
                      , parsec
                      , directory
                      , filepath
                      , tasty
                      , tasty-hunit
                      , tasty-quickcheck
                      , tasty-smallcheck
+                     , aeson
+                     , yaml
+                     , text
+                     , bytestring
   ghc-options:         -threaded -rtsopts -with-rtsopts=-N -fprof-auto
   default-language:    Haskell2010
 

src/Bonlang/ErrorMessages.hs

@@ -4,10 +4,13 @@ import           Bonlang.Lang
 import           Text.Parsec  (SourcePos)
 
 noMainModule :: SourcePos -> BonlangError
-noMainModule at = DefaultError $ "No 'Main' module defined at: " ++ show at
+noMainModule at
+  = DefaultError $ "No 'Main' module defined at: " ++ show at
 
 noMainFunction :: SourcePos -> BonlangError
-noMainFunction at = DefaultError $ "No 'main' function defined at: " ++ show at
+noMainFunction at
+  = DefaultError $ "No 'main' function defined at: " ++ show at
 
-cantStartNonModule :: BonlangError
-cantStartNonModule = DefaultError "Can't start eval on non module"
+cantStartNonModule :: BonlangValue -> BonlangError
+cantStartNonModule x
+  = DefaultError $ "Can't start eval on non module. Provided: " ++ show x

src/Bonlang/Runtime.hs

@@ -87,7 +87,7 @@ startEval s (BonlangDirective dir@(ModuleDef m is at))
                else Except.throwE $ noMainModule at
     where
         hasMain moduleDefs = isJust $ Map.lookup "main" moduleDefs
-startEval _ _ = Except.throwE cantStartNonModule
+startEval _ x = Except.throwE $ cantStartNonModule x
 
 eval :: Scope -> BonlangValue -> IOThrowsException BonlangValue
 eval s (BonlangDirective dir)  = evalDirective s dir
@@ -145,13 +145,14 @@ evalClosure s c@BonlangClosure {} ps
                        let rScope = Map.union s' newParams'
                        s'' <- liftIO $ IORef.newIORef rScope
                        case cBody' of
-                         BonlangClosure {} -> evalClosure s'' cBody' (map snd (Map.toList newParams'))
+                         BonlangClosure {} -> evalClosure s'' cBody' newArgs
                          _                 -> eval s'' cBody'
     where
         notEnoughParams = existingArgs + length ps < length (cParams c)
         tooManyParams   = existingArgs + length ps > length (cParams c)
         existingArgs    = length (Map.toList (cEnv c))
         newParams'      = Map.fromList (zip (drop existingArgs $ cParams c) ps)
+        newArgs         = map snd $ Map.toList newParams'
 evalClosure _ x _
   = Except.throwE $ InternalTypeMismatch "Can't eval non closure" [x]
 

stack.yaml

@@ -2,34 +2,6 @@ flags: {}
 extra-package-dbs: []
 packages:
 - '.'
-extra-deps:
-- QuickCheck-2.8.2
-- ansi-terminal-0.6.2.3
-- ansi-wl-pprint-0.6.7.3
-- async-2.1.0
-- binary-0.8.4.0
-- bytestring-0.10.6.0
-- clock-0.7.2
-- directory-1.2.6.3
-- logict-0.6.0.2
-- mtl-2.2.1
-- optparse-applicative-0.12.1.0
-- parsec-3.1.11
-- primitive-0.6.1.0
-- process-1.4.2.0
-- random-1.1
-- regex-base-0.93.2
-- regex-tdfa-1.2.2
-- smallcheck-1.1.1
-- stm-2.4.4.1
-- tagged-0.8.4
-- tasty-0.11.0.3
-- tasty-hunit-0.9.2
-- tasty-quickcheck-0.8.4
-- tasty-smallcheck-0.8.1
-- text-1.2.2.1
-- tf-random-0.5
-- transformers-compat-0.5.1.4
-- unbounded-delays-0.1.0.9
-- unix-2.7.2.0
-resolver: ghc-8.0.1
+extra-deps: []
+compiler: ghc-8.0.1
+resolver: nightly-2016-07-27

test/Spec.hs

@@ -1,42 +1,94 @@
+{-# LANGUAGE DeriveGeneric     #-}
 {-# LANGUAGE OverloadedStrings #-}
 
+import           Bonlang.Lang
 import           Bonlang.Lexer
+import           Data.Aeson
+import qualified Data.ByteString               as B
+import           Data.Maybe                    (fromJust)
+import qualified Data.Text                     as T
+import qualified Data.Text.Encoding            as E
+import qualified Data.Yaml                     as Y
+import           GHC.Generics
 import           System.Directory
 import           System.FilePath
-import           Test.Tasty.HUnit
 import           Test.Tasty
+import           Test.Tasty.HUnit
 import           Text.ParserCombinators.Parsec
+import Debug.Trace as D
+
+data TestFile = TestFile { meta :: T.Text
+                         , code :: T.Text
+                         }
+                         deriving (Show)
+
+data TestInputOutput = TestInputOutput { output :: String
+                                       }
+                                       deriving (Generic, Show)
+
+instance FromJSON TestInputOutput
+instance ToJSON TestInputOutput
 
 main :: IO ()
-main = do tests' <- tests
-          defaultMain tests'
+main = tests >>= defaultMain
 
 tests :: IO TestTree
-tests = parsing
-    >>= \p -> return $ testGroup "Bonlang" [p]
+tests = do p <- sequence [parsing, testExpectations]
+           return $ testGroup "Bonlang" p
+
+testExpectations :: IO TestTree
+testExpectations = getFiles "test/examples/" >>=
+    \files -> return $ testGroup "Example tests" $ map exampleFiles files
+
+
+exampleFiles :: FilePath -> TestTree
+exampleFiles f = testCase ("Example file: " `mappend` f) exampleAssertion
+    where
+        exampleAssertion :: Assertion
+        exampleAssertion = do testFile <- makeTestFile f
+                              case testFile of
+                                Right testF -> runTestFile testF
+                                Left  x     -> error x
+
+runTestFile :: TestFile -> Assertion
+runTestFile testFile
+  = do output'         <- programOutput
+       expectedOutput' <- expectedOutput
+       output' @?= (output $ fromJust expectedOutput')
+    where
+        programOutput = return "" :: IO String
+        expectedOutput
+          = let tioSource = E.encodeUtf8 $ meta testFile in
+            return $ Y.decode tioSource :: IO (Maybe TestInputOutput)
+
+makeTestFile :: FilePath -> IO (Either String TestFile)
+makeTestFile f = do fileContents <- T.pack <$> readFile f
+                    case T.splitOn "---" fileContents of
+                      [_, meta', code']
+                            ->  return $ Right TestFile { meta = meta'
+                                                        , code = code'
+                                                        }
+                      _ -> return $ Left "Invalid syntax for example file"
 
 parsing :: IO TestTree
-parsing = testFiles
-      >>= \files -> return $ testGroup "Parsing tests" $ map testCaseFiles files
+parsing = getFiles "test/parser_tests/" >>=
+    \files -> return $ testGroup "Parsing tests" $ map testCaseFiles files
 
 testCaseFiles :: String -> TestTree
 testCaseFiles f = testCase ("Parsing file: " `mappend` f) fileAssertion
-    where
-        fileAssertion :: Assertion
-        fileAssertion = do (_, b) <- parse' f
-                           b @?= True
-
-testFiles :: IO [String]
-testFiles = do let testDir = "test/parser_tests/"
-               files <- getDirectoryContents testDir
-               let filtered = filter (\f -> takeExtension f == ".bl") files
-               return $ map (testDir ++) filtered
+                  where
+                      fileAssertion :: Assertion
+                      fileAssertion = do (_, b) <- parse' f
+                                         b @?= True
 
 parse' :: String -> IO (String, Bool)
-parse' f = parseFromFile bonlangParser f
-       >>= \r -> return (f, parsedCorr r)
-    where
-        parsedCorr (Left _)  = False
-        parsedCorr (Right _) = True
-
+parse' f = parseFromFile bonlangParser f >>= \r -> return (f, parsedCorr r)
+           where
+                parsedCorr :: Either ParseError BonlangValue -> Bool
+                parsedCorr (Left _)  = False
+                parsedCorr (Right _) = True
 
+getFiles :: FilePath -> IO [String]
+getFiles dir = do files <- getDirectoryContents dir
+                  let filtered = filter (\f -> takeExtension f == ".bl") files
+                  return $ map (dir ++) filtered

test/examples/automatic_curry.bl

@@ -1,3 +1,7 @@
+---
+output: "4\n"
+---
+
 module Main where
 
 /**
@@ -8,7 +12,7 @@ def addValues [x, y] = + $ x y
 /**
  * Returns a lambda
  */
-def add2 [x1] = addValues $ 2
+def add2 [] = addValues $ 2
 
 def main [] = {
     val four = add2 $ 2;

test/examples/closure.bl

@@ -1,5 +1,8 @@
-module Main where
+---
+output: "1\n2\n3\n"
+---
 
+module Main where
 
 def main [] = {
     val λ = lambda [x, y, z] => map $ puts-ln [x, y, z];

test/examples/closures2.bl

@@ -1,3 +1,7 @@
+---
+output: "4\n4\n"
+---
+
 module Main where
 
 /**

test/examples/hello_add.bl

@@ -1,3 +1,7 @@
+---
+output: "0"
+---
+
 module Main where
 
 def main [] = {

test/examples/hello_bools.bl

@@ -1,3 +1,7 @@
+---
+output: "Hello Bool! 0"
+---
+
 module Main where
 
 def three [] = 3

test/examples/hello_equals.bl

@@ -1,3 +1,7 @@
+---
+output: "Testing this...\nIs equal? True\nWhat was equal... 2"
+---
+
 module Main where
 
 def main [] = {

test/examples/hello_world.bl

@@ -1,3 +1,7 @@
+---
+output: "Gonna say...\nHello World!\n"
+---
+
 module Main where
 
 def main [] = {

test/examples/lazy_hello.bl

@@ -1,3 +1,7 @@
+---
+output: "Lazy Hello!\n"
+---
+
 module Main where
 
 def main [] = {