git.iko.soy/rowtype-yoga/purescm
on bytevector help sign in
Add a common builder helper (#152)
b53599dAntti Holvikari
src/Main.purs+33−95
compare with bytevector
unifiedsplit
@@ -4,27 +4,15 @@ import Prelude
4
4
5import ArgParse.Basic (ArgParser)
5import ArgParse.Basic (ArgParser)
6import ArgParse.Basic as ArgParser
6import ArgParse.Basic as ArgParser
7−import Control.Monad.Except (ExceptT(..), lift, runExceptT)
8−import Control.Parallel (parTraverse)
9−import Data.Argonaut as Json
10import Data.Array as Array
7import Data.Array as Array
11−import Data.Array.NonEmpty (NonEmptyArray)
12−import Data.Array.NonEmpty as NonEmptyArray
13−import Data.Bifunctor (lmap)
14−import Data.Compactable (separate)
15import Data.Either (Either(..), isRight)
8import Data.Either (Either(..), isRight)
16−import Data.Foldable (for_, foldl)
17−import Data.Lazy as Lazy
18−import Data.List (List)
19−import Data.Maybe (fromMaybe, maybe)
9+import Data.Maybe (fromMaybe)
20import Data.Monoid (power)
10import Data.Monoid (power)
21import Data.Newtype (unwrap)
11import Data.Newtype (unwrap)
22import Data.Set as Set
12import Data.Set as Set
23−import Data.Set.NonEmpty as NonEmptySet
24import Data.String (Pattern(..))
13import Data.String (Pattern(..))
25import Data.String as String
14import Data.String as String
26import Data.String.CodeUnits as SCU
15import Data.String.CodeUnits as SCU
27−import Data.Tuple (Tuple(..))
28import Dodo (plainText)
16import Dodo (plainText)
29import Dodo as Dodo
17import Dodo as Dodo
30import Effect (Effect)
18import Effect (Effect)
@@ -37,7 +25,6 @@ import Node.FS.Perms (mkPerms)
37import Node.FS.Perms as Perms
25import Node.FS.Perms as Perms
38import Node.FS.Stats as Stats
26import Node.FS.Stats as Stats
39import Node.FS.Stream (createReadStream, createWriteStream)
27import Node.FS.Stream (createReadStream, createWriteStream)
40−import Node.Glob.Basic (expandGlobs)
41import Node.Library.Execa (ExecaError, ExecaSuccess, execa)
28import Node.Library.Execa (ExecaError, ExecaSuccess, execa)
42import Node.Library.Execa.Which (defaultWhichOptions, which)
29import Node.Library.Execa.Which (defaultWhichOptions, which)
43import Node.Path (FilePath)
30import Node.Path (FilePath)
@@ -45,17 +32,12 @@ import Node.Path as Path
45import Node.Process as Process
32import Node.Process as Process
46import Node.Stream as Stream
33import Node.Stream as Stream
47import Partial.Unsafe (unsafeCrashWith)
34import Partial.Unsafe (unsafeCrashWith)
35+import PureScript.Backend.Chez.Builder (basicBuildMain)
48import PureScript.Backend.Chez.Constants (moduleForeign, moduleLib, schemeExt)
36import PureScript.Backend.Chez.Constants (moduleForeign, moduleLib, schemeExt)
49import PureScript.Backend.Chez.Convert (codegenModule)
37import PureScript.Backend.Chez.Convert (codegenModule)
50import PureScript.Backend.Chez.Printer as Printer
38import PureScript.Backend.Chez.Printer as Printer
51import PureScript.Backend.Chez.Runtime (runtimeModule)
39import PureScript.Backend.Chez.Runtime (runtimeModule)
52−import PureScript.Backend.Optimizer.Builder (buildModules)
40+import PureScript.Backend.Optimizer.CoreFn (Module(..), ModuleName(..))
53−import PureScript.Backend.Optimizer.CoreFn (Ann, Module(..), ModuleName(..))
54−import PureScript.Backend.Optimizer.CoreFn.Json (decodeModule)
55−import PureScript.Backend.Optimizer.CoreFn.Sort (emptyPull, pullResult, resumePull, sortModules)
56−import PureScript.Backend.Optimizer.Directives (parseDirectiveFile)
57−import PureScript.Backend.Optimizer.Directives.Defaults (defaultDirectives)
58−import PureScript.Backend.Optimizer.Semantics.Foreign (coreForeignSemantics)
59
41
60type BuildArgs =
42type BuildArgs =
61 { coreFnDir :: FilePath
43 { coreFnDir :: FilePath
@@ -141,44 +123,36 @@ runBuild args = do
141 let runtimeFilePath = Path.concat [ runtimePath, moduleLib <> schemeExt ]
123 let runtimeFilePath = Path.concat [ runtimePath, moduleLib <> schemeExt ]
142 let runtimeContents = Dodo.print plainText Dodo.twoSpaces $ Printer.printLibrary $ runtimeModule
124 let runtimeContents = Dodo.print plainText Dodo.twoSpaces $ Printer.printLibrary $ runtimeModule
143 FS.writeTextFile UTF8 runtimeFilePath runtimeContents
125 FS.writeTextFile UTF8 runtimeFilePath runtimeContents
144− coreFnModulesFromOutput args.coreFnDir (pure "**") >>= case _ of
126+ basicBuildMain
145− Left errors -> do
127+ { coreFnDirectory: args.coreFnDir
146− for_ errors \(Tuple filePath err) -> do
128+ , coreFnGlobs: pure "**"
147− Console.error $ filePath <> " " <> err
148− liftEffect $ Process.exit 1
149− Right coreFnModules -> do
150− let { directives } = parseDirectiveFile defaultDirectives
151− coreFnModules # buildModules
152− { directives
153− , foreignSemantics: coreForeignSemantics
154− , onCodegenModule: \_ (Module { name: ModuleName name, path }) backend _ -> do
129+ , onCodegenModule: \_ (Module { name: ModuleName name, path }) backend _ -> do
155− let
130+ let
156− formatted =
131+ formatted =
157− Dodo.print plainText Dodo.twoSpaces
132+ Dodo.print plainText Dodo.twoSpaces
158− $ Printer.printLibrary
133+ $ Printer.printLibrary
159− $ codegenModule backend
134+ $ codegenModule backend
160− let modPath = Path.concat [ args.outputDir, name ]
135+ let modPath = Path.concat [ args.outputDir, name ]
161− mkdirp modPath
136+ mkdirp modPath
162− let libPath = Path.concat [ modPath, moduleLib <> schemeExt ]
137+ let libPath = Path.concat [ modPath, moduleLib <> schemeExt ]
163− FS.writeTextFile UTF8 libPath formatted
138+ FS.writeTextFile UTF8 libPath formatted
164− unless (Set.isEmpty backend.foreign) do
139+ unless (Set.isEmpty backend.foreign) do
165− let
140+ let
166− foreignSiblingPath =
141+ foreignSiblingPath =
167− fromMaybe path (String.stripSuffix (Pattern (Path.extname path)) path) <>
142+ fromMaybe path (String.stripSuffix (Pattern (Path.extname path)) path) <>
168− schemeExt
143+ schemeExt
169− let foreignOutputPath = Path.concat [ modPath, moduleForeign <> schemeExt ]
144+ let foreignOutputPath = Path.concat [ modPath, moduleForeign <> schemeExt ]
170− res <- attempt $ copyFile foreignSiblingPath foreignOutputPath
145+ res <- attempt $ copyFile foreignSiblingPath foreignOutputPath
171− unless (isRight res) do
146+ unless (isRight res) do
172− Console.log $ " Foreign implementation missing."
147+ Console.log $ " Foreign implementation missing."
173− , onPrepareModule: \build coreFnMod@(Module { name }) -> do
148+ , onPrepareModule: \build coreFnMod@(Module { name }) -> do
174− let total = show build.moduleCount
149+ let total = show build.moduleCount
175− let index = show (build.moduleIndex + 1)
150+ let index = show (build.moduleIndex + 1)
176− let padding = power " " (SCU.length total - SCU.length index)
151+ let padding = power " " (SCU.length total - SCU.length index)
177− Console.log $ Array.fold
152+ Console.log $ Array.fold
178− [ "[", padding, index, " of ", total, "] purs-backend-chez: building ", unwrap name ]
153+ [ "[", padding, index, " of ", total, "] purs-backend-chez: building ", unwrap name ]
179− pure coreFnMod
154+ pure coreFnMod
180− , traceIdents: Set.empty
181− }
155+ }
182
156
183runBundle :: FilePath -> BundleArgs -> Aff Unit
157runBundle :: FilePath -> BundleArgs -> Aff Unit
184runBundle cliRoot args = do
158runBundle cliRoot args = do
@@ -235,42 +209,6 @@ getSchemeBinary = do
235 else do
209 else do
236 unsafeCrashWith "Could not find scheme binary"
210 unsafeCrashWith "Could not find scheme binary"
237
211
238−coreFnModulesFromOutput
239− :: String
240− -> NonEmptyArray String
241− -> Aff (Either (NonEmptyArray (Tuple FilePath String)) (List (Module Ann)))
242−coreFnModulesFromOutput path globs = runExceptT do
243− paths <- Set.toUnfoldable <$> lift
244− (expandGlobs path ((_ <> "/corefn.json") <$> NonEmptyArray.toArray globs))
245− case NonEmptyArray.toArray globs of
246− [ "**" ] ->
247− sortModules <$> modulesFromPaths paths
248− _ ->
249− go <<< foldl resumePull emptyPull =<< modulesFromPaths paths
250− where
251− modulesFromPaths paths = ExceptT do
252− { left, right } <- separate <$> parTraverse readCoreFnModule paths
253− pure $ maybe (Right right) Left $ NonEmptyArray.fromArray left
254−
255− pathFromModuleName (ModuleName mn) =
256− path <> "/" <> mn <> "/corefn.json"
257−
258− go pull = case pullResult pull of
259− Left needed ->
260− go <<< foldl resumePull pull =<< modulesFromPaths
261− (pathFromModuleName <$> NonEmptySet.toUnfoldable needed)
262− Right modules ->
263− pure $ Lazy.force modules
264−
265−readCoreFnModule :: String -> Aff (Either (Tuple FilePath String) (Module Ann))
266−readCoreFnModule filePath = do
267− contents <- FS.readTextFile UTF8 filePath
268− case lmap Json.printJsonDecodeError <<< decodeModule =<< Json.jsonParser contents of
269− Left err -> do
270− pure $ Left $ Tuple filePath err
271− Right mod ->
272− pure $ Right mod
273−
274mkdirp :: FilePath -> Aff Unit
212mkdirp :: FilePath -> Aff Unit
275mkdirp path = FS.mkdir' path { recursive: true, mode: mkPerms Perms.all Perms.all Perms.all }
213mkdirp path = FS.mkdir' path { recursive: true, mode: mkPerms Perms.all Perms.all Perms.all }
276
214
src/PureScript/Backend/Chez/Builder.pursnew file+95
@@ -0,0 +1,95 @@
1+module PureScript.Backend.Chez.Builder where
2+
3+import Prelude
4+
5+import Control.Monad.Cont.Trans (lift)
6+import Control.Monad.Except (ExceptT(..), runExceptT)
7+import Control.Parallel (parTraverse)
8+import Data.Argonaut as Json
9+import Data.Array.NonEmpty (NonEmptyArray)
10+import Data.Array.NonEmpty as NonEmptyArray
11+import Data.Bifunctor (lmap)
12+import Data.Compactable (separate)
13+import Data.Either (Either(..))
14+import Data.Foldable (foldl, for_)
15+import Data.Lazy as Lazy
16+import Data.List (List)
17+import Data.Maybe (maybe)
18+import Data.Set as Set
19+import Data.Set.NonEmpty as NonEmptySet
20+import Data.Tuple (Tuple(..))
21+import Effect.Aff (Aff)
22+import Effect.Class (liftEffect)
23+import Effect.Class.Console as Console
24+import Node.Encoding (Encoding(..))
25+import Node.FS.Aff as FS
26+import Node.Glob.Basic (expandGlobs)
27+import Node.Path (FilePath)
28+import Node.Process as Process
29+import PureScript.Backend.Optimizer.Builder (BuildEnv, buildModules)
30+import PureScript.Backend.Optimizer.Convert (BackendModule, OptimizationSteps)
31+import PureScript.Backend.Optimizer.CoreFn (Ann, Module, ModuleName(..))
32+import PureScript.Backend.Optimizer.CoreFn.Json (decodeModule)
33+import PureScript.Backend.Optimizer.CoreFn.Sort (emptyPull, pullResult, resumePull, sortModules)
34+import PureScript.Backend.Optimizer.Directives (parseDirectiveFile)
35+import PureScript.Backend.Optimizer.Directives.Defaults (defaultDirectives)
36+import PureScript.Backend.Optimizer.Semantics.Foreign (coreForeignSemantics)
37+
38+basicBuildMain
39+ :: { coreFnDirectory :: FilePath
40+ , coreFnGlobs :: NonEmptyArray String
41+ , onCodegenModule :: BuildEnv -> Module Ann -> BackendModule -> OptimizationSteps -> Aff Unit
42+ , onPrepareModule :: BuildEnv -> Module Ann -> Aff (Module Ann)
43+ }
44+ -> Aff Unit
45+basicBuildMain options = do
46+ coreFnModulesFromOutput options.coreFnDirectory options.coreFnGlobs >>= case _ of
47+ Left errors -> do
48+ for_ errors \(Tuple filePath err) -> do
49+ Console.error $ filePath <> " " <> err
50+ liftEffect $ Process.exit 1
51+ Right coreFnModules -> do
52+ let { directives } = parseDirectiveFile defaultDirectives
53+ coreFnModules # buildModules
54+ { directives
55+ , foreignSemantics: coreForeignSemantics
56+ , onCodegenModule: options.onCodegenModule
57+ , onPrepareModule: options.onPrepareModule
58+ , traceIdents: Set.empty
59+ }
60+
61+coreFnModulesFromOutput
62+ :: String
63+ -> NonEmptyArray String
64+ -> Aff (Either (NonEmptyArray (Tuple FilePath String)) (List (Module Ann)))
65+coreFnModulesFromOutput path globs = runExceptT do
66+ paths <- Set.toUnfoldable <$> lift
67+ (expandGlobs path ((_ <> "/corefn.json") <$> NonEmptyArray.toArray globs))
68+ case NonEmptyArray.toArray globs of
69+ [ "**" ] ->
70+ sortModules <$> modulesFromPaths paths
71+ _ ->
72+ go <<< foldl resumePull emptyPull =<< modulesFromPaths paths
73+ where
74+ modulesFromPaths paths = ExceptT do
75+ { left, right } <- separate <$> parTraverse readCoreFnModule paths
76+ pure $ maybe (Right right) Left $ NonEmptyArray.fromArray left
77+
78+ pathFromModuleName (ModuleName mn) =
79+ path <> "/" <> mn <> "/corefn.json"
80+
81+ go pull = case pullResult pull of
82+ Left needed ->
83+ go <<< foldl resumePull pull =<< modulesFromPaths
84+ (pathFromModuleName <$> NonEmptySet.toUnfoldable needed)
85+ Right modules ->
86+ pure $ Lazy.force modules
87+
88+readCoreFnModule :: String -> Aff (Either (Tuple FilePath String) (Module Ann))
89+readCoreFnModule filePath = do
90+ contents <- FS.readTextFile UTF8 filePath
91+ case lmap Json.printJsonDecodeError <<< decodeModule =<< Json.jsonParser contents of
92+ Left err -> do
93+ pure $ Left $ Tuple filePath err
94+ Right mod ->
95+ pure $ Right mod
test/Main.purs+82−95
@@ -15,7 +15,6 @@ import Data.Array (findMap)
15import Data.Array as Array
15import Data.Array as Array
16import Data.Array.NonEmpty (NonEmptyArray)
16import Data.Array.NonEmpty (NonEmptyArray)
17import Data.Either (Either(..), either, isRight)
17import Data.Either (Either(..), either, isRight)
18−import Data.Foldable (for_)
19import Data.Foldable as Foldable
18import Data.Foldable as Foldable
20import Data.Map as Map
19import Data.Map as Map
21import Data.Maybe (Maybe(..), fromMaybe, isJust)
20import Data.Maybe (Maybe(..), fromMaybe, isJust)
@@ -26,7 +25,6 @@ import Data.String (Pattern(..))
26import Data.String as String
25import Data.String as String
27import Data.String.CodeUnits as SCU
26import Data.String.CodeUnits as SCU
28import Data.TraversableWithIndex (forWithIndex)
27import Data.TraversableWithIndex (forWithIndex)
29−import Data.Tuple (Tuple(..))
30import Dodo (plainText)
28import Dodo (plainText)
31import Dodo as Dodo
29import Dodo as Dodo
32import Effect (Effect)
30import Effect (Effect)
@@ -41,17 +39,14 @@ import Node.Library.Execa.Which (defaultWhichOptions, which)
41import Node.Path as Path
39import Node.Path as Path
42import Node.Process as Process
40import Node.Process as Process
43import Partial.Unsafe (unsafeCrashWith)
41import Partial.Unsafe (unsafeCrashWith)
42+import PureScript.Backend.Chez.Builder (basicBuildMain)
44import PureScript.Backend.Chez.Constants (moduleForeign, moduleLib, schemeExt)
43import PureScript.Backend.Chez.Constants (moduleForeign, moduleLib, schemeExt)
45import PureScript.Backend.Chez.Convert (codegenModule)
44import PureScript.Backend.Chez.Convert (codegenModule)
46import PureScript.Backend.Chez.Printer as P
45import PureScript.Backend.Chez.Printer as P
47import PureScript.Backend.Chez.Runtime (runtimeModule)
46import PureScript.Backend.Chez.Runtime (runtimeModule)
48−import PureScript.Backend.Optimizer.Builder (buildModules)
49import PureScript.Backend.Optimizer.Convert (BackendModule)
47import PureScript.Backend.Optimizer.Convert (BackendModule)
50import PureScript.Backend.Optimizer.CoreFn (Comment(..), Module(..), ModuleName(..))
48import 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)
55
50
56type TestArgs =
51type TestArgs =
57 { accept :: Boolean
52 { accept :: Boolean
@@ -103,98 +98,90 @@ runSnapshotTests { accept, filter } = do
103 let runtimeFilePath = Path.concat [ runtimePath, moduleLib <> schemeExt ]
98 let runtimeFilePath = Path.concat [ runtimePath, moduleLib <> schemeExt ]
104 let runtimeContents = Dodo.print plainText Dodo.twoSpaces $ P.printLibrary $ runtimeModule
99 let runtimeContents = Dodo.print plainText Dodo.twoSpaces $ P.printLibrary $ runtimeModule
105 FS.writeTextFile UTF8 runtimeFilePath runtimeContents
100 FS.writeTextFile UTF8 runtimeFilePath runtimeContents
106− coreFnModulesFromOutput "output" filter >>= case _ of
101+ basicBuildMain
107− Left errors -> do
102+ { coreFnDirectory: "output"
108− for_ errors \(Tuple filePath err) -> do
103+ , coreFnGlobs: filter
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
104+ , 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
151 let
105 let
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
152− snapshotFilePath = Path.concat [ snapshotsOut, name <> schemeExt ]
139+ snapshotFilePath = Path.concat [ snapshotsOut, name <> schemeExt ]
153− runAcceptedTest = do
140+ runAcceptedTest = do
154− schemeFile <- liftEffect $ Path.resolve [ testOut, name ] $ moduleLib <> schemeExt
141+ schemeFile <- liftEffect $ Path.resolve [ testOut, name ] $ moduleLib <> schemeExt
155− result <- loadModuleMain
142+ result <- loadModuleMain
156− { libdir: vendorDirectory <> ":" <> testOut
143+ { libdir: vendorDirectory <> ":" <> testOut
157− , scheme: schemeBin
144+ , scheme: schemeBin
158− , hasMain
145+ , hasMain
159− , modulePath: schemeFile
146+ , modulePath: schemeFile
160− , moduleName: name
147+ , moduleName: name
161− }
148+ }
162− case result of
149+ case result of
163− Left { message }
150+ Left { message }
164− | matchesFail message failsWith ->
151+ | 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
152+ 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
189 | otherwise -> do
153 | otherwise -> do
190 Console.log $ withGraphics (foreground Red) "✗" <> " " <> name <> " failed."
154 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
195 pure false
156 pure false
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
196− unless (Foldable.and results) do
183+ unless (Foldable.and results) do
197− liftEffect $ Process.exit 1
184+ liftEffect $ Process.exit 1
198
185
199hasFails :: BackendModule -> Maybe String
186hasFails :: BackendModule -> Maybe String
200hasFails = findMap go <<< _.comments
187hasFails = findMap go <<< _.comments
test/Utils.purs−53
@@ -9,26 +9,13 @@ module Test.Utils where
9
9
10import Prelude
10import Prelude
11
11
12−import Control.Monad.Except (ExceptT(..), lift, runExceptT)
13−import Control.Parallel (parTraverse)
14−import Data.Argonaut as Json
15import Data.Array as Array
12import Data.Array as Array
16import Data.Array.NonEmpty as NonEmptyArray
13import Data.Array.NonEmpty as NonEmptyArray
17import Data.Array.NonEmpty.Internal (NonEmptyArray(..))
14import Data.Array.NonEmpty.Internal (NonEmptyArray(..))
18−import Data.Bifunctor (lmap)
19−import Data.Compactable (separate)
20import Data.Either (Either(..))
15import Data.Either (Either(..))
21−import Data.Foldable (foldl)
22−import Data.Lazy as Lazy
23−import Data.List (List)
24−import Data.Maybe (maybe)
25import Data.Posix.Signal (Signal(..))
16import Data.Posix.Signal (Signal(..))
26−import Data.Set as Set
27−import Data.Set.NonEmpty as NonEmptySet
28−import Data.Tuple (Tuple(..))
29import Effect.Aff (Aff, effectCanceler, error, makeAff, throwError)
17import Effect.Aff (Aff, effectCanceler, error, makeAff, throwError)
30import Effect.Class (liftEffect)
18import Effect.Class (liftEffect)
31−import Effect.Class.Console as Console
32import Node.Buffer (Buffer, freeze)
19import Node.Buffer (Buffer, freeze)
33import Node.Buffer.Immutable as ImmutableBuffer
20import Node.Buffer.Immutable as ImmutableBuffer
34import Node.ChildProcess (ExecResult, Exit(..), defaultExecOptions, defaultSpawnOptions, inherit)
21import Node.ChildProcess (ExecResult, Exit(..), defaultExecOptions, defaultSpawnOptions, inherit)
@@ -39,14 +26,10 @@ import Node.FS.Perms (mkPerms)
39import Node.FS.Perms as Perms
26import Node.FS.Perms as Perms
40import Node.FS.Stats as Stats
27import Node.FS.Stats as Stats
41import Node.FS.Stream (createReadStream, createWriteStream)
28import Node.FS.Stream (createReadStream, createWriteStream)
42−import Node.Glob.Basic (expandGlobs)
43import Node.Library.Execa (ExecaError, ExecaSuccess, execa)
29import Node.Library.Execa (ExecaError, ExecaSuccess, execa)
44import Node.Path (FilePath)
30import Node.Path (FilePath)
45import Node.Process as Process
31import Node.Process as Process
46import Node.Stream as Stream
32import Node.Stream as Stream
47−import PureScript.Backend.Optimizer.CoreFn (Ann, Module, ModuleName(..))
48−import PureScript.Backend.Optimizer.CoreFn.Json (decodeModule)
49−import PureScript.Backend.Optimizer.CoreFn.Sort (emptyPull, pullResult, resumePull, sortModules)
50import PureScript.CST (RecoveredParserResult(..), parseModule)
33import PureScript.CST (RecoveredParserResult(..), parseModule)
51import PureScript.CST.Errors (printParseError)
34import PureScript.CST.Errors (printParseError)
52import PureScript.CST.Types as CSTT
35import PureScript.CST.Types as CSTT
@@ -119,42 +102,6 @@ copyFile from to = do
119 Stream.destroy dst
102 Stream.destroy dst
120 Stream.destroy src
103 Stream.destroy src
121
104
122−coreFnModulesFromOutput
123− :: String
124− -> NonEmptyArray String
125− -> Aff (Either (NonEmptyArray (Tuple FilePath String)) (List (Module Ann)))
126−coreFnModulesFromOutput path globs = runExceptT do
127− paths <- Set.toUnfoldable <$> lift
128− (expandGlobs path ((_ <> "/corefn.json") <$> NonEmptyArray.toArray globs))
129− case NonEmptyArray.toArray globs of
130− [ "**" ] ->
131− sortModules <$> modulesFromPaths paths
132− _ ->
133− go <<< foldl resumePull emptyPull =<< modulesFromPaths paths
134− where
135− modulesFromPaths paths = ExceptT do
136− { left, right } <- separate <$> parTraverse readCoreFnModule paths
137− pure $ maybe (Right right) Left $ NonEmptyArray.fromArray left
138−
139− pathFromModuleName (ModuleName mn) =
140− path <> "/" <> mn <> "/corefn.json"
141−
142− go pull = case pullResult pull of
143− Left needed ->
144− go <<< foldl resumePull pull =<< modulesFromPaths
145− (pathFromModuleName <$> NonEmptySet.toUnfoldable needed)
146− Right modules ->
147− pure $ Lazy.force modules
148−
149−readCoreFnModule :: String -> Aff (Either (Tuple FilePath String) (Module Ann))
150−readCoreFnModule filePath = do
151− contents <- FS.readTextFile UTF8 filePath
152− case lmap Json.printJsonDecodeError <<< decodeModule =<< Json.jsonParser contents of
153− Left err -> do
154− pure $ Left $ Tuple filePath err
155− Right mod ->
156− pure $ Right mod
157−
158-- | Returns `Right true` if the source code has this type signature
105-- | Returns `Right true` if the source code has this type signature
159-- | somewhere in it:
106-- | somewhere in it:
160-- | ```
107-- | ```