@@ -2,10 +2,183 @@ module Test.Main where
22
33import Prelude
44
5+import Ansi.Codes (Color(..))
6+import Ansi.Output (foreground, withGraphics)
7+import ArgParse.Basic (ArgParser)
8+import ArgParse.Basic as ArgParser
9+import Data.Array (findMap)
10+import Data.Array as Array
11+import Data.Array.NonEmpty (NonEmptyArray)
12+import Data.Either (Either(..))
13+import Data.Foldable (for_)
14+import Data.Foldable as Foldable
15+import Data.Map as Map
16+import Data.Maybe (Maybe(..))
17+import Data.Monoid (power)
18+import Data.Newtype (unwrap)
19+import Data.Set as Set
20+import Data.String (Pattern(..))
21+import Data.String as String
22+import Data.String.CodeUnits as SCU
23+import Data.TraversableWithIndex (forWithIndex)
24+import Data.Tuple (Tuple(..))
25+import Dodo (plainText)
26+import Dodo as Dodo
527import Effect (Effect)
6−import Effect.Class.Console (log)
28+import Effect.Aff (Aff, Error, attempt, launchAff_)
29+import Effect.Aff as Error
30+import Effect.Class (liftEffect)
31+import Effect.Class.Console as Console
32+import Effect.Ref as Ref
33+import Node.Encoding (Encoding(..))
34+import Node.FS.Aff as FS
35+import Node.Glob.Basic (expandGlobs)
36+import Node.Path as Path
37+import Node.Process as Process
38+import PureScript.Backend.Chez.Convert (codegenModule)
39+import PureScript.Backend.Chez.Syntax as S
40+import PureScript.Backend.Optimizer.Builder (buildModules)
41+import PureScript.Backend.Optimizer.Convert (BackendModule)
42+import PureScript.Backend.Optimizer.CoreFn (Comment(..), Module(..), ModuleName(..))
43+import PureScript.Backend.Optimizer.Directives (parseDirectiveFile)
44+import PureScript.Backend.Optimizer.Directives.Defaults (defaultDirectives)
45+import PureScript.Backend.Optimizer.Semantics.Foreign (coreForeignSemantics)
46+import Test.Utils (bufferToUTF8, coreFnModulesFromOutput, execWithStdin, mkdirp, spawnFromParent)
47+
48+type TestArgs =
49+ { accept :: Boolean
50+ , filter :: NonEmptyArray String
51+ }
52+
53+argParser :: ArgParser TestArgs
54+argParser =
55+ ArgParser.fromRecord
56+ { accept:
57+ ArgParser.flag [ "--accept", "-a" ]
58+ "Accepts snapshot output"
59+ # ArgParser.boolean
60+ # ArgParser.default false
61+ , filter:
62+ ArgParser.argument [ "--filter", "-f" ]
63+ "Filter tests matching a prefix"
64+ # ArgParser.unfolded1
65+ # ArgParser.default (pure "Snapshot.*")
66+ }
767
868main :: Effect Unit
969main = do
10− log "🍝"
11− log "You should add some tests."
70+ cliArgs <- Array.drop 2 <$> Process.argv
71+ case ArgParser.parseArgs "test" "" argParser cliArgs of
72+ Left err ->
73+ Console.error $ ArgParser.printArgError err
74+ Right args ->
75+ launchAff_ $ runSnapshotTests args
76+
77+runSnapshotTests :: TestArgs -> Aff Unit
78+runSnapshotTests { accept, filter } = do
79+ liftEffect $ Process.chdir $ Path.concat [ "test-snapshots" ]
80+ spawnFromParent "spago" [ "build", "-u", "-g corefn" ]
81+ snapshotDir <- liftEffect Process.cwd
82+ snapshotPaths <- expandGlobs (Path.concat [ snapshotDir, "snapshots-input" ])
83+ [ "Snapshot.*.purs" ]
84+ outputRef <- liftEffect $ Ref.new Map.empty
85+ let snapshotsOut = Path.concat [ snapshotDir, "snapshots-output" ]
86+ let testOut = Path.concat [ snapshotDir, "test-out" ]
87+ mkdirp snapshotsOut
88+ mkdirp testOut
89+ coreFnModulesFromOutput "output" filter >>= case _ of
90+ Left errors -> do
91+ for_ errors \(Tuple filePath err) -> do
92+ Console.error $ filePath <> " " <> err
93+ liftEffect $ Process.exit 1
94+ Right coreFnModules -> do
95+ let { directives } = parseDirectiveFile defaultDirectives
96+ -- No runtime .ss files needed yet
97+ -- copyFile (Path.concat [ "..", "..", "runtime.js" ]) (Path.concat [ testOut, "runtime.js" ])
98+ coreFnModules # buildModules
99+ { directives
100+ , foreignSemantics: coreForeignSemantics -- no chez scheme specific foreign semantics yet
101+ , onCodegenModule: \_ (Module { name: ModuleName name, path }) backend -> do
102+ let
103+ formatted =
104+ Dodo.print plainText Dodo.twoSpaces $ S.printChezExpr $ codegenModule
105+ backend
106+ let testFileDir = Path.concat [ testOut, name ]
107+ let testFilePath = Path.concat [ testFileDir, "output.ss" ]
108+ mkdirp testFileDir
109+ FS.writeTextFile UTF8 testFilePath formatted
110+ -- Not worried about FFI yet
111+ -- unless (Set.isEmpty backend.foreign) do
112+ -- let
113+ -- foreignSiblingPath =
114+ -- fromMaybe path (String.stripSuffix (Pattern (Path.extname path)) path) <> ".ss"
115+ -- let foreignOutputPath = Path.concat [ testFileDir, "foreign.ss" ]
116+ -- copyFile foreignSiblingPath foreignOutputPath
117+ when (Set.member (Path.concat [ snapshotDir, path ]) snapshotPaths) do
118+ void $ liftEffect $ Ref.modify (Map.insert name (Tuple formatted (hasFails backend)))
119+ outputRef
120+ , onPrepareModule: \build coreFnMod@(Module { name }) -> do
121+ let total = show build.moduleCount
122+ let index = show (build.moduleIndex + 1)
123+ let padding = power " " (SCU.length total - SCU.length index)
124+ Console.log $ "[" <> padding <> index <> " of " <> total <> "] Building " <> unwrap name
125+ pure coreFnMod
126+ }
127+ outputModules <- liftEffect $ Ref.read outputRef
128+ results <- forWithIndex outputModules \name (Tuple output _failsWith) -> do
129+ let
130+ snapshotFilePath = Path.concat [ snapshotsOut, name <> ".ss" ]
131+ -- Not doing acceptance tests yet
132+ -- runAcceptedTest = do
133+ -- result <- attempt $ foldMap liftEffect =<< loadModuleMain =<< liftEffect
134+ -- (Path.resolve [ testOut, name ] "output.ss")
135+ -- case result of
136+ -- Left err | matchesFail err failsWith -> do
137+ -- Console.log $ withGraphics (foreground Red) "✗" <> " " <> name <> " failed."
138+ -- Console.log $ Error.message err
139+ -- pure false
140+ -- Right _ | isJust failsWith -> do
141+ -- Console.log $ withGraphics (foreground Red) "✗" <> " " <> name <>
142+ -- " succeeded when it should have failed."
143+ -- pure false
144+ -- _ ->
145+ -- pure true
146+ attempt (FS.readTextFile UTF8 snapshotFilePath) >>= case _ of
147+ Left _ -> do
148+ Console.log $ withGraphics (foreground Yellow) "✓" <> " " <> name <> " saved."
149+ FS.writeTextFile UTF8 snapshotFilePath output
150+ pure true
151+ Right prevOutput
152+ | output == prevOutput ->
153+ -- runAcceptedTest
154+ pure true
155+ | accept -> do
156+ Console.log $ withGraphics (foreground Yellow) "✓" <> " " <> name <> " accepted."
157+ FS.writeTextFile UTF8 snapshotFilePath output
158+ -- runAcceptedTest
159+ pure true
160+ | otherwise -> do
161+ Console.log $ withGraphics (foreground Red) "✗" <> " " <> name <> " failed."
162+ diff <- bufferToUTF8 <<< _.stdout =<< execWithStdin
163+ ("diff " <> snapshotFilePath <> " -")
164+ output
165+ Console.log diff
166+ pure false
167+ unless (Foldable.and results) do
168+ liftEffect $ Process.exit 1
169+
170+hasFails :: BackendModule -> Maybe String
171+hasFails = findMap go <<< _.comments
172+ where
173+ go = case _ of
174+ LineComment comm ->
175+ String.stripPrefix (Pattern "@fails ") (String.trim comm)
176+ _ ->
177+ Nothing
178+
179+matchesFail :: Error -> Maybe String -> Boolean
180+matchesFail err = case _ of
181+ Just msg ->
182+ not $ String.contains (Pattern msg) $ Error.message err
183+ Nothing ->
184+ true