@@ -2,12 +2,293 @@ module Main where
22
33import Prelude
44
5+import ArgParse.Basic (ArgParser)
6+import ArgParse.Basic as ArgParser
7+import Control.Monad.Except (ExceptT(..), lift, runExceptT)
8+import Control.Parallel (parTraverse)
9+import Data.Argonaut as Json
10+import 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)
15+import 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)
20+import Data.Monoid (power)
21+import Data.Newtype (unwrap)
22+import Data.Set as Set
23+import Data.Set.NonEmpty as NonEmptySet
24+import Data.String (Pattern(..))
25+import Data.String as String
26+import Data.String.CodeUnits as SCU
27+import Data.Tuple (Tuple(..))
28+import Dodo (plainText)
29+import Dodo as Dodo
530import Effect (Effect)
6−import Effect.Aff (launchAff_)
31+import Effect.Aff (Aff, attempt, effectCanceler, error, launchAff_, makeAff, throwError)
732import Effect.Class (liftEffect)
8−import Effect.Console (log)
33+import Effect.Class.Console as Console
34+import Node.Encoding (Encoding(..))
35+import Node.FS.Aff as FS
36+import Node.FS.Perms (mkPerms)
37+import Node.FS.Perms as Perms
38+import Node.FS.Stats as Stats
39+import Node.FS.Stream (createReadStream, createWriteStream)
40+import Node.Glob.Basic (expandGlobs)
41+import Node.Library.Execa (ExecaError, ExecaSuccess, execa)
42+import Node.Library.Execa.Which (defaultWhichOptions, which)
43+import Node.Path (FilePath)
44+import Node.Path as Path
45+import Node.Process as Process
46+import Node.Stream as Stream
47+import Partial.Unsafe (unsafeCrashWith)
48+import PureScript.Backend.Chez.Constants (moduleForeign, moduleLib, schemeExt)
49+import PureScript.Backend.Chez.Convert (codegenModule)
50+import PureScript.Backend.Chez.Printer as Printer
51+import PureScript.Backend.Chez.Runtime (runtimeModule)
52+import PureScript.Backend.Optimizer.Builder (buildModules)
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+
60+type BuildArgs =
61+ { coreFnDir :: FilePath
62+ , outputDir :: FilePath
63+ }
64+
65+type BundleArgs =
66+ { moduleName :: String
67+ , libDir :: FilePath
68+ , outputDir :: FilePath
69+ }
70+
71+data Command
72+ = Build BuildArgs
73+ | Bundle BundleArgs
74+
75+cliArgParser :: ArgParser Command
76+cliArgParser =
77+ ArgParser.choose "command"
78+ [ ArgParser.command [ "build" ]
79+ "Builds Chez scheme code from corefn.json files"
80+ do
81+ Build <$> buildArgsParser <* ArgParser.flagHelp
82+ , ArgParser.command [ "bundle-app" ]
83+ "Bundles .so files to a single program file."
84+ do Bundle <$> bundleArgsParser <* ArgParser.flagHelp
85+ ]
86+ <* ArgParser.flagHelp
87+
88+buildArgsParser :: ArgParser BuildArgs
89+buildArgsParser =
90+ ArgParser.fromRecord
91+ { coreFnDir:
92+ ArgParser.argument [ "--corefn-dir" ]
93+ "Path to input directory containing corefn.json files.\n\
94+ \Defaults to './output'."
95+ # ArgParser.default (Path.concat [ ".", "output" ])
96+ , outputDir:
97+ ArgParser.argument [ "--output-dir" ]
98+ "Path to output directory for backend files.\n\
99+ \Defaults to './output'."
100+ # ArgParser.default (Path.concat [ ".", "output" ])
101+ }
102+
103+bundleArgsParser :: ArgParser BundleArgs
104+bundleArgsParser =
105+ ArgParser.fromRecord
106+ { moduleName:
107+ ArgParser.argument [ "--main" ]
108+ "Module to be used as the application's entry point.\n\
109+ \Defaults to 'Main'."
110+ # ArgParser.default "Main"
111+ , libDir:
112+ ArgParser.argument [ "--libdir" ]
113+ "Path to scheme source files.\n\
114+ \Defaults to './output'."
115+ # ArgParser.default (Path.concat [ ".", "output" ])
116+ , outputDir:
117+ ArgParser.argument [ "--output-dir" ]
118+ "Path to output directory for backend files.\n\
119+ \Defaults to './output'."
120+ # ArgParser.default (Path.concat [ ".", "output" ])
121+ }
122+
123+main :: FilePath -> Effect Unit
124+main cliRoot = do
125+ cliArgs <- Array.drop 2 <$> Process.argv
126+ case
127+ ArgParser.parseArgs "purs-backend-chez" "Chez Scheme backend for PureScript" cliArgParser
128+ cliArgs
129+ of
130+ Left err ->
131+ Console.error $ ArgParser.printArgError err
132+ Right (Build args) ->
133+ launchAff_ $ runBuild args
134+ Right (Bundle arg) ->
135+ launchAff_ $ runBundle cliRoot arg
136+
137+runBuild :: BuildArgs -> Aff Unit
138+runBuild args = do
139+ let runtimePath = Path.concat [ args.outputDir, "purs", "runtime" ]
140+ mkdirp runtimePath
141+ let runtimeFilePath = Path.concat [ runtimePath, moduleLib <> schemeExt ]
142+ let runtimeContents = Dodo.print plainText Dodo.twoSpaces $ Printer.printLibrary $ runtimeModule
143+ FS.writeTextFile UTF8 runtimeFilePath runtimeContents
144+ coreFnModulesFromOutput args.coreFnDir (pure "**") >>= case _ of
145+ Left errors -> do
146+ for_ errors \(Tuple filePath err) -> do
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
155+ let
156+ formatted =
157+ Dodo.print plainText Dodo.twoSpaces
158+ $ Printer.printLibrary
159+ $ codegenModule backend
160+ let modPath = Path.concat [ args.outputDir, name ]
161+ mkdirp modPath
162+ let libPath = Path.concat [ modPath, moduleLib <> schemeExt ]
163+ FS.writeTextFile UTF8 libPath formatted
164+ unless (Set.isEmpty backend.foreign) do
165+ let
166+ foreignSiblingPath =
167+ fromMaybe path (String.stripSuffix (Pattern (Path.extname path)) path) <>
168+ schemeExt
169+ let foreignOutputPath = Path.concat [ modPath, moduleForeign <> schemeExt ]
170+ res <- attempt $ copyFile foreignSiblingPath foreignOutputPath
171+ unless (isRight res) do
172+ Console.log $ " Foreign implementation missing."
173+ , onPrepareModule: \build coreFnMod@(Module { name }) -> do
174+ let total = show build.moduleCount
175+ let index = show (build.moduleIndex + 1)
176+ let padding = power " " (SCU.length total - SCU.length index)
177+ Console.log $ Array.fold
178+ [ "[", padding, index, " of ", total, "] purs-backend-chez: building ", unwrap name ]
179+ pure coreFnMod
180+ , traceIdents: Set.empty
181+ }
182+
183+runBundle :: FilePath -> BundleArgs -> Aff Unit
184+runBundle cliRoot args = do
185+ let outPath = Path.concat [ args.outputDir, "main" ]
186+ let mainPath = Path.concat [ args.outputDir, "main.ss" ]
187+ let mainWpoPath = Path.concat [ args.outputDir, "main.wpo" ]
188+ mkdirp args.outputDir
189+ let
190+ mainContent = Array.fold
191+ [ "(import (" <> args.moduleName <> " lib))"
192+ , "(main)"
193+ ]
194+ FS.writeTextFile UTF8 mainPath mainContent
195+ let
196+ runtimePath = Path.concat [ cliRoot, "vendor" ]
197+ runtimeLibPathPair = runtimePath <> "::" <> (Path.concat [ args.outputDir ])
198+ libDirPathPair = args.libDir <> "::" <> args.outputDir
199+ libDirs = runtimeLibPathPair <> ":" <> libDirPathPair <> ":"
200+ arguments = [ "-q", "--libdirs", libDirs ]
201+ res <- evalScheme arguments $ Array.fold
202+ [ "(top-level-program (import (chezscheme))"
203+ , " (with-exception-handler (lambda (e) (display-condition e (console-error-port)) (newline (console-error-port)) (exit -1))"
204+ , " (lambda ()"
205+ , " (optimize-level 3)"
206+ , " (compile-file-message #f)"
207+ , " (compile-imported-libraries #t)"
208+ , " (generate-wpo-files #t)"
209+ , " (compile-program \"" <> mainPath <> "\")"
210+ , " (compile-whole-program \"" <> mainWpoPath <> "\" \"" <> outPath <> "\")"
211+ , ")))"
212+ ]
213+ case res of
214+ Left err -> liftEffect $ Process.exit (fromMaybe 1 err.exitCode)
215+ Right _ -> Console.log $ "Created " <> outPath
216+
217+evalScheme :: Array String -> String -> Aff (Either ExecaError ExecaSuccess)
218+evalScheme arguments code = do
219+ schemeBin <- getSchemeBinary
220+ spawned <- execa schemeBin arguments identity
221+ spawned.stdin.writeUtf8End code
222+ void $ liftEffect $ Stream.pipe spawned.stdout.stream Process.stdout
223+ void $ liftEffect $ Stream.pipe spawned.stderr.stream Process.stderr
224+ spawned.result
225+
226+getSchemeBinary :: Aff String
227+getSchemeBinary = do
228+ useScheme <- isRight <$> which "scheme" defaultWhichOptions
229+ if useScheme then do
230+ pure "scheme"
231+ else do
232+ useChez <- isRight <$> which "chez" defaultWhichOptions
233+ if useChez then
234+ pure "chez"
235+ else do
236+ unsafeCrashWith "Could not find scheme binary"
237+
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+
274+mkdirp :: FilePath -> Aff Unit
275+mkdirp path = FS.mkdir' path { recursive: true, mode: mkPerms Perms.all Perms.all Perms.all }
276+
277+copyFile :: FilePath -> FilePath -> Aff Unit
278+copyFile from to = do
279+ stats <- FS.stat from
280+ unless (Stats.isFile stats) do
281+ throwError $ error $ "Not a file: " <> from
282+ makeAff \k -> do
283+ src <- createReadStream from
284+ dst <- createWriteStream to
285+ res <- Stream.pipe src dst
286+ Stream.onError src (k <<< Left)
287+ Stream.onError dst (k <<< Left)
288+ Stream.onError res (k <<< Left)
289+ Stream.onFinish res (k (Right unit))
290+ pure $ effectCanceler do
291+ Stream.destroy res
292+ Stream.destroy dst
293+ Stream.destroy src
9294
10−main :: Effect Unit
11−main = launchAff_ do
12− liftEffect $ log "Not yet implemented. See tests."
13− pure unit