never executed always true always false
1 {-# LANGUAGE RecordWildCards #-}
2
3 module Conjure.ParsePrint (tests) where
4
5 -- conjure
6
7 import Conjure.Language.Definition (Model)
8 import Conjure.Language.NameGen (runNameGen)
9 import Conjure.Language.Pretty
10 import Conjure.Language.Type (TypeCheckerMode (..))
11 import Conjure.Prelude
12 import Conjure.UI (OutputFormat (..))
13 import Conjure.UI.IO (readModelFromFile, writeModel)
14 import Conjure.UI.TypeCheck (typeCheckModel_StandAlone)
15 import Conjure.UserError
16
17 -- base
18 import System.Info (os)
19
20 -- tasty
21 import Test.Tasty (TestTree, testGroup)
22 import Test.Tasty.HUnit (assertFailure, testCaseSteps)
23
24 import Data.Aeson (decode')
25 import qualified Data.Aeson as JSON
26 import Data.Aeson.Diff
27 import Data.ByteString.Builder (toLazyByteString)
28 import qualified Data.Text
29 import Data.Text.Encoding (encodeUtf8Builder)
30 import qualified Data.Aeson.Types as JSON
31
32 tests ::
33 (?typeCheckerMode :: TypeCheckerMode) =>
34 IO TestTree
35 tests = do
36 let baseDir = "tests/parse_print"
37 dirs <- mapM (isTestDir baseDir) =<< getAllDirs baseDir
38 let testCases = map testSingleDir (catMaybes dirs)
39 return (testGroup "parse_print" testCases)
40
41 data TestDirFiles = TestDirFiles
42 { name :: String -- a name for the test case
43 , tBaseDir :: FilePath -- dir
44 , essenceFile :: FilePath -- dir + filename
45 }
46 deriving (Show)
47
48 -- returns True if the argument points to a directory that is not hidden
49 isTestDir :: FilePath -> FilePath -> IO (Maybe TestDirFiles)
50 isTestDir baseDir dir = do
51 essenceFiles <- filter (".essence" `isSuffixOf`) <$> getDirectoryContents dir
52 case essenceFiles of
53 [f] ->
54 return $
55 Just
56 TestDirFiles
57 { name = drop (length baseDir + 1) dir
58 , tBaseDir = dir
59 , essenceFile = dir </> f
60 }
61 _ -> return Nothing
62
63 -- the first FilePath is the base directory for the parse_print tests
64 -- we know at this point that the second FilePath points to a directory D,
65 -- which contains + an Essence file D/D.essence
66 testSingleDir ::
67 (?typeCheckerMode :: TypeCheckerMode) =>
68 TestDirFiles ->
69 TestTree
70 testSingleDir TestDirFiles{..} = testCaseSteps (map (\ch -> if ch == '/' then '.' else ch) name) $ \step -> do
71 step "Conjuring"
72 model_ <- runUserErrorT (readModelFromFile essenceFile)
73 let tyCheck :: Model -> Either Doc ()
74 tyCheck m = runNameGen () $ ignoreLogs $ void $ typeCheckModel_StandAlone m
75 let result :: Either Doc Model
76 result = case model_ of
77 Left err -> userErr err
78 Right model -> Right model
79 case result of
80 Left "" -> do
81 removeFileIfExists (tBaseDir </> "stderr")
82 removeFileIfExists (tBaseDir </> "stdout")
83 Left err -> do
84 writeFile (tBaseDir </> "stderr") (renderNormal err)
85 removeFileIfExists (tBaseDir </> "stdout")
86 Right model -> do
87 writeModel 120 ASTJSON (Just (tBaseDir </> "model.json")) model
88 writeModel 120 Plain (Just (tBaseDir </> "stdout")) model
89 case tyCheck model of
90 Left err -> writeFile (tBaseDir </> "typecheck") (renderNormal err)
91 Right () -> writeFile (tBaseDir </> "typecheck") ""
92 removeFileIfExists (tBaseDir </> "stderr")
93
94 let fixWindowsPaths :: String -> String
95 fixWindowsPaths
96 | os `elem` ["mingw32"] = fixBackslashes
97 | otherwise = id
98
99 fixBackslashes :: String -> String
100 fixBackslashes ('/' : '\\' : xs) = "/\\" ++ fixBackslashes xs
101 fixBackslashes ('\\' : '/' : xs) = "\\/" ++ fixBackslashes xs
102 fixBackslashes ('\\' : xs) = '/' : fixBackslashes xs
103 fixBackslashes [] = []
104 fixBackslashes (x : xs) = x : fixBackslashes xs
105
106 readIfExists :: FilePath -> IO String
107 readIfExists f = fromMaybe "" <$> readFileIfExists f
108
109 step "Checking stderr"
110 stderrG <- fixWindowsPaths <$> readIfExists (tBaseDir </> "stderr")
111 stderrE <- readIfExists (tBaseDir </> "stderr.expected")
112 unless (stderrE == stderrG) $
113 assertFailure $
114 renderNormal $
115 vcat
116 [ "unexpected stderr:" <++> pretty stderrG
117 , "was expecting: " <++> pretty stderrE
118 ]
119
120 step "Checking stdout"
121 stdoutG <- fixWindowsPaths <$> readIfExists (tBaseDir </> "stdout")
122 stdoutE <- readIfExists (tBaseDir </> "stdout.expected")
123 unless (stdoutE == stdoutG) $
124 assertFailure $
125 renderNormal $
126 vcat
127 [ "unexpected stdout:" <++> pretty stdoutG
128 , "was expecting: " <++> pretty stdoutE
129 ]
130
131 step "Checking Generated Representation"
132 modelG <- fixWindowsPaths <$> readIfExists (tBaseDir </> "model.json")
133 unless (null modelG) $ do
134 modelE <- readIfExists (tBaseDir </> "model.expected.json")
135 let diffs = do
136 jGiven <- stringToJson modelG
137 jReference <- stringToJson modelE
138 let Patch ds = diff jGiven jReference
139 return ds
140 case diffs of
141 Nothing -> assertFailure $ "JSON parser error in" ++ modelE
142 Just [] -> return ()
143 Just ops -> assertFailure $ renderNormal $ vcat ["Difference in json:" <++> vcat (map (stringToDoc . show) ops)]
144
145 step "Checking Types"
146 typecheckG <- fixWindowsPaths <$> readIfExists (tBaseDir </> "typecheck")
147 unless (null typecheckG) $ do
148 typecheckE <- readIfExists (tBaseDir </> "typecheck.expected")
149 unless (typecheckE == typecheckG) $
150 assertFailure $
151 renderNormal $
152 vcat
153 [ "unexpected typeError:" <++> pretty typecheckG
154 , "was expecting: " <++> pretty typecheckE
155 ]
156
157 stringToJson :: String -> Maybe JSON.Value
158 stringToJson "" = Just JSON.emptyObject
159 stringToJson s = decode' $ toLazyByteString $ encodeUtf8Builder $ Data.Text.pack s