git.iko.soy/rowtype-yoga/purescm
on inline-st help sign in
rowtype-yoga/purescm/src/Main.purs
296 lines 11 kB history raw
1module Main where
3import Prelude
5import ArgParse.Basic (ArgParser)
6import ArgParse.Basic as ArgParser
7import Data.Array as Array
8import Data.Either (Either(..), isRight)
9import Data.Maybe (Maybe(..), fromMaybe)
10import Data.Monoid (power)
11import Data.Newtype (unwrap)
12import Data.Set as Set
13import Data.String (Pattern(..))
14import Data.String as String
15import Data.String.CodeUnits as SCU
16import Dodo (plainText)
17import Dodo as Dodo
18import Effect (Effect)
19import Effect.Aff (Aff, attempt, effectCanceler, error, launchAff_, makeAff, runAff_, throwError)
20import Effect.Class (liftEffect)
21import Effect.Class.Console as Console
22import Effect.Exception (message)
23import Node.Encoding (Encoding(..))
24import Node.EventEmitter (on_)
25import Node.FS.Aff as FS
26import Node.FS.Perms (mkPerms)
27import Node.FS.Perms as Perms
28import Node.FS.Stats as Stats
29import Node.FS.Stream (createReadStream, createWriteStream)
30import Node.Library.Execa (ExecaResult, execa)
31import Node.Library.Execa.Which (defaultWhichOptions, which)
32import Node.Path (FilePath)
33import Node.Path as Path
34import Node.Process as Process
35import Node.Stream as Stream
36import Partial.Unsafe (unsafeCrashWith)
37import PureScript.Backend.Chez.Builder (basicBuildMain)
38import PureScript.Backend.Chez.Constants (moduleForeign, moduleLib, schemeExt)
39import PureScript.Backend.Chez.Convert (codegenModule)
40import PureScript.Backend.Chez.Printer as Printer
41import PureScript.Backend.Optimizer.CoreFn (Module(..), ModuleName(..))
42import Spago.Generated.BuildInfo as BuildInfo
44type BuildArgs =
45 { coreFnDir :: FilePath
46 , outputDir :: FilePath
47 , directivesFile :: Maybe FilePath
48 }
50type BundleArgs =
51 { moduleName :: String
52 , libDir :: FilePath
53 , outputDir :: FilePath
54 }
56type RunArgs =
57 { moduleName :: String
58 , libDir :: FilePath
59 }
61data Command
62 = Build BuildArgs
63 | Bundle BundleArgs
64 | Run RunArgs
66cliArgParser :: ArgParser Command
67cliArgParser =
68 ArgParser.choose "command"
69 [ ArgParser.command [ "build" ]
70 "Builds Chez scheme code from corefn.json files"
71 do
72 Build <$> buildCmdArgParser <* ArgParser.flagHelp
73 , ArgParser.command [ "bundle-app" ]
74 "Bundles .so files to a single program file."
75 do Bundle <$> bundleCmdArgParser <* ArgParser.flagHelp
76 , ArgParser.command [ "run" ]
77 "Runs a compiled scheme program by invoking\n\
78 \the main function using the Chez interpreter."
79 do Run <$> runCmdArgParser <* ArgParser.flagHelp
80 ]
81 <* ArgParser.flagHelp
82 <* ArgParser.flagInfo [ "--version", "-v" ] "Show the current version of purescm."
83 BuildInfo.packages.purescm
85buildCmdArgParser :: ArgParser BuildArgs
86buildCmdArgParser =
87 ArgParser.fromRecord
88 { coreFnDir:
89 ArgParser.argument [ "--corefn-dir" ]
90 "Path to input directory containing corefn.json files.\n\
91 \Defaults to './output'."
92 # ArgParser.default (Path.concat [ ".", "output" ])
93 , outputDir:
94 ArgParser.argument [ "--output" ]
95 "Path to output directory for backend files.\n\
96 \Defaults to './output'."
97 # ArgParser.default (Path.concat [ ".", "output" ])
98 , directivesFile:
99 ArgParser.argument [ "--directives" ]
100 "Path to file that defines external inline directives (optional)."
101 # ArgParser.optional
102 }
104bundleCmdArgParser :: ArgParser BundleArgs
105bundleCmdArgParser =
106 ArgParser.fromRecord
107 { moduleName:
108 ArgParser.argument [ "--main" ]
109 "Module to be used as the application's entry point.\n\
110 \Defaults to 'Main'."
111 # ArgParser.default "Main"
112 , libDir:
113 ArgParser.argument [ "--libdir" ]
114 "Path to scheme source files.\n\
115 \Defaults to './output'."
116 # ArgParser.default (Path.concat [ ".", "output" ])
117 , outputDir:
118 ArgParser.argument [ "--output" ]
119 "Path to output directory for backend files.\n\
120 \Defaults to './output'."
121 # ArgParser.default (Path.concat [ ".", "output" ])
122 }
124runCmdArgParser :: ArgParser RunArgs
125runCmdArgParser =
126 ArgParser.fromRecord
127 { moduleName:
128 ArgParser.argument [ "--main" ]
129 "Module to be used as the application's entry point.\n\
130 \Defaults to 'Main'."
131 # ArgParser.default "Main"
132 , libDir:
133 ArgParser.argument [ "--libdir" ]
134 "Path to scheme source files.\n\
135 \Defaults to './output'."
136 # ArgParser.default (Path.concat [ ".", "output" ])
137 }
139main :: FilePath -> Effect Unit
140main cliRoot = do
141 cliArgs <- Array.drop 2 <$> Process.argv
142 case
143 ArgParser.parseArgs "purescm" "Chez Scheme backend for PureScript" cliArgParser
144 cliArgs
145 of
146 Left err ->
147 Console.error $ ArgParser.printArgError err
148 Right (Build args) ->
149 flip runAff_ (runBuild args) case _ of
150 Right _ -> pure unit
151 Left err -> do
152 Console.error (message err)
153 Process.exit' 1
154 Right (Bundle arg) ->
155 launchAff_ $ runBundle cliRoot arg
156 Right (Run arg) ->
157 launchAff_ $ runRun cliRoot arg
159runBuild :: BuildArgs -> Aff Unit
160runBuild args = do
161 let runtimePath = Path.concat [ args.outputDir, "purs", "runtime" ]
162 mkdirp runtimePath
163 basicBuildMain
164 { coreFnDirectory: args.coreFnDir
165 , coreFnGlobs: pure "**"
166 , externalDirectivesFile: args.directivesFile
167 , onCodegenModule: \_ (Module { name: ModuleName name, path }) backend _ -> do
168 let
169 formatted =
170 Dodo.print plainText Dodo.twoSpaces
171 $ Printer.printLibrary
172 $ codegenModule backend
173 let modPath = Path.concat [ args.outputDir, name ]
174 mkdirp modPath
175 let libPath = Path.concat [ modPath, moduleLib <> schemeExt ]
176 FS.writeTextFile UTF8 libPath formatted
177 unless (Set.isEmpty backend.foreign) do
178 let
179 foreignSiblingPath =
180 fromMaybe path (String.stripSuffix (Pattern (Path.extname path)) path) <>
181 schemeExt
182 let foreignOutputPath = Path.concat [ modPath, moduleForeign <> schemeExt ]
183 res <- attempt $ copyFile foreignSiblingPath foreignOutputPath
184 unless (isRight res) do
185 Console.log $ " Foreign implementation missing."
186 , onPrepareModule: \build coreFnMod@(Module { name }) -> do
187 let total = show build.moduleCount
188 let index = show (build.moduleIndex + 1)
189 let padding = power " " (SCU.length total - SCU.length index)
190 Console.log $ Array.fold
191 [ "[", padding, index, " of ", total, "] purescm: building ", unwrap name ]
192 pure coreFnMod
193 }
195runBundle :: FilePath -> BundleArgs -> Aff Unit
196runBundle cliRoot args = do
197 let outPath = Path.concat [ args.outputDir, "main" ]
198 let mainPath = Path.concat [ args.outputDir, "main.ss" ]
199 let mainWpoPath = Path.concat [ args.outputDir, "main.wpo" ]
200 mkdirp args.outputDir
201 let
202 mainContent = String.joinWith "\n"
203 [ "#!chezscheme"
204 , "(import (chezscheme)"
205 , " (only (purs runtime finalizers) run-finalizers)"
206 , " (only (" <> args.moduleName <> " lib) main))"
207 , "(collect-request-handler (lambda () (collect) (run-finalizers)))"
208 , "(main)"
209 ]
210 FS.writeTextFile UTF8 mainPath mainContent
211 let
212 runtimePath = Path.concat [ cliRoot, "vendor" ]
213 runtimeLibPathPair = runtimePath <> "::" <> (Path.concat [ args.outputDir ])
214 libDirPathPair = args.libDir <> "::" <> args.outputDir
215 libDirs = runtimeLibPathPair <> ":" <> libDirPathPair <> ":"
216 arguments = [ "-q", "--libdirs", libDirs ]
217 res <- evalScheme arguments $ Array.fold
218 [ "(top-level-program (import (chezscheme))"
219 -- Catch compilation errors so that we exit with an error code
220 , " (with-exception-handler (lambda (e) (display-condition e (console-error-port)) (newline (console-error-port)) (exit -1))"
221 , " (lambda ()"
222 , " (compile-profile #f)"
223 , " (optimize-level 3)"
224 , " (compile-file-message #f)"
225 , " (compile-imported-libraries #t)"
226 , " (generate-wpo-files #t)"
227 , " (compile-program \"" <> mainPath <> "\")"
228 , " (compile-whole-program \"" <> mainWpoPath <> "\" \"" <> outPath <> "\"))))"
229 ]
230 case res.exitCode of
231 Just 0 -> Console.log $ "Created " <> outPath
232 _ -> liftEffect $ Process.exit' (fromMaybe 1 res.exitCode)
234runRun :: FilePath -> RunArgs -> Aff Unit
235runRun cliRoot args = do
236 let
237 runtimePath = Path.concat [ cliRoot, "vendor" ]
238 libDirs = runtimePath <> ":" <> args.libDir <> ":"
239 arguments = [ "-q", "--libdirs", libDirs ]
240 res <- evalScheme arguments $ Array.fold
241 -- Catch errors so that we exit with an error code
242 [ "(base-exception-handler (lambda (e)"
243 , " (display-condition e (console-error-port))"
244 , " (newline (console-error-port))"
245 , " (exit -1)))"
246 , "(top-level-program (import (chezscheme)"
247 , " (only (purs runtime finalizers) run-finalizers)"
248 , " (only (" <> args.moduleName <> " lib) main))"
249 , " (collect-request-handler (lambda () (collect) (run-finalizers)))"
250 , " (main))"
251 ]
252 case res.exitCode of
253 Just 0 -> pure unit
254 _ -> liftEffect $ Process.setExitCode (fromMaybe 1 res.exitCode)
256evalScheme :: Array String -> String -> Aff ExecaResult
257evalScheme arguments code = do
258 schemeBin <- getSchemeBinary
259 spawned <- execa schemeBin arguments identity
260 spawned.stdin.writeUtf8End code
261 spawned.stdout.pipeToParentStdout
262 spawned.stderr.pipeToParentStderr
263 spawned.getResult
265getSchemeBinary :: Aff String
266getSchemeBinary = do
267 useScheme <- isRight <$> which "scheme" defaultWhichOptions
268 if useScheme then do
269 pure "scheme"
270 else do
271 useChez <- isRight <$> which "chez" defaultWhichOptions
272 if useChez then
273 pure "chez"
274 else do
275 unsafeCrashWith "Could not find scheme binary"
277mkdirp :: FilePath -> Aff Unit
278mkdirp path = FS.mkdir' path { recursive: true, mode: mkPerms Perms.all Perms.all Perms.all }
280copyFile :: FilePath -> FilePath -> Aff Unit
281copyFile from to = do
282 stats <- FS.stat from
283 unless (Stats.isFile stats) do
284 throwError $ error $ "Not a file: " <> from
285 makeAff \k -> do
286 src <- createReadStream from
287 dst <- createWriteStream to
288 src # on_ Stream.errorH \err -> do
289 Stream.destroy' dst $ error $ "Got error in src stream: " <> message err
290 k $ Left err
291 dst # on_ Stream.errorH (k <<< Left)
292 dst # on_ Stream.finishH (k (Right unit))
293 Stream.pipe src dst
294 pure $ effectCanceler do
295 Stream.destroy dst
296 Stream.destroy src