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 removeFileIfExists (tBaseDir </> "model.json")
84 removeFileIfExists (tBaseDir </> "typecheck")
85 Left err -> do
86 writeFile (tBaseDir </> "stderr") (renderNormal err)
87 removeFileIfExists (tBaseDir </> "stdout")
88 removeFileIfExists (tBaseDir </> "model.json")
89 removeFileIfExists (tBaseDir </> "typecheck")
90 Right model -> do
91 writeModel 120 ASTJSON (Just (tBaseDir </> "model.json")) model
92 writeModel 120 Plain (Just (tBaseDir </> "stdout")) model
93 case tyCheck model of
94 Left err -> writeFile (tBaseDir </> "typecheck") (renderNormal err)
95 Right () -> writeFile (tBaseDir </> "typecheck") ""
96 removeFileIfExists (tBaseDir </> "stderr")
97
98 let fixWindowsPaths :: String -> String
99 fixWindowsPaths
100 | os `elem` ["mingw32"] = fixBackslashes
101 | otherwise = id
102
103 fixBackslashes :: String -> String
104 fixBackslashes ('/' : '\\' : xs) = "/\\" ++ fixBackslashes xs
105 fixBackslashes ('\\' : '/' : xs) = "\\/" ++ fixBackslashes xs
106 fixBackslashes ('\\' : xs) = '/' : fixBackslashes xs
107 fixBackslashes [] = []
108 fixBackslashes (x : xs) = x : fixBackslashes xs
109
110 readIfExists :: FilePath -> IO String
111 readIfExists f = fromMaybe "" <$> readFileIfExists f
112
113 step "Checking stderr"
114 stderrG <- fixWindowsPaths <$> readIfExists (tBaseDir </> "stderr")
115 stderrE <- readIfExists (tBaseDir </> "stderr.expected")
116 unless (stderrE == stderrG) $
117 assertFailure $
118 renderNormal $
119 vcat
120 [ "unexpected stderr:" <++> pretty stderrG
121 , "was expecting: " <++> pretty stderrE
122 ]
123
124 step "Checking stdout"
125 stdoutG <- fixWindowsPaths <$> readIfExists (tBaseDir </> "stdout")
126 stdoutE <- readIfExists (tBaseDir </> "stdout.expected")
127 unless (stdoutE == stdoutG) $
128 assertFailure $
129 renderNormal $
130 vcat
131 [ "unexpected stdout:" <++> pretty stdoutG
132 , "was expecting: " <++> pretty stdoutE
133 ]
134
135 step "Checking Generated Representation"
136 modelG <- fixWindowsPaths <$> readIfExists (tBaseDir </> "model.json")
137 unless (null modelG) $ do
138 modelE <- readIfExists (tBaseDir </> "model.expected.json")
139 let diffs = do
140 jGiven <- stringToJson modelG
141 jReference <- stringToJson modelE
142 let Patch ds = diff jGiven jReference
143 return ds
144 case diffs of
145 Nothing -> assertFailure $ "JSON parser error in" ++ modelE
146 Just [] -> return ()
147 Just ops -> assertFailure $ renderNormal $ vcat ["Difference in json:" <++> vcat (map (stringToDoc . show) ops)]
148
149 step "Checking Types"
150 typecheckG <- fixWindowsPaths <$> readIfExists (tBaseDir </> "typecheck")
151 unless (null typecheckG) $ do
152 typecheckE <- readIfExists (tBaseDir </> "typecheck.expected")
153 unless (typecheckE == typecheckG) $
154 assertFailure $
155 renderNormal $
156 vcat
157 [ "unexpected typeError:" <++> pretty typecheckG
158 , "was expecting: " <++> pretty typecheckE
159 ]
160
161 stringToJson :: String -> Maybe JSON.Value
162 stringToJson "" = Just JSON.emptyObject
163 stringToJson s = decode' $ toLazyByteString $ encodeUtf8Builder $ Data.Text.pack s