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 e <- do
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 return stderrE
120 unless (e /= "") $ do
121 do
122 step "Checking Generated Representation"
123 stdoutG <- fixWindowsPaths <$> readIfExists (tBaseDir </> "model.json")
124 stdoutE <- readIfExists (tBaseDir </> "model.expected.json")
125 let diffs = do
126 jGiven <- stringToJson stdoutG
127 jReference <- stringToJson stdoutE
128 let Patch ds = diff jGiven jReference
129 return ds
130 case diffs of
131 Nothing -> assertFailure $ "JSON parser error in" ++ stdoutE
132 Just [] -> return ()
133 Just ops -> assertFailure $ renderNormal $ vcat ["Difference in json:" <++> vcat (map (stringToDoc . show) ops)]
134 do
135 step "Checking stdout"
136 stdoutG <- fixWindowsPaths <$> readIfExists (tBaseDir </> "stdout")
137 stdoutE <- readIfExists (tBaseDir </> "stdout.expected")
138 unless (stdoutE == stdoutG) $
139 assertFailure $
140 renderNormal $
141 vcat
142 [ "unexpected stdout:" <++> pretty stdoutG
143 , "was expecting: " <++> pretty stdoutE
144 ]
145 do
146 step "Checking Types"
147 stdoutE <- fixWindowsPaths <$> readIfExists (tBaseDir </> "typecheck")
148 stdoutG <- readIfExists (tBaseDir </> "typecheck.expected")
149 unless (stdoutE == stdoutG) $
150 assertFailure $
151 renderNormal $
152 vcat
153 [ "unexpected typeError:" <++> pretty stdoutG
154 , "was expecting: " <++> pretty stdoutE
155 ]
156
157 stringToJson :: String -> Maybe JSON.Value
158 stringToJson "" = Just JSON.emptyObject
159 stringToJson s = decode' $ toLazyByteString $ encodeUtf8Builder $ Data.Text.pack s