git.iko.soy/rowtype-yoga/purescm
on bytevector help sign in
rowtype-yoga/purescm/test/Utils.purs
155 lines 5.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/Utils.purs
3-- https://github.com/aristanetworks/purescript-backend-optimizer/blob/main/backend-es/src/Main.purs
4--
5-- To fullfill copyright requirements...
6-- Copyright © 2022 Arista Networks, Inc.
7-- MIT license: https://opensource.org/license/mit/
8module Test.Utils where
10import Prelude
12import Data.Array as Array
13import Data.Array.NonEmpty as NonEmptyArray
14import Data.Array.NonEmpty.Internal (NonEmptyArray(..))
15import Data.Either (Either(..))
16import Data.Maybe (Maybe(..))
17import Effect.Aff (Aff, effectCanceler, error, makeAff, message, throwError)
18import Effect.Class (liftEffect)
19import Foreign.Object as Object
20import Node.EventEmitter (on_)
21import Node.FS.Aff as FS
22import Node.FS.Perms as Perms
23import Node.FS.Stats as Stats
24import Node.FS.Stream (createReadStream, createWriteStream)
25import Node.Library.Execa (ExecaResult, execa)
26import Node.Path (FilePath)
27import Node.Process as Process
28import Node.Stream as Stream
29import PureScript.CST (RecoveredParserResult(..), parseModule)
30import PureScript.CST.Errors (printParseError)
31import PureScript.CST.Types as CSTT
33spawnFromParent :: String -> Array String -> Aff Unit
34spawnFromParent command args = do
35 spawned <- execa command args identity
36 spawned.stdout.pipeToParentStdout
37 spawned.stderr.pipeToParentStderr
38 result <- spawned.getResult
39 unless (result.exitCode == Just 0) do
40 liftEffect $ Process.exit' 1
42execWithStdin :: String -> Array String -> String -> Aff ExecaResult
43execWithStdin command args input = do
44 spawned <- execa command args identity
45 spawned.stdin.writeUtf8End input
46 spawned.getResult
48mkdirp :: FilePath -> Aff Unit
49mkdirp path = FS.mkdir' path { recursive: true, mode: Perms.permsAll }
51loadModuleMain
52 :: { libdir :: FilePath
53 , scheme :: String
54 , hasMain :: Boolean
55 , moduleName :: String
56 , modulePath :: String
57 }
58 -> Aff ExecaResult
59loadModuleMain options = do
60 let
61 arguments :: Array String
62 arguments = [ "-q", "--libdirs", options.libdir <> ":" ] <>
63 if not options.hasMain then
64 [ "--script", options.modulePath ]
65 else
66 []
68 -- Apple blocks DYLD environment variables, so loading libraries with DYLD_LIBRARY_PATH
69 -- will not work across process spawns. We go around this by carrying the library path
70 -- in CHEZ_DYLD_LIBRARY_PATH and setting DYLD_LIBRARY_PATH when spawning. For more info see:
71 -- https://developer.apple.com/library/archive/documentation/Security/Conceptual/System_Integrity_Protection_Guide/RuntimeProtections/RuntimeProtections.html
72 env <- liftEffect $ Process.getEnv
73 case Object.lookup "CHEZ_DYLD_LIBRARY_PATH" env of
74 Just dyldPath -> do
75 liftEffect $ Process.setEnv "DYLD_LIBRARY_PATH" dyldPath
76 _ -> pure unit
78 spawned <- execa options.scheme arguments (_ { extendEnv = Just true })
79 when options.hasMain do
80 spawned.stdin.writeUtf8End $ Array.fold
81 [ "(base-exception-handler (lambda (e) (display-condition e (console-error-port)) (newline (console-error-port)) (exit -1)))"
82 , "(top-level-program (import (only (chezscheme) base-exception-handler exit lambda)"
83 , " (" <> options.moduleName <> " lib)"
84 , " (only (purescm stack-trace) print-stack-trace))"
85 , " (base-exception-handler (lambda (e) (print-stack-trace e) (exit -1)))"
86 , " (main))"
87 ]
88 spawned.stdout.pipeToParentStdout
89 spawned.stderr.pipeToParentStderr
90 spawned.getResult
92copyFile :: FilePath -> FilePath -> Aff Unit
93copyFile from to = do
94 stats <- FS.stat from
95 unless (Stats.isFile stats) do
96 throwError $ error $ "Not a file: " <> from
97 makeAff \k -> do
98 src <- createReadStream from
99 dst <- createWriteStream to
100 src # on_ Stream.errorH \err -> do
101 Stream.destroy' dst $ error $ "Got error in src stream: " <> message err
102 k $ Left err
103 dst # on_ Stream.errorH (k <<< Left)
104 dst # on_ Stream.finishH (k (Right unit))
105 Stream.pipe src dst
106 pure $ effectCanceler do
107 Stream.destroy dst
108 Stream.destroy src
110-- | Returns `Right true` if the source code has this type signature
111-- | somewhere in it:
112-- | ```
113-- | main :: Effect Unit
114-- | ```
115-- |
116-- | If `Effect` or `Unit` are qualified by a module alias,
117-- | this will not return `true`.
118-- | ```
119-- | main :: Effect.Effect Prelude.Unit
120-- | ```
121canRunMain :: String -> Either String Boolean
122canRunMain sourceCode =
123 case parseModule sourceCode of
124 ParseSucceeded (CSTT.Module { body: CSTT.ModuleBody { decls } }) ->
125 pure $ Array.any isMain decls
126 ParseSucceededWithErrors _ errs ->
127 Left $ Array.intercalate "\n"
128 [ "canRunMain - could not completely parse file."
129 , Array.intercalate "\n" $ map printPositionedError $ NonEmptyArray.toArray errs
130 ]
131 ParseFailed err ->
132 Left $ Array.intercalate "\n"
133 [ "canRunMain - could not parse file."
134 , printPositionedError err
135 ]
136 where
137 printPositionedError err = Array.intercalate "\n"
138 [ ""
139 , "Position: " <> show err.position
140 , "Reason: " <> printParseError err.error
141 ]
142 isMain = case _ of
143 CSTT.DeclSignature
144 ( CSTT.Labeled
145 { label: CSTT.Name { name: CSTT.Ident "main" }
146 , value:
147 CSTT.TypeApp
148 (CSTT.TypeConstructor (CSTT.QualifiedName { name: CSTT.Proper "Effect" }))
149 ( NonEmptyArray
150 [ CSTT.TypeConstructor (CSTT.QualifiedName { name: CSTT.Proper "Unit" })
151 ]
152 )
153 }
154 ) -> true
155 _ -> false