@@ -15,7 +15,6 @@ import Data.Array (findMap)
1515import Data.Array as Array
1616import Data.Array.NonEmpty (NonEmptyArray)
1717import Data.Either (Either(..), either, isRight)
18−import Data.Foldable (for_)
1918import Data.Foldable as Foldable
2019import Data.Map as Map
2120import Data.Maybe (Maybe(..), fromMaybe, isJust)
@@ -26,7 +25,6 @@ import Data.String (Pattern(..))
2625import Data.String as String
2726import Data.String.CodeUnits as SCU
2827import Data.TraversableWithIndex (forWithIndex)
29−import Data.Tuple (Tuple(..))
3028import Dodo (plainText)
3129import Dodo as Dodo
3230import Effect (Effect)
@@ -41,17 +39,14 @@ import Node.Library.Execa.Which (defaultWhichOptions, which)
4139import Node.Path as Path
4240import Node.Process as Process
4341import Partial.Unsafe (unsafeCrashWith)
42+import PureScript.Backend.Chez.Builder (basicBuildMain)
4443import PureScript.Backend.Chez.Constants (moduleForeign, moduleLib, schemeExt)
4544import PureScript.Backend.Chez.Convert (codegenModule)
4645import PureScript.Backend.Chez.Printer as P
4746import PureScript.Backend.Chez.Runtime (runtimeModule)
48−import PureScript.Backend.Optimizer.Builder (buildModules)
4947import PureScript.Backend.Optimizer.Convert (BackendModule)
5048import PureScript.Backend.Optimizer.CoreFn (Comment(..), Module(..), ModuleName(..))
51−import PureScript.Backend.Optimizer.Directives (parseDirectiveFile)
52−import PureScript.Backend.Optimizer.Directives.Defaults (defaultDirectives)
53−import PureScript.Backend.Optimizer.Semantics.Foreign (coreForeignSemantics)
54−import Test.Utils (bufferToUTF8, canRunMain, copyFile, coreFnModulesFromOutput, execWithStdin, loadModuleMain, mkdirp, spawnFromParent)
49+import Test.Utils (bufferToUTF8, canRunMain, copyFile, execWithStdin, loadModuleMain, mkdirp, spawnFromParent)
5550
5651type TestArgs =
5752 { accept :: Boolean
@@ -103,98 +98,90 @@ runSnapshotTests { accept, filter } = do
10398 let runtimeFilePath = Path.concat [ runtimePath, moduleLib <> schemeExt ]
10499 let runtimeContents = Dodo.print plainText Dodo.twoSpaces $ P.printLibrary $ runtimeModule
105100 FS.writeTextFile UTF8 runtimeFilePath runtimeContents
106− coreFnModulesFromOutput "output" filter >>= case _ of
107− Left errors -> do
108− for_ errors \(Tuple filePath err) -> do
109− Console.error $ filePath <> " " <> err
110− liftEffect $ Process.exit 1
111− Right coreFnModules -> do
112− let { directives } = parseDirectiveFile defaultDirectives
113− coreFnModules # buildModules
114− { directives
115− , foreignSemantics: coreForeignSemantics -- no chez scheme specific foreign semantics yet
116− , onCodegenModule: \_ (Module { name: ModuleName name, path }) backend _ -> do
117− let
118− formatted =
119− Dodo.print plainText Dodo.twoSpaces
120− $ P.printLibrary
121− $ codegenModule backend
122− let testFileDir = Path.concat [ testOut, name ]
123− let testFilePath = Path.concat [ testFileDir, moduleLib <> schemeExt ]
124− mkdirp testFileDir
125− FS.writeTextFile UTF8 testFilePath formatted
126− unless (Set.isEmpty backend.foreign) do
127− let
128− foreignSiblingPath =
129− fromMaybe path (String.stripSuffix (Pattern (Path.extname path)) path) <>
130− schemeExt
131− let foreignOutputPath = Path.concat [ testFileDir, moduleForeign <> schemeExt ]
132− copyFile foreignSiblingPath foreignOutputPath
133− let snapshotDirFile = Path.concat [ snapshotDir, path ]
134− when (Set.member snapshotDirFile snapshotPaths) do
135− originalFileSourceCode <- FS.readTextFile UTF8 snapshotDirFile
136− hasMain <- either unsafeCrashWith pure $
137− canRunMain originalFileSourceCode
138− void $ liftEffect $ Ref.modify
139− (Map.insert name ({ formatted, failsWith: hasFails backend, hasMain }))
140− outputRef
141− , onPrepareModule: \build coreFnMod@(Module { name }) -> do
142− let total = show build.moduleCount
143− let index = show (build.moduleIndex + 1)
144− let padding = power " " (SCU.length total - SCU.length index)
145− Console.log $ "[" <> padding <> index <> " of " <> total <> "] Building " <> unwrap name
146− pure coreFnMod
147− , traceIdents: Set.empty
148− }
149− outputModules <- liftEffect $ Ref.read outputRef
150− results <- forWithIndex outputModules \name ({ formatted, failsWith, hasMain }) -> do
101+ basicBuildMain
102+ { coreFnDirectory: "output"
103+ , coreFnGlobs: filter
104+ , onCodegenModule: \_ (Module { name: ModuleName name, path }) backend _ -> do
151105 let
152− snapshotFilePath = Path.concat [ snapshotsOut, name <> schemeExt ]
153− runAcceptedTest = do
154− schemeFile <- liftEffect $ Path.resolve [ testOut, name ] $ moduleLib <> schemeExt
155− result <- loadModuleMain
156− { libdir: vendorDirectory <> ":" <> testOut
157− , scheme: schemeBin
158− , hasMain
159− , modulePath: schemeFile
160− , moduleName: name
161− }
162− case result of
163− Left { message }
164− | matchesFail message failsWith ->
165− pure true
166− | otherwise -> do
167− Console.log $ withGraphics (foreground Red) "✗" <> " " <> name <> " failed."
168− Console.log message
169− pure false
170− Right _
171− | isJust failsWith -> do
172− Console.log $ withGraphics (foreground Red) "✗" <> " " <> name <>
173− " succeeded when it should have failed."
174− pure false
175− | otherwise ->
176− pure true
177− attempt (FS.readTextFile UTF8 snapshotFilePath) >>= case _ of
178− Left _ -> do
179− Console.log $ withGraphics (foreground Yellow) "✓" <> " " <> name <> " saved."
180− FS.writeTextFile UTF8 snapshotFilePath formatted
181− pure true
182− Right prevOutput
183− | formatted == prevOutput ->
184− runAcceptedTest
185− | accept -> do
186− Console.log $ withGraphics (foreground Yellow) "✓" <> " " <> name <> " accepted."
187− FS.writeTextFile UTF8 snapshotFilePath formatted
188− runAcceptedTest
106+ formatted =
107+ Dodo.print plainText Dodo.twoSpaces
108+ $ P.printLibrary
109+ $ codegenModule backend
110+ let testFileDir = Path.concat [ testOut, name ]
111+ let testFilePath = Path.concat [ testFileDir, moduleLib <> schemeExt ]
112+ mkdirp testFileDir
113+ FS.writeTextFile UTF8 testFilePath formatted
114+ unless (Set.isEmpty backend.foreign) do
115+ let
116+ foreignSiblingPath =
117+ fromMaybe path (String.stripSuffix (Pattern (Path.extname path)) path) <>
118+ schemeExt
119+ let foreignOutputPath = Path.concat [ testFileDir, moduleForeign <> schemeExt ]
120+ copyFile foreignSiblingPath foreignOutputPath
121+ let snapshotDirFile = Path.concat [ snapshotDir, path ]
122+ when (Set.member snapshotDirFile snapshotPaths) do
123+ originalFileSourceCode <- FS.readTextFile UTF8 snapshotDirFile
124+ hasMain <- either unsafeCrashWith pure $
125+ canRunMain originalFileSourceCode
126+ void $ liftEffect $ Ref.modify
127+ (Map.insert name ({ formatted, failsWith: hasFails backend, hasMain }))
128+ outputRef
129+ , onPrepareModule: \build coreFnMod@(Module { name }) -> do
130+ let total = show build.moduleCount
131+ let index = show (build.moduleIndex + 1)
132+ let padding = power " " (SCU.length total - SCU.length index)
133+ Console.log $ "[" <> padding <> index <> " of " <> total <> "] Building " <> unwrap name
134+ pure coreFnMod
135+ }
136+ outputModules <- liftEffect $ Ref.read outputRef
137+ results <- forWithIndex outputModules \name ({ formatted, failsWith, hasMain }) -> do
138+ let
139+ snapshotFilePath = Path.concat [ snapshotsOut, name <> schemeExt ]
140+ runAcceptedTest = do
141+ schemeFile <- liftEffect $ Path.resolve [ testOut, name ] $ moduleLib <> schemeExt
142+ result <- loadModuleMain
143+ { libdir: vendorDirectory <> ":" <> testOut
144+ , scheme: schemeBin
145+ , hasMain
146+ , modulePath: schemeFile
147+ , moduleName: name
148+ }
149+ case result of
150+ Left { message }
151+ | matchesFail message failsWith ->
152+ pure true
189153 | otherwise -> do
190154 Console.log $ withGraphics (foreground Red) "✗" <> " " <> name <> " failed."
191− diff <- bufferToUTF8 <<< _.stdout =<< execWithStdin
192− ("diff " <> snapshotFilePath <> " -")
193− formatted
194− Console.log diff
155+ Console.log message
195156 pure false
196− unless (Foldable.and results) do
197− liftEffect $ Process.exit 1
157+ Right _
158+ | isJust failsWith -> do
159+ Console.log $ withGraphics (foreground Red) "✗" <> " " <> name <>
160+ " succeeded when it should have failed."
161+ pure false
162+ | otherwise ->
163+ pure true
164+ attempt (FS.readTextFile UTF8 snapshotFilePath) >>= case _ of
165+ Left _ -> do
166+ Console.log $ withGraphics (foreground Yellow) "✓" <> " " <> name <> " saved."
167+ FS.writeTextFile UTF8 snapshotFilePath formatted
168+ pure true
169+ Right prevOutput
170+ | formatted == prevOutput ->
171+ runAcceptedTest
172+ | accept -> do
173+ Console.log $ withGraphics (foreground Yellow) "✓" <> " " <> name <> " accepted."
174+ FS.writeTextFile UTF8 snapshotFilePath formatted
175+ runAcceptedTest
176+ | otherwise -> do
177+ Console.log $ withGraphics (foreground Red) "✗" <> " " <> name <> " failed."
178+ diff <- bufferToUTF8 <<< _.stdout =<< execWithStdin
179+ ("diff " <> snapshotFilePath <> " -")
180+ formatted
181+ Console.log diff
182+ pure false
183+ unless (Foldable.and results) do
184+ liftEffect $ Process.exit 1
198185
199186hasFails :: BackendModule -> Maybe String
200187hasFails = findMap go <<< _.comments