~jojo/Carth

5f4549698c6783d9dbed5f2bf6b12d537a529314 — JoJo 1 year, 1 month ago 6071f95
Test that examples and benchmarks compile

So now, `stack test` will: test that programs in test/tests/bad/ don't
typecheck, and fail with the expected error variant; test that
programs in examples/ compile; and test that programs in test/bench/
compile.

Next: test that programs in test/tests/good/ run and produce the
expected output.
M .gitignore => .gitignore +2 -1
@@ 7,4 7,5 @@
/dist/
*.untangled
*.svg
*.prof
\ No newline at end of file
*.prof
*.o
\ No newline at end of file

M app/GetConfig.hs => app/GetConfig.hs +1 -7
@@ 63,13 63,7 @@ compileCfg args = do
            $ ("Error: Input file \"" ++ inf ++ "\" ")
            ++ "would be overwritten by the generated executable"
        exitFailure
    let defaultCfg = CompileConfig
            { cInfile = inf
            , cOutfile = outf
            , cCompiler = "cc"
            , cDebug = False
            , cVerbose = False
            }
    let defaultCfg = defaultCompileConfig inf outf
        cfg = foldl (&) defaultCfg fs
    pure (CompileConf cfg)


A examples/sicp.carth => examples/sicp.carth +11 -0
@@ 0,0 1,11 @@
(import std)

(define (main unit)
  (display (show-int (fib 11))))

(define fib
  (fmatch
    (case 0 0)
    (case 1 1)
    (case n (+ (fib (- n 1))
               (fib (- n 2))))))

M src/Conf.hs => src/Conf.hs +9 -1
@@ 1,4 1,4 @@
module Conf (Conf(..), CompileConfig(..), RunConfig(..), verbose, Config(..)) where
module Conf where

import Control.Monad



@@ 31,5 31,13 @@ instance Config RunConfig where
    getDebug = rDebug
    getVerbose = rVerbose

defaultCompileConfig :: FilePath -> FilePath -> CompileConfig
defaultCompileConfig inf outf = CompileConfig { cInfile = inf
                                              , cOutfile = outf
                                              , cCompiler = "cc"
                                              , cDebug = False
                                              , cVerbose = False
                                              }

verbose :: Config cfg => cfg -> String -> IO ()
verbose cfg msg = when (getVerbose cfg) $ putStrLn msg

M test/SystemSpec.hs => test/SystemSpec.hs +26 -3
@@ 11,17 11,40 @@ import Test.Hspec

import Parse
import Check
import Compile
import Monomorphize
import Conf

spec :: Spec
spec = do
    -- describe "Good programs" $ do
    --     it "produce expected output" $ shouldSatisfy True id
    describe "Examples compile" $ do
        let d = "examples"
        fs <- runIO $ listDirectory d <&> filter isSourceFile
        forM_ fs $ \f -> do
            it (dropExtension f) $ shouldReturn (compile' (d </> f)) True
    describe "Benchmarks compile" $ do
        let d = "test/bench"
        fs <- runIO $ listDirectory d <&> filter isSourceFile
        forM_ fs $ \f -> do
            it (dropExtension f) $ shouldReturn (compile' (d </> f)) True
    describe "Bad programs don't typecheck" $ do
        let d = "test/tests/bad"
        fs <- runIO $ listDirectory d <&> filter (isExtensionOf "carth")
        fs <- runIO $ listDirectory d <&> filter isSourceFile
        forM_ fs $ \f -> do
            expectedErr <- runIO $ fmap (drop 3 . head . lines) (readFile (d </> f))
            result <- runIO $ parse (d </> f)
            it (dropExtension f) $ shouldSatisfy (fmap typecheck result) $ \case
                Right (Left e) -> show (toConstr e) == expectedErr
                _ -> False

isSourceFile :: FilePath -> Bool
isSourceFile f = let e = takeExtension f in e == ".carth" || e == ".org"

compile' :: FilePath -> IO Bool
compile' f =
    let cfg = defaultCompileConfig f (dropExtension f)
    in  Parse.parse f >>= \case
            Left _ -> pure False
            Right ast -> case typecheck ast of
                Left _ -> pure False
                Right ann -> compile f cfg (monomorphize ann) $> True

A test/bench/big-nested-struct-on-heap.carth => test/bench/big-nested-struct-on-heap.carth +19 -0
@@ 0,0 1,19 @@
(import std)

(define (main Unit)
  (for (range-from 0) big-allocation))

(define (big-allocation n)
  (let ((a (A n n n n))
        (b (B a a a a))
        (c (C b b b b))
        (d (D c c c c))
        (e (E d d d d)))
    (seq (box (F e e e e)) (display (show-int n)))))

(data A (A Int Int Int Int))
(data B (B A A A A))
(data C (C B B B B))
(data D (D C C C C))
(data E (E D D D D))
(data F (F E E E E))