git.iko.soy/rowtype-yoga/purescm
on bytevector help sign in
rowtype-yoga/purescm/test/Main.purs
173 lines 6.7 kB history raw
1-- A majority of the code below was copied from
2-- https://github.com/aristanetworks/purescript-backend-optimizer/blob/main/backend-es/test/Main.purs
3-- To fullfill copyright requirements...
4-- Copyright © 2022 Arista Networks, Inc.
5-- MIT license: https://opensource.org/license/mit/
6module Test.Main where
8import Prelude
10import Ansi.Codes (Color(..))
11import Ansi.Output (foreground, withGraphics)
12import ArgParse.Basic (ArgParser)
13import ArgParse.Basic as ArgParser
14import Data.Array as Array
15import Data.Array.NonEmpty (NonEmptyArray)
16import Data.Array.NonEmpty as NonEmptyArray
17import Data.Either (Either(..), either, isRight)
18import Data.Foldable as Foldable
19import Data.Maybe (Maybe(..))
20import Data.Monoid (power)
21import Data.Set as Set
22import Data.String (Pattern(..), Replacement(..))
23import Data.String as String
24import Data.String.CodeUnits as SCU
25import Data.TraversableWithIndex (forWithIndex)
26import Effect (Effect)
27import Effect.Aff (Aff, attempt, launchAff_)
28import Effect.Class (liftEffect)
29import Effect.Class.Console as Console
30import Node.Encoding (Encoding(..))
31import Node.FS.Aff as FS
32import Node.Glob.Basic (expandGlobs)
33import Node.Library.Execa.Which (defaultWhichOptions, which)
34import Node.Path as Path
35import Node.Process as Process
36import Partial.Unsafe (unsafeCrashWith)
37import PureScript.Backend.Chez.Constants (moduleLib, schemeExt)
38import Test.Utils (canRunMain, execWithStdin, loadModuleMain, mkdirp, spawnFromParent)
40type TestArgs =
41 { accept :: Boolean
42 , filter :: NonEmptyArray String
43 }
45argParser :: ArgParser TestArgs
46argParser =
47 ArgParser.fromRecord
48 { accept:
49 ArgParser.flag [ "--accept", "-a" ]
50 "Accepts snapshot output"
51 # ArgParser.boolean
52 # ArgParser.default false
53 , filter:
54 ArgParser.argument [ "--filter", "-f" ]
55 "Filter tests matching a prefix"
56 # ArgParser.unfolded1
57 # ArgParser.default (pure "Snapshot.*")
58 }
60main :: Effect Unit
61main = do
62 cliArgs <- Array.drop 2 <$> Process.argv
63 case ArgParser.parseArgs "test" "" argParser cliArgs of
64 Left err ->
65 Console.error $ ArgParser.printArgError err
66 Right args ->
67 launchAff_ $ runSnapshotTests args
69runSnapshotTests :: TestArgs -> Aff Unit
70runSnapshotTests { accept, filter } = do
71 currentDirectory <- liftEffect Process.cwd
72 let runtimeLibPath = Path.concat [ currentDirectory, "lib" ]
74 -- Get into the snapshot project and build it
75 liftEffect $ Process.chdir $ Path.concat [ "test-snapshots" ]
76 spawnFromParent "spago" [ "build" ]
77 snapshotDir <- liftEffect Process.cwd
78 let snapshotInput = Path.concat [ snapshotDir, "src", "snapshots-input" ]
79 let snapshotsOut = Path.concat [ snapshotDir, "src", "snapshots-output" ]
80 snapshotPaths <- expandGlobs snapshotInput (map (_ <> ".purs") $ NonEmptyArray.toArray filter)
81 mkdirp snapshotsOut
82 schemeBin <- getSchemeBinary
84 -- Tests return true or false depending on whether they pass
85 results <- forWithIndex (Set.toUnfoldable snapshotPaths :: Array _) \i snapshotInputPath -> do
86 let
87 -- The idea here is that we get files from the `output` directory, and check if
88 -- they look like the ones we have in `snapshots-output`
89 expectedSnapshotOutputPath =
90 String.replace (Pattern snapshotInput) (Replacement snapshotsOut)
91 $ String.replace (Pattern ".purs") (Replacement schemeExt)
92 $ snapshotInputPath
93 actualSnapshotOutputPath =
94 String.replace (Pattern snapshotInput) (Replacement (Path.concat [ snapshotDir, "output" ]))
95 $ String.replace (Pattern ".purs") (Replacement $ "/" <> moduleLib <> schemeExt)
96 $ snapshotInputPath
97 name = String.replace (Pattern $ snapshotInput <> "/") (Replacement "")
98 $ String.replace (Pattern ".purs") (Replacement "")
99 $ snapshotInputPath
101 let
102 total = show $ Set.size snapshotPaths
103 index = show i
104 padding = power " " (SCU.length total - SCU.length index)
105 Console.log $ "[" <> padding <> index <> " of " <> total <> "] Running test " <> name
107 -- Read the file generated by purescm
108 actualSnapshotOutput <- FS.readTextFile UTF8 actualSnapshotOutputPath
109 purescriptFile <- FS.readTextFile UTF8 snapshotInputPath
110 hasMain <- either unsafeCrashWith pure $ canRunMain purescriptFile
112 let
113 runAcceptedTest = do
114 result <- loadModuleMain
115 { libdir: runtimeLibPath <> ":output"
116 , scheme: schemeBin
117 , hasMain
118 , modulePath: actualSnapshotOutputPath
119 , moduleName: name
120 }
121 let shouldFail = isFailingTestFile purescriptFile
122 case result.exitCode of
123 Just 0 -> pure true
124 Just 0 | shouldFail -> do
125 Console.log $ withGraphics (foreground Red) "✗" <> " " <> name <> " should have failed."
126 Console.log result.message
127 pure false
128 _ | shouldFail -> pure true
129 _ -> do
130 Console.log $ withGraphics (foreground Red) "✗" <> " " <> name <> " failed."
131 Console.log result.message
132 pure false
134 attempt (FS.readTextFile UTF8 expectedSnapshotOutputPath) >>= case _ of
135 -- If we don't have this fixture yet, save it
136 Left _ -> do
137 Console.log $ withGraphics (foreground Yellow) "✓" <> " " <> name <> " saved."
138 FS.writeTextFile UTF8 expectedSnapshotOutputPath actualSnapshotOutput
139 pure true
140 Right prevOutput
141 -- We have and it looks the same -> run it
142 | actualSnapshotOutput == prevOutput ->
143 runAcceptedTest
144 -- We have it but we are accepting the new output -> save it, and run it afterwards
145 | accept -> do
146 Console.log $ withGraphics (foreground Yellow) "✓" <> " " <> name <> " accepted."
147 FS.writeTextFile UTF8 expectedSnapshotOutputPath actualSnapshotOutput
148 runAcceptedTest
149 -- We have it and it's broken
150 | otherwise -> do
151 Console.log $ withGraphics (foreground Red) "✗" <> " " <> name <> " failed."
152 diff <- _.stdout <$> execWithStdin "diff" [ expectedSnapshotOutputPath, "-" ]
153 actualSnapshotOutput
154 Console.log diff
155 pure false
157 unless (Foldable.and results) do
158 liftEffect $ Process.exit' 1
160isFailingTestFile :: String -> Boolean
161isFailingTestFile = String.contains (Pattern "Failing")
163getSchemeBinary :: Aff String
164getSchemeBinary = do
165 useScheme <- isRight <$> which "scheme" defaultWhichOptions
166 if useScheme then do
167 pure "scheme"
168 else do
169 useChez <- isRight <$> which "chez" defaultWhichOptions
170 if useChez then
171 pure "chez"
172 else do
173 unsafeCrashWith "Could not find scheme binary"