~jojo/Carth

ref: 27587c11a60188f03779912feebebea41625da2a Carth/test/SystemSpec.hs -rw-r--r-- 2.7 KiB
27587c11JoJo Fix undefined macros due to imports not being imported in order 1 year, 3 months ago
                                                                                
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
{-# LANGUAGE LambdaCase #-}

module SystemSpec where

import Prelude hiding (lex)

import Data.Data
import Data.Functor
import Control.Monad
import Control.Monad.Except
import System.Directory
import System.FilePath
import Data.List
import Test.Hspec
import System.IO.Silently

import Misc
import Lex
import Parse
import qualified Parsed
import Check
import Compile
import Monomorphize
import Optimize
import qualified Optimized as Ast
import Conf

spec :: Spec
spec = do
    describe "Good programs run with expected output" $ do
        let d = "test/tests/good"
        fs <- runIO $ listDirectory d <&> filter isSourceFile
        forM_ fs $ \f -> do
            expectedOut <- runIO $ fmap
                (unlines . map (drop 3) . takeWhile (isPrefixOf ";; ") . lines)
                (readFile (d </> f))
            it (dropExtension f) $ shouldReturn (run' (d </> f)) expectedOut
    describe "Bad programs don't typecheck" $ do
        let d = "test/tests/bad"
        fs <- runIO $ listDirectory d <&> filter isSourceFile
        forM_ fs $ \f -> do
            expectedErr <- runIO $ fmap (drop 3 . head . lines) (readFile (d </> f))
            result <- runIO $ lexAndParse (d </> f)
            it (dropExtension f) $ shouldSatisfy (fmap typecheck result) $ \case
                Just (Left e) -> show (toConstr e) == expectedErr
                _ -> False
    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

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

run' :: FilePath -> IO String
run' f =
    let cfg = defaultRunConfig f
    in  frontend f >>= \case
            Nothing -> error "Program failed to pass through frontend"
            Just ast -> capture_ (run f cfg ast)

compile' :: FilePath -> IO Bool
compile' f =
    let cfg = defaultCompileConfig f (dropExtension f)
    in  frontend f >>= \case
            Nothing -> pure False
            Just ast -> compile f cfg ast $> True

frontend :: FilePath -> IO (Maybe Ast.Program)
frontend f = lexAndParse f <&> \case
    Nothing -> Nothing
    Just ast -> fmap (optimize . monomorphize) (rightToMaybe (typecheck ast))

lexAndParse :: FilePath -> IO (Maybe Parsed.Program)
lexAndParse f = fmap rightToMaybe (runExceptT (lex' f >>= parse''))
  where
    lex' = withExceptT (const ()) . lex
    parse'' = withExceptT (const ()) . liftEither . runExcept . parse