0cd4f99...golang · rowtype-yoga/purescript-native

.gitignore+2−2

since splitsnapshots

unifiedsplit

@@ -12,12 +12,12 @@ cabal.sandbox.config

12.test_modules/

13bower_components/

14node_modules

15−pscpp.cabal

16−psgo.cabal

17tmp/

15tmp/

18.stack-work/

16.stack-work/

17+stack.yaml.lock

19output

18output

20examples/docs/docs/

19examples/docs/docs/

21core-tests/full-core-docs.md

20core-tests/full-core-docs.md

22.psc-ide-port

21.psc-ide-port

23.vscode/

22.vscode/

23+result

README-go.mdnew file+48

@@ -0,0 +1,48 @@

1+

2+### psgo

3+

4+#### Performance

5+

6+* No runtime system beyond some support types and functions

7+* Uses PureScript's normal tail call optimization techniques for generated Go code

8+

9+#### Differences from PureScript:

10+

11+* Foreign imports/exports are Go instead of JavaScript – see [standard library foreign implementations](https://github.com/andyarvanitis/purescript-native-go-ffi)

12+* No Go-specific REPL

13+

14+#### Other notes:

15+

16+* The provided `Any` type is just an alias for `interface{}`

17+* PureScript types are represented in Go with:

18+

19+ | PureScript | Go |

20+ |------------|----|

21+ |`Array` | `[]Any`|

22+ |`String` | `string`|

23+ |`Number` | `float64`|

24+ |`Int` | `int`|

25+ |`Char` | `string` (single UTF-8 entity)|

26+ |`Boolean` | `bool`|

27+ |Records | `map[string]Any`|

28+

29+#### Future ideas:

30+

31+* Nice facilities (modules) for concurrency/parallelism, using goroutines

32+

33+

34+#### Getting Started

35+This assumes you are running macOS (OS X) or a Unix-like system (Linux, *BSD, etc.).

36+

37+1. Choose a working directory wherever you like. Then create a `src` subdirectory under it, which will be where you will place your own PureScript source files.

38+

39+1. Initialize your project with `spago init`, and install any dependencies with `spago install` (please see their instructions if you haven't used it before).

40+

41+1. Add the `backend = "psgo"` option to your `spago.dhall` file. That way `spago` will use the psgo backend when compiling.

42+

43+1. You should now be ready to build a PureScript program:

44+ * As stated above, place your source file(s) in the working directory's `src` subdirectory and execute `spago build`.

45+

46+ * This will generate the Go source tree for your program and then build an executable binary. The resulting executable will be in your working directory and will be named `Main`. The generated source files will be under `output/`.

47+

48+---

README.md+25−54

@@ -1,70 +1,41 @@

1[![PureScript](https://raw.githubusercontent.com/purescript/purescript/master/logo.png)](http://purescript.org)

2

3−This is an experimental C++11 (or later) compiler backend for [PureScript](https://github.com/purescript/purescript). It attempts to generate "sane", debuggable, and portable C++ code as an intermediate language, which is then compiled to a native executable binary. This enables easy interoperability with existing C/C++ frameworks and libraries on a number of platforms.

3+This is a platform-native compiler backend for [PureScript](https://github.com/purescript/purescript). It attempts to generate "sane", debuggable, and portable [C++11](https://isocpp.org/wiki/faq/cpp11) (or later) or [Go](https://golang.org/) code as an intermediate language, which is then compiled to a native executable binary. This also enables easy interoperability with existing C/C++ or Go frameworks and libraries on a number of platforms.

4

5−---

5+There are two utilities in the purescript-native "suite": `pscpp` and `psgo`. The source code in this branch is for `psgo`, the purescript-to-Go transpiler. For the source code of the `pscpp` purescript-to-C++ transpiler, please see the [cpp branch](https://github.com/andyarvanitis/purescript-native/tree/cpp).

6−

7−### **Please note that this project supersedes [pure11](https://github.com/pure11/pure11)**

8−

9−#### Please see [changes](https://github.com/andyarvanitis/purescript-native/wiki/changes) for more details.

10−

11−---

12

6

13#### Platforms

7#### Platforms

14−* Generated C++ code and resulting binary executables tested (to at least some extent) on:

8+* Although purescript-native should work on any platform supporting PureScript and modern C++ or Go, the generated code and resulting binary executables have been tested on:

9+ * macOS Mojave 10.14.5 – full test suite

15− * macOS Mojave, Xcode 10.1's clang (full test suite)

10+ * For C++, Xcode 10.2.1's `clang` was used

11+ * For Go, `go` version 1.12.7 was used

12+ * Windows 10 x64 – full test suite

16− * Windows 10 x64 and x86, Visual Studio 2017

13+ * C++: Visual Studio 2017 and `clang`

14+ * Go: `go` version 1.12.7

15+ * Linux Debian 9.5 amd64 – full test suite (C++)

17− * Linux Debian 9.5 amd64, default versions of clang and gcc/g++ (full test suite)

16+ * Default versions of `clang` and `gcc`

17+ * Linux Debian 10 amd64 – full test suite (Go)

18+ * Default version of `go`

18− * Raspberry Pi 3 B+ Raspbian official build (ARM), default versions of clang and gcc/g++

19+ * Raspberry Pi 3 B+ Raspbian official build (ARM), default versions of `clang` and `gcc`

19−

20−#### Performance

21−

22−* No runtime system beyond some support classes and the standard C++11 (or later) runtime library

23−* For automatic memory management, uses native C++11 reference counting (`std::shared_ptr`)

24−* Uses PureScript's normal tail call optimization techniques for generated C++ code

25−

26−#### Differences from PureScript:

27−

28−* Foreign imports/exports are C++ instead of JavaScript – see [FFI notes](https://github.com/andyarvanitis/purescript-native/wiki/FFI) and [standard library foreign implementations](https://github.com/andyarvanitis/purescript-native-ffi)

29−* No C++-specific REPL

30−

31−#### Other notes:

32−

33−* PureScript arrays are implemented using [`std::vector`](http://en.cppreference.com/w/cpp/container/vector)

34−* `String` types are implemented with C++11 `u8` literals (UTF-8) and `std::string`

35−* `Number` is C++ `double`, `Int` is C++ `int`, `Char` is `std::string` (single UTF-8 entity), `Boolean` is `bool`

36−

37−#### Future ideas:

38−

39−* Nice facilities (modules) for concurrency/parallelism, using `std::thread`, `std::async`, etc. under the hood (output is already generally thread-safe for immutable values, thanks to `std::shared_ptr`)

40−

41−#### Requirements for building the compiler itself

42−

43−* [Haskell Stack](https://docs.haskellstack.org/en/stable/README/) (if you're running macOS 10.13+, you can use pre-built binaries from [here](https://github.com/andyarvanitis/purescript-native/releases/))

44−

45−#### Requirements for using it

46−

47−* A recent version (0.12+) of [purescript](https://github.com/purescript/purescript/releases).

48

20

49−* A C++11-capable toolchain, e.g. recent versions of clang, gcc, Microsoft Visual Studio

50−* GNU Make is the default supported build tool, but you should be able to use your favorite C++ build system, tools, debuggers, etc.

51

21

52−#### Getting Started

22+#### Requirements for building `pscpp` and `psgo`

53−This assumes you are running macOS (OS X) or a Unix-like system (Linux, *BSD, etc.).

54

23

55−1. Make sure you have developer tools for your system installed. For macOS, you'll need a recent version of Xcode. For Linux, etc., you can use clang 3.5 or later, or gcc/g++ 4.9.2 or later.

24+* [Haskell Stack](https://docs.haskellstack.org/en/stable/README/) (if you're running macOS 10.14.5+, you can use pre-built binaries from [here](https://github.com/andyarvanitis/purescript-native/releases/))

56

25

57−2. Create a working directory wherever you like, and a `src` subdirectory under it, which will be where you will place your own PureScript source files.

26+#### Requirements for using PureScript + purescript-native

58

27

59−3. Under your working directory, also create an `ffi` subdirectory, which will be where you will place C/C++ FFI source files. You should at least add the contents of [purescript-native-ffi](https://github.com/andyarvanitis/purescript-native-ffi) into this directory, in addition to any of your own foreign implementations.

28+* A recent version (0.13+) of [purescript](https://github.com/purescript/purescript/releases).

60

29

61−4. Generate the default GNU `Makefile` in your working directory by running `pscpp --makefile`.

30+* For `pscpp`, a C++11-capable toolchain, e.g. recent versions of clang, gcc, Microsoft Visual Studio

31+ * GNU Make + `psc-package` is the default supported build tool, but you should be able to use your favorite package manager, C++ build system, tools, debuggers, etc.

32+* For `psgo`, the [Go toolchain](https://golang.org) for your system

33+ * You can use your favorite PureScript package manager and build tools – but for simplicity, [`spago`](https://github.com/spacchetti/spago) is recommended.

62

34

63−5. Use PureScript's standard [`psc-package`](https://psc-package.readthedocs.io/en/latest/) utility to add and manage package dependencies.

64

35

65−6. You should now be ready to build a PureScript program:

36+#### For more information and a Getting Started guide, please see

66− * As stated above, place your source file(s) in the working directory's `src` subdirectory and execute `make debug` or `make release`. If your build machine has multiple cores, you might want to append `-jN` to your *make* command, where `N` is the number of cores.

37+* [`pscpp`](https://github.com/andyarvanitis/purescript-native/blob/cpp/README-cpp.md)

38+* [`psgo`](https://github.com/andyarvanitis/purescript-native/blob/golang/README-go.md)

67

39

68− * This will generate the C++ source tree for your program and then build an executable binary. The resulting executable will be in the `bin` subdirectory under the output directory and called `main` (so `output/bin/main`, by default). Source files will be under `src` (`output/src/` by default).

69

40

70---

41---

app/Main.hs+162−47

@@ -10,7 +10,7 @@ import Data.Aeson

10import Data.Aeson.Types

11import Data.Char

12import Data.FileEmbed (embedFile)

13−import Data.List (delete, isPrefixOf, partition)

13+import Data.List (delete, intercalate, isPrefixOf, nub, partition, (\\))

14import Data.Maybe

15import Data.Monoid ((<>))

16import Data.Version

@@ -19,8 +19,10 @@ import Control.Monad.Supply.Class

19import Text.Printf

20

21import System.Environment

22−import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist, getModificationTime)

22+import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist, getCurrentDirectory, getModificationTime)

23import System.FilePath ((</>), joinPath, splitDirectories, takeDirectory)

24+import System.FilePath.Find

25+import System.Process

24

26

25import Data.Text (Text)

27import Data.Text (Text)

26import qualified Data.Text as T

28import qualified Data.Text as T

@@ -29,6 +31,8 @@ import qualified Data.Text.Lazy as L

29import qualified Data.Text.Lazy.Encoding as L

31import qualified Data.Text.Lazy.Encoding as L

30import qualified Data.ByteString as B

32import qualified Data.ByteString as B

31

33

34+import Development.GitRev

35+

32import Language.PureScript.AST.Literals

36import Language.PureScript.AST.Literals

33import Language.PureScript.CoreFn

37import Language.PureScript.CoreFn

34import Language.PureScript.CoreFn.FromJSON

38import Language.PureScript.CoreFn.FromJSON

@@ -39,6 +43,8 @@ import CodeGen.IL.Printer

39

43

40import Tests

44import Tests

41

45

46+data Command = Build | Run (Maybe String)

47+

42parseJson :: Text -> Value

48parseJson :: Text -> Value

43parseJson text

49parseJson text

44 | Just fileJson <- decode . L.encodeUtf8 $ L.fromStrict text = fileJson

50 | Just fileJson <- decode . L.encodeUtf8 $ L.fromStrict text = fileJson

@@ -48,43 +54,102 @@ jsonToModule :: Value -> Module Ann

48jsonToModule value =

54jsonToModule value =

49 case parse moduleFromJSON value of

55 case parse moduleFromJSON value of

50 Success (_, r) -> r

56 Success (_, r) -> r

51− _ -> error "failed"

57+ _ -> error "Failed parsing corefn. Psgo currently supports purescript <= 0.13.8"

58+

59+splitArgs :: [String] -> ([String], Maybe String, [String])

60+splitArgs args =

61+ let (opts, files) = partition (isPrefixOf "--") args

62+ opts' = (map . map) toLower opts

63+ (moduleName, files') =

64+ if null files

65+ then (Nothing, files)

66+ else

67+ if "--run" `elem` opts' && length (files) >= 1

68+ then do

69+ let file0 = head files

70+ files' = tail files

71+ case file0 of

72+ "Main.main" -> (Just "Main", files')

73+ "Test.Main.main" -> (Just "Test.Main", files')

74+ _ -> (Nothing, files)

75+ else (Nothing, files)

76+ in (opts, moduleName, files')

52

77

53main :: IO ()

78main :: IO ()

54main = do

79main = do

55 args <- getArgs

80 args <- getArgs

56− if null args

81+ -- let (opts, files) = partition (isPrefixOf "--") args

57− then return ()

82+ let (opts, moduleName, files) = splitArgs args

83+ opts' = (map . map) toLower opts

84+ if "--tests" `elem` opts'

85+ then runTests

58 else do

86 else do

59− let (opts, files) = partition (isPrefixOf "--") args

60− opts' = (map . map) toLower opts

61− if "--tests" `elem` opts'

87+ if "--help" `elem` opts' || "--version" `elem` opts'

62− then runTests

88+ then do

63− else do

64− when ("--makefile" `elem` opts') $

89+ when ("--help" `elem` opts') $ do

65− B.writeFile "Makefile" $(embedFile "support/Makefile")

66− when ("--help" `elem` opts') $

67 putStrLn help

90 putStrLn help

91+ when ("--version" `elem` opts') $ do

92+ let branch = $(gitBranch)

93+ details | branch == "golang" = "master, commit " ++ $(gitHash)

94+ | otherwise = branch

95+ putStrLn $ details ++ if $(gitDirty) then " (DIRTY)" else ""

96+ else do

68− when (not $ null files) $ do

97+ if null files

98+ then do

99+ currentDir <- getCurrentDirectory

100+ processFiles opts' [currentDir]

101+ else

102+ processFiles opts' files

103+ if "--run" `elem` opts

104+ then runBuildTool $ Run moduleName

105+ else when ("--no-build" `notElem` opts) $

106+ runBuildTool Build

107+ return ()

108+ where

109+ processFiles :: [String] -> [FilePath] -> IO ()

110+ processFiles opts [file] = do

111+ isDir <- doesDirectoryExist file

112+ if isDir then do

113+ files <- find always (fileName ==? corefn) file

114+ if null files

115+ then errorNoCorefnFiles

116+ else generateFiles opts files

117+ else generateFiles opts [file]

118+ processFiles opts files = do

119+ generateFiles opts files

120+ basePath :: [FilePath] -> FilePath

121+ basePath files =

69− let filepath = takeDirectory (head files)

122+ let filepath = takeDirectory (head files) in

70− baseOutpath = joinPath $ (init $ splitDirectories filepath) ++ [outdir]

123+ joinPath $ (init $ splitDirectories filepath)

71− writeRuntimeFiles baseOutpath

124+ generateFiles :: [String] -> [FilePath] -> IO ()

125+ generateFiles opts files = do

126+ let baseOutpath = basePath files

127+ writeSupportFiles baseOutpath

72− Par.mapM (generateCode opts' baseOutpath) files

128+ Par.mapM (generateCode opts baseOutpath) files

73− return ()

129+ return ()

130+ runBuildTool :: Command -> IO ()

131+ runBuildTool cmd = do

132+ project <- projectEnv

133+ case cmd of

134+ Build -> do

135+ callProcess "go" ["build", T.unpack project </> modPrefix' </> "Main"]

136+ Run moduleName -> do

137+ callProcess "go" ["run", T.unpack project </> modPrefix' </> fromMaybe "Main" moduleName]

74− return ()

138+ return ()

75

139

76generateCode :: [String] -> FilePath -> FilePath -> IO ()

140generateCode :: [String] -> FilePath -> FilePath -> IO ()

77generateCode opts baseOutpath jsonFile = do

141generateCode opts baseOutpath jsonFile = do

78 jsonModTime <- getModificationTime jsonFile

142 jsonModTime <- getModificationTime jsonFile

79 let filepath = takeDirectory jsonFile

143 let filepath = takeDirectory jsonFile

80 dirparts = splitDirectories $ filepath

144 dirparts = splitDirectories $ filepath

81− mname = (\c -> if c == '.' then '_' else c) <$> last dirparts

145+ mname = last dirparts

82 basedir = joinPath $ init dirparts

146 basedir = joinPath $ init dirparts

83− possInterfaceFilename = basedir </> outdir </> mname </> interfaceFileName mname

147+ mname' = T.pack mname

148+ possibleFileName = basedir </> (T.unpack mname') </> implFileName mname'

84− exists <- doesFileExist possInterfaceFilename

149+ exists <- doesFileExist possibleFileName

85 if exists

150 if exists

86 then do

151 then do

87− modTime <- getModificationTime possInterfaceFilename

152+ modTime <- getModificationTime possibleFileName

88 when (modTime < jsonModTime) $

153 when (modTime < jsonModTime) $

89 transpile opts baseOutpath jsonFile

154 transpile opts baseOutpath jsonFile

90 else transpile opts baseOutpath jsonFile

155 else transpile opts baseOutpath jsonFile

@@ -92,44 +157,94 @@ generateCode opts baseOutpath jsonFile = do

92transpile :: [String] -> FilePath -> FilePath -> IO ()

157transpile :: [String] -> FilePath -> FilePath -> IO ()

93transpile opts baseOutpath jsonFile = do

158transpile opts baseOutpath jsonFile = do

94 jsonText <- T.decodeUtf8 <$> B.readFile jsonFile

159 jsonText <- T.decodeUtf8 <$> B.readFile jsonFile

160+ project <- projectEnv

95 let module' = jsonToModule $ parseJson jsonText

161 let module' = jsonToModule $ parseJson jsonText

96− ((interface, foreigns, asts, implHeader, implFooter), _) <- runSupplyT 5 (moduleToIL module' Nothing)

162+ ((_, foreigns, asts, implHeader, implFooter), _) <- runSupplyT 5 (moduleToIL module' project)

97− let mn = moduleNameToIL $ moduleName module'

163+ let mn = moduleNameToIL' $ moduleName module'

98 implementation = prettyPrintIL asts

164 implementation = prettyPrintIL asts

99 outpath = joinPath [baseOutpath, T.unpack mn]

165 outpath = joinPath [baseOutpath, T.unpack mn]

100− interfacePath = outpath </> interfaceFileName (T.unpack mn)

101 implPath = outpath </> implFileName mn

166 implPath = outpath </> implFileName mn

102− putStrLn interfacePath

103 createDirectoryIfMissing True outpath

167 createDirectoryIfMissing True outpath

104− B.writeFile interfacePath $ T.encodeUtf8 interface

105 putStrLn implPath

168 putStrLn implPath

106 B.writeFile implPath $ T.encodeUtf8 (implHeader <> implementation <> implFooter)

169 B.writeFile implPath $ T.encodeUtf8 (implHeader <> implementation <> implFooter)

107

170

108−writeRuntimeFiles :: FilePath -> IO ()

171+writeSupportFiles :: FilePath -> IO ()

109−writeRuntimeFiles baseOutpath = do

172+writeSupportFiles baseOutpath = do

173+ currentDir <- getCurrentDirectory

174+ let outputdir = T.pack $ baseOutpath \\ currentDir

175+ ffiOutpath = currentDir </> subdir

110− createDirectoryIfMissing True $ baseOutpath </> "purescript"

176+ createDirectoryIfMissing True baseOutpath

111− let runtimeSource = baseOutpath </> "purescript" </> "purescript.go"

177+ createDirectoryIfMissing True ffiOutpath

112− runtimeExists <- doesFileExist runtimeSource

178+ writeModuleFile outputdir currentDir $(embedFile "support/go.mod.working")

113− when (not runtimeExists) $ do

179+ writeModuleFile outputdir baseOutpath $(embedFile "support/go.mod.output")

114− B.writeFile runtimeSource $(embedFile "runtime/purescript.go")

180+ writeModuleFile outputdir ffiOutpath $(embedFile "support/go.mod.ffi-loader")

115−

181+ writeLoaderFile ffiOutpath $(embedFile "support/ffi-loader.go")

116−outdir :: FilePath

182+ where

117−outdir = "src"

183+ writeModuleFile :: Text -> FilePath -> B.ByteString -> IO ()

118−

184+ writeModuleFile outputdir path modText = do

119−interfaceFileName :: String -> FilePath

185+ let goModSource = path </> "go.mod"

120−interfaceFileName mn = mn <> ".go"

186+ goModSourceExists <- doesFileExist goModSource

187+ when (not goModSourceExists) $ do

188+ project <- projectEnv

189+ let project' = T.unpack project

190+ outputdir' = tail $ T.unpack outputdir

191+ modText' = T.replace "$PROJECT" project $ T.decodeUtf8 modText

192+ replaceLoader = project' </> ffiLoader' <> "=." </> subdir

193+ replaceOutput = project' </> modPrefix' <> "=." </> outputdir'

194+ B.writeFile goModSource $ T.encodeUtf8 modText'

195+ callProcess "go" ["mod", "edit", "-replace", replaceLoader]

196+ callProcess "go" ["mod", "edit", "-replace", replaceOutput]

197+ callProcess "go" ["clean", "-modcache"]

198+ writeLoaderFile :: FilePath -> B.ByteString -> IO ()

199+ writeLoaderFile ffiOutpath loaderText = do

200+ let loaderSource = ffiOutpath </> "ffi_loader.go"

201+ loaderSourceExists <- doesFileExist loaderSource

202+ when (not loaderSourceExists) $ do

203+ B.writeFile loaderSource loaderText

121

204

122implFileName :: Text -> FilePath

205implFileName :: Text -> FilePath

123−implFileName mn = T.unpack $ mn <> ".go"

206+implFileName mn = ((\c -> if c == '.' then '_' else c) <$> T.unpack mn) <> ".go"

207+

208+projectEnv :: IO Text

209+projectEnv = do

210+ T.pack . fromMaybe defaultProject <$> lookupEnv goproject

124

211

125help :: String

212help :: String

126help = "Usage: psgo OPTIONS COREFN-FILES\n\

213help = "Usage: psgo OPTIONS COREFN-FILES\n\

127− \ PureScript-to-go compiler\n\n\

214+ \ PureScript to native (via go) compiler\n\n\

128 \Available options:\n\

215 \Available options:\n\

129 \ --help Show this help text\n\n\

216 \ --help Show this help text\n\n\

130− \ --makefile Generate a GNU Makefile which can be used for compiling\n\

217+ \ --version Show the version number\n\n\

131− \ a PureScript program and libraries to a native binary via\n\

218+ \ --run Run the generated go code directly, without building an\n\

132− \ purs corefn output and C++\n\n\

219+ \ executable\n\

220+ \ --no-build Generate go source files, but do not build an executable\n\

133 \ --tests Run test cases (under construction)\n\n\

221 \ --tests Run test cases (under construction)\n\n\

134 \See also:\n\

222 \See also:\n\

135 \ purs compile --help\n"

223 \ purs compile --help\n"

224+

225+corefn :: String

226+corefn = "corefn.json"

227+

228+goSrc :: String

229+goSrc = ".go"

230+

231+goproject :: String

232+goproject = "GOPROJECT"

233+

234+defaultProject :: String

235+defaultProject = "project.localhost"

236+

237+modPrefix' :: String

238+modPrefix' = T.unpack modPrefix

239+

240+ffiLoader' :: String

241+ffiLoader' = T.unpack ffiLoader

242+

243+subdir :: String

244+subdir = T.unpack modLabel

245+

246+errorNoCorefnFiles :: IO ()

247+errorNoCorefnFiles = do

248+ ioError . userError $ "no compiled purescript '" <> corefn <> "' files found –\n" <>

249+ " make sure to use the '--codegen corefn' option with your purs\n" <>

250+ " project build tool"

default.nixnew file+23

@@ -0,0 +1,23 @@

1+let

2+ haskellNix = import (builtins.fetchTarball https://github.com/input-output-hk/haskell.nix/archive/master.tar.gz) {};

3+ nixpkgsSrc = haskellNix.sources.nixpkgs-1903; # has hsc2hs-0.68.4

4+

5+ hsc2hsOverlay = self: super: {

6+ buildPackages = super.buildPackages // {

7+ hsc2hs = super.haskellPackages.hsc2hs;

8+ };

9+ };

10+

11+ nixpkgsArgs = haskellNix.nixpkgsArgs // {

12+ overlays = haskellNix.nixpkgsArgs.overlays ++ [ hsc2hsOverlay ];

13+ };

14+in

15+{ pkgs ? import nixpkgsSrc nixpkgsArgs

16+}:

17+

18+pkgs.haskell-nix.stackProject {

19+ src = pkgs.haskell-nix.haskellLib.cleanGit {

20+ name = "purescript-native";

21+ src = ./.;

22+ };

23+}

package.yaml+6−5

@@ -10,7 +10,6 @@ extra-source-files:

10- README.md

11- ChangeLog.md

12- stack.yaml

13−- runtime/*

14- support/*

13- support/*

15

14

16# Metadata used when publishing your package

15# Metadata used when publishing your package

@@ -25,7 +24,7 @@ description: Please see the README on Github at <https://github.com/andy

25dependencies:

24dependencies:

26- base >= 4.7 && < 5

25- base >= 4.7 && < 5

27- bytestring >= 0.10.8.2 && < 0.11

26- bytestring >= 0.10.8.2 && < 0.11

28−- purescript -any

27+- purescript

29- base-compat >=0.6.0

28- base-compat >=0.6.0

30- protolude >=0.1.6

29- protolude >=0.1.6

31- text

30- text

@@ -37,9 +36,11 @@ dependencies:

37- transformers >=0.3.0 && <0.6

36- transformers >=0.3.0 && <0.6

38- mtl >=2.1.0 && <2.3.0

37- mtl >=2.1.0 && <2.3.0

39- aeson >=1.0 && <1.5

38- aeson >=1.0 && <1.5

40−- directory -any

39+- directory

41−- process -any

40+- process

42−- file-embed -any

41+- file-embed

42+- filemanip

43+- gitrev

43

44

44library:

45library:

45 source-dirs: src

46 source-dirs: src

psgo.cabalnew file+145

@@ -0,0 +1,145 @@

1+cabal-version: 1.12

2+

3+-- This file has been generated from package.yaml by hpack version 0.35.0.

4+--

5+-- see: https://github.com/sol/hpack

6+

7+name: psgo

8+version: 0.1.0.0

9+description: Please see the README on Github at <https://github.com/andyarvanitis/purescript-native#readme>

10+homepage: https://github.com/andyarvanitis/purescript-native#readme

11+bug-reports: https://github.com/andyarvanitis/purescript-native/issues

12+author: Andy Arvanitis

13+maintainer: example@example.com

14+copyright: 2018 Andy Arvanitis

15+license: BSD3

16+license-file: LICENSE

17+build-type: Simple

18+extra-source-files:

19+ README.md

20+ ChangeLog.md

21+ stack.yaml

22+ support/ffi-loader.go

23+ support/go.mod.ffi-loader

24+ support/go.mod.output

25+ support/go.mod.working

26+

27+source-repository head

28+ type: git

29+ location: https://github.com/andyarvanitis/purescript-native

30+

31+library

32+ exposed-modules:

33+ CodeGen.IL

34+ CodeGen.IL.Common

35+ CodeGen.IL.Optimizer

36+ CodeGen.IL.Optimizer.Common

37+ CodeGen.IL.Optimizer.Inliner

38+ CodeGen.IL.Optimizer.MagicDo

39+ CodeGen.IL.Optimizer.TCO

40+ CodeGen.IL.Printer

41+ Tests

42+ other-modules:

43+ Paths_psgo

44+ hs-source-dirs:

45+ src

46+ default-extensions:

47+ ConstraintKinds

48+ DataKinds

49+ DeriveFunctor

50+ EmptyDataDecls

51+ FlexibleContexts

52+ KindSignatures

53+ LambdaCase

54+ MultiParamTypeClasses

55+ NoImplicitPrelude

56+ PatternGuards

57+ PatternSynonyms

58+ RankNTypes

59+ RecordWildCards

60+ OverloadedStrings

61+ ScopedTypeVariables

62+ TupleSections

63+ ViewPatterns

64+ build-depends:

65+ aeson >=1.0 && <1.5

66+ , base >=4.7 && <5

67+ , base-compat >=0.6.0

68+ , bytestring >=0.10.8.2 && <0.11

69+ , containers

70+ , directory

71+ , file-embed

72+ , filemanip

73+ , filepath

74+ , gitrev

75+ , monad-parallel >=0.7.2.2 && <0.8

76+ , mtl >=2.1.0 && <2.3.0

77+ , pattern-arrows >=0.0.2 && <0.1

78+ , process

79+ , protolude >=0.1.6

80+ , purescript

81+ , safe >=0.3.9 && <0.4

82+ , text

83+ , transformers >=0.3.0 && <0.6

84+ default-language: Haskell2010

85+

86+executable psgo

87+ main-is: Main.hs

88+ other-modules:

89+ Paths_psgo

90+ hs-source-dirs:

91+ app

92+ ghc-options: -threaded -rtsopts -with-rtsopts=-N

93+ build-depends:

94+ aeson >=1.0 && <1.5

95+ , base >=4.7 && <5

96+ , base-compat >=0.6.0

97+ , bytestring >=0.10.8.2 && <0.11

98+ , containers

99+ , directory

100+ , file-embed

101+ , filemanip

102+ , filepath

103+ , gitrev

104+ , monad-parallel >=0.7.2.2 && <0.8

105+ , mtl >=2.1.0 && <2.3.0

106+ , pattern-arrows >=0.0.2 && <0.1

107+ , process

108+ , protolude >=0.1.6

109+ , psgo

110+ , purescript

111+ , safe >=0.3.9 && <0.4

112+ , text

113+ , transformers >=0.3.0 && <0.6

114+ default-language: Haskell2010

115+

116+test-suite psgo-test

117+ type: exitcode-stdio-1.0

118+ main-is: Spec.hs

119+ other-modules:

120+ Paths_psgo

121+ hs-source-dirs:

122+ test

123+ ghc-options: -threaded -rtsopts -with-rtsopts=-N

124+ build-depends:

125+ aeson >=1.0 && <1.5

126+ , base >=4.7 && <5

127+ , base-compat >=0.6.0

128+ , bytestring >=0.10.8.2 && <0.11

129+ , containers

130+ , directory

131+ , file-embed

132+ , filemanip

133+ , filepath

134+ , gitrev

135+ , monad-parallel >=0.7.2.2 && <0.8

136+ , mtl >=2.1.0 && <2.3.0

137+ , pattern-arrows >=0.0.2 && <0.1

138+ , process

139+ , protolude >=0.1.6

140+ , psgo

141+ , purescript

142+ , safe >=0.3.9 && <0.4

143+ , text

144+ , transformers >=0.3.0 && <0.6

145+ default-language: Haskell2010

runtime/purescript.godeleted−54

@@ -1,54 +0,0 @@

1−package purescript

2−

3−//go:generate purs --version

4−

5−import "sync"

6−

7−type Any interface{}

8−

9−type Fn = func(Any) Any

10−type EffFn = func() Any

11−

12−type Once = sync.Once

13−

14−type IGNORE_UNUSED_RUNTIME = bool

15−

16−const Undefined = "undefined"

17−

18−func Apply(f Any, args ...Any) Any {

19− result := f

20− for _, arg := range args {

21− fn, _ := result.(Fn)

22− result = fn(arg)

23− }

24− return result

25−}

26−

27−func Run(f Any, args ...Any) Any {

28− fn, _ := f.(EffFn)

29− return fn()

30−}

31−

32−func Get(dict Any, key string) Any {

33− d, _ := dict.(map[string]Any)

34− return d[key]

35−}

36−

37−func SafeGet(dict map[string]Any, key string) Any {

38− value, ok := dict[key]

39− if !ok {

40− panic("Foreign value '" + key + "' not defined")

41− }

42− return value

43−}

44−

45−func Contains(dict Any, key string) bool {

46− d, _ := dict.(map[string]Any)

47− _, found := d[key]

48− return found

49−}

50−

51−func Length(arr Any) Any {

52− a, _ := arr.([]Any)

53− return len(a)

54−}

src/CodeGen/IL.hs+21−63

@@ -40,7 +40,6 @@ import CodeGen.IL.Optimizer

40import CodeGen.IL.Printer

41

42data DeclType = ModuleDecl | LetDecl | RecLetDecl deriving (Eq)

43−data ImportType = Imported | Ignored

44

43

45-- | Generate code in the simplified intermediate representation for all declarations in a

44-- | Generate code in the simplified intermediate representation for all declarations in a

46-- module.

45-- module.

@@ -49,24 +48,19 @@ moduleToIL

49 -- . (Monad m, MonadReader Options m, MonadSupply m, MonadError MultipleErrors m)

48 -- . (Monad m, MonadReader Options m, MonadSupply m, MonadError MultipleErrors m)

50 . (Monad m, MonadSupply m)

49 . (Monad m, MonadSupply m)

51 => Module Ann

50 => Module Ann

52− -> Maybe AST

51+ -> Text

53 -> m (Text, [Text], [AST], Text, Text)

52 -> m (Text, [Text], [AST], Text, Text)

54−moduleToIL (Module _ coms mn _ imps _ foreigns decls) _ =

53+moduleToIL (Module _ coms mn _ imps _ foreigns decls) project =

55 do

54 do

56− let usedNames = concatMap getNames decls

57− let mnLookup = renameImports usedNames imps

58− imports <- traverse (importToIL Imported mnLookup) . (\\ (mn : C.primModules)) . (\\ [mn]) $ ordNub $ map snd imps

59− ignoredImports <- traverse (importToIL Ignored mnLookup) . delete (ModuleName [ProperName C.prim]) . (\\ (mn : C.primModules)) $ ordNub $ map snd imps

60− interfaceImport <- importToIL Imported (renameImports [] [(emptyAnn, mn)]) mn

61− let decls' = renameModules mnLookup decls

62− ilDecls <- mapM (bindToIL ModuleDecl) decls'

55+ ilDecls <- mapM (bindToIL ModuleDecl) decls

63 optimized <- traverse (traverse (optimize modName')) ilDecls

56 optimized <- traverse (traverse (optimize modName')) ilDecls

64 let optimized' = concat optimized

57 let optimized' = concat optimized

65 values = annotValue <$> optimized'

58 values = annotValue <$> optimized'

66 foreigns' = moduleIdentToIL <$> foreigns

59 foreigns' = moduleIdentToIL <$> foreigns

67 interface = interfaceSource modName values foreigns

60 interface = interfaceSource modName values foreigns

61+ imports = nub . concat $ importToIL <$> optimized'

68− implHeader = implHeaderSource modName (imports ++ ignoredImports) interfaceImport

62+ implHeader = implHeaderSource modName imports project

69− implFooter = implFooterSource modName foreigns

63+ implFooter = implFooterSource (runModuleName mn) foreigns

70 return $ (interface, foreigns', optimized', implHeader, implFooter)

64 return $ (interface, foreigns', optimized', implHeader, implFooter)

71 where

65 where

72 modName = moduleNameToIL mn

66 modName = moduleNameToIL mn

@@ -83,55 +77,16 @@ moduleToIL (Module _ coms mn _ imps _ foreigns decls) _ =

83 getNames (NonRec _ ident _) = [ident]

77 getNames (NonRec _ ident _) = [ident]

84 getNames (Rec vals) = map (snd . fst) vals

78 getNames (Rec vals) = map (snd . fst) vals

85

79

86− -- | Creates alternative names for each module to ensure they don't collide

87− -- with declaration names.

88− renameImports :: [Ident] -> [(Ann, ModuleName)] -> M.Map ModuleName (Ann, ModuleName)

89− renameImports = go M.empty

90− where

91− go :: M.Map ModuleName (Ann, ModuleName) -> [Ident] -> [(Ann, ModuleName)] -> M.Map ModuleName (Ann, ModuleName)

92− go acc used ((ann, mn') : mns') =

93− let mni = Ident $ runModuleName mn'

94− in if mn' /= mn && mni `elem` used

95− then let newName = freshModuleName 1 mn' used

96− in go (M.insert mn' (ann, newName) acc) (Ident (runModuleName newName) : used) mns'

97− else go (M.insert mn' (ann, mn') acc) used mns'

98− go acc _ [] = acc

99−

100− freshModuleName :: Integer -> ModuleName -> [Ident] -> ModuleName

101− freshModuleName i mn'@(ModuleName pns) used =

102− let newName = ModuleName $ init pns ++ [ProperName $ runProperName (last pns) <> "_" <> T.pack (show i)]

103− in if Ident (runModuleName newName) `elem` used

104− then freshModuleName (i + 1) mn' used

105− else newName

106−

107− -- | Generates IL code for a module import, binding the required module

80+ -- | Generates IL code for a module import

108− -- to the alternative

81+ --

109− importToIL :: ImportType -> M.Map ModuleName (Ann, ModuleName) -> ModuleName -> m Text

82+ importToIL :: AST -> [Text]

110− importToIL t mnLookup mn' = do

83+ importToIL = AST.everything (++) modRef

111− let ((_, _, _, _), mnSafe) = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup

112− mname = moduleNameToIL mnSafe

113− pure $ case t of

114− Imported -> "import \"" <> mname <> "\"\n"

115− Ignored -> "type _ = " <> mname <> ".IGNORE_UNUSED_IMPORTS\n"

116−

117− -- | Replaces the `ModuleName`s in the AST so that the generated code refers to

118− -- the collision-avoiding renamed module imports.

119− renameModules :: M.Map ModuleName (Ann, ModuleName) -> [Bind Ann] -> [Bind Ann]

120− renameModules mnLookup binds =

121− let (f, _, _) = everywhereOnValues id ilExpr goBinder

122− in map f binds

123 where

84 where

124− ilExpr :: Expr a -> Expr a

85+ modRef (AST.Indexer _ (AST.Var _ _) (AST.Var _ mname))

125− ilExpr (Var ann q) = Var ann (renameQual q)

86+ | not $ T.null mname = [extract mname]

126− ilExpr e = e

87+ modRef _ = []

127− goBinder :: Binder a -> Binder a

88+ extract :: Text -> Text

128− goBinder (ConstructorBinder ann q1 q2 bs) = ConstructorBinder ann (renameQual q1) (renameQual q2) bs

89+ extract = T.replace "_" "." . T.dropWhileEnd (=='_')

129− goBinder b = b

130− renameQual :: Qualified a -> Qualified a

131− renameQual (Qualified (Just mn') a) =

132− let (_,mnSafe) = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup

133− in Qualified (Just mnSafe) a

134− renameQual q = q

135

90

136 -- |

91 -- |

137 -- Generate code in the simplified intermediate representation for a declaration

92 -- Generate code in the simplified intermediate representation for a declaration

@@ -182,7 +137,7 @@ moduleToIL (Module _ coms mn _ imps _ foreigns decls) _ =

182 updates <- mapM (sndM valueToIL) ps

137 updates <- mapM (sndM valueToIL) ps

183 obj' <- freshName'

138 obj' <- freshName'

184 let objVar = AST.Var Nothing obj'

139 let objVar = AST.Var Nothing obj'

185− copy = AST.VariableIntroduction Nothing obj' (Just $ AST.App Nothing (AST.StringLiteral Nothing (mkString dictType)) [obj])

140+ copy = AST.VariableIntroduction Nothing obj' (Just $ copyDict obj)

186 assign (k, v) = AST.Assignment Nothing (accessorString k objVar) v

141 assign (k, v) = AST.Assignment Nothing (accessorString k objVar) v

187 sts = copy : (assign <$> updates) ++ [AST.Return Nothing objVar]

142 sts = copy : (assign <$> updates) ++ [AST.Return Nothing objVar]

188 return $ AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing sts)) []

143 return $ AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing sts)) []

@@ -246,7 +201,7 @@ moduleToIL (Module _ coms mn _ imps _ foreigns decls) _ =

246 -- | Generate code in the simplified intermediate representation for a reference to a

201 -- | Generate code in the simplified intermediate representation for a reference to a

247 -- variable that may have a qualified name.

202 -- variable that may have a qualified name.

248 qualifiedToIL :: (a -> Ident) -> Qualified a -> AST

203 qualifiedToIL :: (a -> Ident) -> Qualified a -> AST

249− qualifiedToIL f (Qualified (Just (ModuleName [ProperName mn'])) a) | mn' == C.prim = AST.Var Nothing . moduleIdentToIL $ f a

204+ qualifiedToIL f (Qualified (Just (ModuleName mn')) a) | mn' == C.prim = AST.Var Nothing . moduleIdentToIL $ f a

250 qualifiedToIL f (Qualified (Just mn') a) | mn /= mn' = AST.Indexer Nothing (AST.Var Nothing . moduleIdentToIL $ f a) (AST.Var Nothing (moduleNameToIL mn'))

205 qualifiedToIL f (Qualified (Just mn') a) | mn /= mn' = AST.Indexer Nothing (AST.Var Nothing . moduleIdentToIL $ f a) (AST.Var Nothing (moduleNameToIL mn'))

251 qualifiedToIL f (Qualified _ a) = AST.Indexer Nothing (AST.Var Nothing . moduleIdentToIL $ f a) (AST.Var Nothing "")

206 qualifiedToIL f (Qualified _ a) = AST.Indexer Nothing (AST.Var Nothing . moduleIdentToIL $ f a) (AST.Var Nothing "")

252

207

@@ -273,7 +228,7 @@ moduleToIL (Module _ coms mn _ imps _ foreigns decls) _ =

273 go _ _ _ = internalError "Invalid arguments to bindersToIL"

228 go _ _ _ = internalError "Invalid arguments to bindersToIL"

274

229

275 failedPatternMessage :: Text

230 failedPatternMessage :: Text

276− failedPatternMessage = "Failed pattern match at " <> runModuleName mn <> " " <> displayStartEndPos ss <> ": "

231+ failedPatternMessage = "Failed pattern match at " <> runModuleName mn <> " " <> displayStartEndPos ss

277

232

278 guardsToIL :: Either [(Guard Ann, Expr Ann)] (Expr Ann) -> m [AST]

233 guardsToIL :: Either [(Guard Ann, Expr Ann)] (Expr Ann) -> m [AST]

279 guardsToIL (Left gs) = traverse genGuard gs where

234 guardsToIL (Left gs) = traverse genGuard gs where

@@ -361,3 +316,6 @@ emptyAnn = (SourceSpan "" (SourcePos 0 0) (SourcePos 0 0), [], Nothing, Nothing)

361arrayLength :: AST -> AST

316arrayLength :: AST -> AST

362arrayLength a = AST.App Nothing (AST.Var Nothing arrayLengthFn) [a]

317arrayLength a = AST.App Nothing (AST.Var Nothing arrayLengthFn) [a]

363-- arrayLength a = AST.Var Nothing (arrayLengthFn <> "(" <> prettyPrintIL1 a <> ")")

318-- arrayLength a = AST.Var Nothing (arrayLengthFn <> "(" <> prettyPrintIL1 a <> ")")

319+

320+copyDict :: AST -> AST

321+copyDict a = AST.App Nothing (AST.Var Nothing copyDictFn) [a]

src/CodeGen/IL/Common.hs+40−27

@@ -16,13 +16,12 @@ import Language.PureScript.Names

16import qualified Language.PureScript.Constants as C

17

18moduleNameToIL :: ModuleName -> Text

19−moduleNameToIL (ModuleName pns) =

19+moduleNameToIL (ModuleName mn) =

20− let name = T.intercalate "_" (runProperName `map` pns)

20+ let name = T.replace "." "_" mn

21− in moduleNameToIL' name

21+ in if nameIsILBuiltIn name then (name <> moduleRenamerMarker) else name

22

23−moduleNameToIL' :: Text -> Text

23+moduleNameToIL' :: ModuleName -> Text

24−moduleNameToIL' name =

24+moduleNameToIL' (ModuleName mn) = T.replace "_" "." mn

25− if moduleIsReserved name then (name <> "_") else name

26

25

27-- | Convert an 'Ident' into a valid IL identifier:

26-- | Convert an 'Ident' into a valid IL identifier:

28--

27--

@@ -33,7 +32,7 @@ moduleNameToIL' name =

33identToIL :: Ident -> Text

32identToIL :: Ident -> Text

34identToIL UnusedIdent = unusedName

33identToIL UnusedIdent = unusedName

35identToIL (Ident "$__unused") = unusedName

34identToIL (Ident "$__unused") = unusedName

36−identToIL (Ident name) | name == C.undefined = undefinedName

35+identToIL (Ident name) | name == C.undefined = undefinedName -- Note: done in Printer.hs too

37identToIL (Ident name) = properToIL name

36identToIL (Ident name) = properToIL name

38identToIL (GenIdent _ _) = internalError "GenIdent in identToIL"

37identToIL (GenIdent _ _) = internalError "GenIdent in identToIL"

39

38

@@ -51,16 +50,17 @@ unusedName = "_"

51

50

52properToIL :: Text -> Text

51properToIL :: Text -> Text

53properToIL name

52properToIL name

54− | nameIsILReserved name || nameIsILBuiltIn name || prefixIsReserved name = name <> "ˉ"

53+ | nameIsILReserved name = "ˉ" <> name

55 | otherwise = T.concatMap identCharToText name

54 | otherwise = T.concatMap identCharToText name

56

55

57-- | Attempts to find a human-readable name for a symbol, if none has been specified returns the

56-- | Attempts to find a human-readable name for a symbol, if none has been specified returns the

58-- ordinal value.

57-- ordinal value.

59identCharToText :: Char -> Text

58identCharToText :: Char -> Text

59+identCharToText 'ṩ' = "_ṩ"

60identCharToText c | isAlphaNum c = T.singleton c

61identCharToText '_' = "_"

62−identCharToText '\'' = "ʹ"

62+identCharToText '\'' = "ꞌ" -- lowercase saltillo

63−identCharToText c = "ᵤ" <> T.pack (show (ord c))

63+identCharToText c = error (show (ord c)) -- TODO: should never occur now(?)

64

65moduleProperToIL :: Text -> Text

66moduleProperToIL = T.concatMap identCharToText

@@ -74,7 +74,21 @@ nameIsILReserved name =

74nameIsILBuiltIn :: Text -> Bool

75nameIsILBuiltIn name =

76 name `elem`

77− [

77+ [ "Any"

78+ , "Apply"

79+ , "Contains"

80+ , "CopyDict"

81+ , "Dict"

82+ , "EffFn"

83+ , "Fn"

84+ , "Foreign"

85+ , "Get"

86+ , "Index"

87+ , "Is"

88+ , "Length"

89+ , "Once"

90+ , "Run"

91+ , "Undefined"

78 ]

92 ]

79

93

80ilAnyReserved :: [Text]

94ilAnyReserved :: [Text]

@@ -113,16 +127,6 @@ ilKeywords =

113 , "var"

127 , "var"

114 ]

128 ]

115

129

116−moduleIsReserved :: Text -> Bool

117−moduleIsReserved "Main" = False

118−moduleIsReserved name = not $ T.isInfixOf "_" name

119−

120−prefixIsReserved :: Text -> Bool

121−prefixIsReserved name =

122− any (`T.isPrefixOf` name)

123− [

124− ]

125−

126ilLiterals :: [Text]

130ilLiterals :: [Text]

127ilLiterals =

131ilLiterals =

128 [ "init"

132 [ "init"

@@ -148,16 +152,19 @@ ilLiterals =

148 ]

152 ]

149

153

150withPrefix :: Text -> Text

154withPrefix :: Text -> Text

151−withPrefix s = "PS__" <> s

155+withPrefix s = "Ꞌ" <> s -- uppercase saltillo

152

156

153anyType :: Text

157anyType :: Text

154anyType = "Any"

158anyType = "Any"

155

159

156dictType :: Text

160dictType :: Text

157−dictType = "map[string]Any"

161+dictType = "Dict"

158

162

159arrayType :: Text

163arrayType :: Text

160−arrayType = "[]Any"

164+arrayType = "[]" <> anyType

165+

166+uncurriedFnType :: Int -> Text

167+uncurriedFnType i = "Fn" <> (T.pack . show $ i)

161

168

162int :: Text

169int :: Text

163int = "int"

170int = "int"

@@ -174,10 +181,16 @@ string = "string"

174arrayLengthFn :: Text

181arrayLengthFn :: Text

175arrayLengthFn = "Length"

182arrayLengthFn = "Length"

176

183

177−tcoLoop :: Text

184+indexFn :: Text

178−tcoLoop = "ᵗᶜloop"

185+indexFn = "Index"

186+

187+copyDictFn :: Text

188+copyDictFn = "CopyDict"

179

189

180freshName' :: MonadSupply m => m Text

190freshName' :: MonadSupply m => m Text

181freshName' = do

191freshName' = do

182 name <- freshName

192 name <- freshName

183− return $ T.replace "$" "ᵗ" name

193+ return $ T.replace "$" "ṩ" name

194+

195+moduleRenamerMarker :: Text

196+moduleRenamerMarker = "__"

src/CodeGen/IL/Optimizer.hs+22−23

@@ -8,10 +8,10 @@ import Data.Text (Text)

8import Language.PureScript.CoreImp.AST

9import Language.PureScript.CoreImp.Optimizer.Blocks

10import Language.PureScript.CoreImp.Optimizer.Common hiding (isDict)

11−import Language.PureScript.CoreImp.Optimizer.Inliner hiding (inlineCommonOperators, inlineCommonValues, inlineUnsafeCoerce, inlineUnsafePartial)

11+import Language.PureScript.CoreImp.Optimizer.Inliner (etaConvert, evaluateIifes, inlineVariables, unThunk)

12import Language.PureScript.CoreImp.Optimizer.Unused

13

14−import CodeGen.IL.Common (moduleNameToIL', undefinedName, unusedName)

14+import CodeGen.IL.Common (unusedName)

15import CodeGen.IL.Optimizer.Inliner

16import CodeGen.IL.Optimizer.MagicDo

17import CodeGen.IL.Optimizer.TCO

@@ -21,23 +21,19 @@ import qualified Language.PureScript.Constants as C

21-- | Apply a series of optimizer passes to simplified IL code

22optimize :: MonadSupply m => AST -> AST -> m AST

23optimize mn il = do

24− il' <- untilFixedPoint (inlineFnComposition . inlineUnsafeCoerce . inlineUnsafePartial . tidyUp . applyAll

24+ il' <- untilFixedPoint (inlineFnComposition . inlineUnsafeCoerce . inlineUnsafePartial . tidyUp) il

25− [ inlineCommonValues

25+ il'' <- untilFixedPoint (return . ignoreUnusedResults . inlineCommonValues . inlineCommonOperators . tidyUp) . tco mn . inlineST

26− , inlineCommonOperators

27− ]) il

28− untilFixedPoint (return . tidyUp) . tco mn . inlineST

29 =<< untilFixedPoint (return . magicDoST)

26 =<< untilFixedPoint (return . magicDoST)

30 =<< untilFixedPoint (return . magicDoEff)

27 =<< untilFixedPoint (return . magicDoEff)

31 =<< untilFixedPoint (return . magicDoEffect) il'

28 =<< untilFixedPoint (return . magicDoEffect) il'

29+ untilFixedPoint (return . collapseVarDeclarations) il''

32 where

30 where

33 tidyUp :: AST -> AST

31 tidyUp :: AST -> AST

34 tidyUp = applyAll

32 tidyUp = applyAll

35 [ collapseNestedBlocks

33 [ collapseNestedBlocks

36 , collapseNestedIfs

34 , collapseNestedIfs

37 , collapseIfChecks

35 , collapseIfChecks

38− , ignoreUnusedResults

39 , removeCodeAfterReturnStatements

36 , removeCodeAfterReturnStatements

40− -- , removeUndefinedApp

41 , unThunk

37 , unThunk

42 , etaConvert

38 , etaConvert

43 , evaluateIifes

39 , evaluateIifes

@@ -51,18 +47,6 @@ untilFixedPoint f = go

51 a' <- f a

47 a' <- f a

52 if a' == a then return a' else go a'

48 if a' == a then return a' else go a'

53

49

54−-- | Overridden from CoreImp

55−

56−-- inlineApply :: AST -> AST

57−-- inlineApply = everywhereTopDown convert where

58−-- convert (App ss (App _ (Indexer _ (Var _ apply) (Var _ dataFunction)) [ f ]) [ arg ])

59−-- | apply == C.apply && dataFunction == C.dataFunction

60−-- = App ss f [ arg ]

61−-- convert (App ss (App _ (Indexer _ (Var _ applyFlipped) (Var _ dataFunction)) [ arg ]) [ f ])

62−-- | applyFlipped == C.applyFlipped && dataFunction == C.dataFunction

63−-- = App ss f [ arg ]

64−-- convert other = other

65−

66collapseIfChecks :: AST -> AST

50collapseIfChecks :: AST -> AST

67collapseIfChecks = everywhere collapse where

51collapseIfChecks = everywhere collapse where

68 collapse :: AST -> AST

52 collapse :: AST -> AST

@@ -71,12 +55,27 @@ collapseIfChecks = everywhere collapse where

71 | prop == "otherwise" && val == "Data_Boolean" = exprs

55 | prop == "otherwise" && val == "Data_Boolean" = exprs

72 collapse exprs = exprs

56 collapse exprs = exprs

73

57

58+collapseVarDeclarations :: AST -> AST

59+collapseVarDeclarations = everywhere collapse where

60+ collapse :: AST -> AST

61+ collapse (Block ss sts) = Block ss (go Nothing sts)

62+ collapse s = s

63+

64+ go :: Maybe Text -> [AST] -> [AST]

65+ go _ [] = []

66+ go Nothing (decl@(VariableIntroduction _ var (Just _)) : sts) = decl : go (Just var) (go Nothing sts)

67+ go (Just var') ((VariableIntroduction ss var (Just val)) : sts)

68+ | var == var' = (Assignment ss (Var Nothing var) val) : go (Just var') sts

69+ go var' (s:sts) = s : go var' sts

74

70

75ignoreUnusedResults :: AST -> AST

71ignoreUnusedResults :: AST -> AST

76ignoreUnusedResults = everywhere $ removeFromBlock go

72ignoreUnusedResults = everywhere $ removeFromBlock go

77 where

73 where

78 go :: [AST] -> [AST]

74 go :: [AST] -> [AST]

79 go [] = []

75 go [] = []

80− go (VariableIntroduction ss var s@(Just _) : sts)

76+ go (VariableIntroduction ss var (Just s) : sts)

81− | not $ any (everything (||) (isUsed var)) sts = (VariableIntroduction ss unusedName s) : sts

77+ | not $ any (everything (||) (isUsed var)) sts = sts'

78+ where

79+ sts' | App{} <- s = s : (go sts)

80+ | otherwise = go sts

82 go (s:sts) = s : go sts

81 go (s:sts) = s : go sts

src/CodeGen/IL/Optimizer/Common.hs+1−3

@@ -8,11 +8,9 @@ import Data.Text (Text)

8import Language.PureScript.CoreImp.AST

9import Language.PureScript.PSString (PSString, decodeString)

10

11−import CodeGen.IL.Common (moduleNameToIL')

12−

13isDict :: (Text, PSString) -> AST -> Bool

11isDict :: (Text, PSString) -> AST -> Bool

14isDict (moduleName, dictName) (Indexer _ (Var _ x) (Var _ y)) =

12isDict (moduleName, dictName) (Indexer _ (Var _ x) (Var _ y)) =

15− Just x == decodeString dictName && y == moduleNameToIL' moduleName

13+ Just x == decodeString dictName && y == moduleName

16isDict _ _ = False

14isDict _ _ = False

17

15

18isDict' :: [(Text, PSString)] -> AST -> Bool

16isDict' :: [(Text, PSString)] -> AST -> Bool

src/CodeGen/IL/Optimizer/Inliner.hs+34−18

@@ -2,7 +2,7 @@

2module CodeGen.IL.Optimizer.Inliner

3 ( inlineCommonValues

4 , inlineCommonOperators

5− -- , inlineFnComposition

5+ , inlineFnComposition

6 , inlineUnsafeCoerce

7 , inlineUnsafePartial

8 ) where

@@ -48,7 +48,7 @@ inlineCommonValues = everywhere convert

48 | isDict boundedBoolean dict && isDict fnBottom fn = BooleanLiteral ss False

49 | isDict boundedBoolean dict && isDict fnTop fn = BooleanLiteral ss True

50 convert (App ss (App _ fn [dict]) [x])

51− | isDict ringInt dict && isDict fnNegate fn = Unary ss Negate x -- (unbox x $ snd ringInt)

51+ | isDict ringInt dict && isDict fnNegate fn = Unary ss Negate (unbox x $ snd ringInt)

52 convert (App ss (App _ (App _ fn [dict]) [x]) [y])

53 | isDict semiringInt dict && isDict fnAdd fn = intOp ss Add semiringInt x y

54 | isDict semiringInt dict && isDict fnMultiply fn = intOp ss Multiply semiringInt x y

@@ -117,12 +117,11 @@ inlineCommonOperators = everywhereTopDown $ applyAll $

117 , binary' C.dataIntBits C.xor BitwiseXor

118 , binary' C.dataIntBits C.shl ShiftLeft

119 , binary' C.dataIntBits C.shr ShiftRight

120− , binary' C.dataIntBits C.zshr ZeroFillShiftRight

121 , unary' C.dataIntBits C.complement BitwiseNot

120 , unary' C.dataIntBits C.complement BitwiseNot

122

121

123 , inlineNonClassFunction (isModFn (C.dataFunction, C.apply)) $ \f x -> App Nothing f [x]

122 , inlineNonClassFunction (isModFn (C.dataFunction, C.apply)) $ \f x -> App Nothing f [x]

124 , inlineNonClassFunction (isModFn (C.dataFunction, C.applyFlipped)) $ \x f -> App Nothing f [x]

123 , inlineNonClassFunction (isModFn (C.dataFunction, C.applyFlipped)) $ \x f -> App Nothing f [x]

125− , inlineNonClassFunction (isModFnWithDict (C.dataArray, C.unsafeIndex)) $ flip (Indexer Nothing)

124+ , inlineUnsafeIndex (isModFnWithDict (C.dataArray, C.unsafeIndex)) $ flip (Indexer Nothing)

126 ] ++

125 ] ++

127 [ fn | i <- [0..10], fn <- [ mkFn i, runFn i ] ] ++

126 [ fn | i <- [0..10], fn <- [ mkFn i, runFn i ] ] ++

128 [ fn | i <- [0..10], fn <- [ mkEffFn C.controlMonadEffUncurried C.mkEffFn i, runEffFn C.controlMonadEffUncurried C.runEffFn i ] ] ++

127 [ fn | i <- [0..10], fn <- [ mkEffFn C.controlMonadEffUncurried C.mkEffFn i, runEffFn C.controlMonadEffUncurried C.runEffFn i ] ] ++

@@ -137,8 +136,10 @@ inlineCommonOperators = everywhereTopDown $ applyAll $

137 binary' :: Text -> PSString -> BinaryOperator -> AST -> AST

136 binary' :: Text -> PSString -> BinaryOperator -> AST -> AST

138 binary' moduleName opString op = convert where

137 binary' moduleName opString op = convert where

139 convert :: AST -> AST

138 convert :: AST -> AST

140− convert (App ss (App _ fn [x]) [y]) | isDict (moduleName, opString) fn = Binary ss op (unbox x opString) (unbox y opString)

139+ convert (App ss (App _ fn [x]) [y]) | isDict (moduleName, opString) fn = Binary ss op (unbox x mn) (unbox y mn)

141 convert other = other

140 convert other = other

141+ mn :: PSString

142+ mn = mkString moduleName

142 unary :: (Text, PSString) -> (Text, PSString) -> UnaryOperator -> AST -> AST

143 unary :: (Text, PSString) -> (Text, PSString) -> UnaryOperator -> AST -> AST

143 unary dicts@(_, d) fns op = convert where

144 unary dicts@(_, d) fns op = convert where

144 convert :: AST -> AST

145 convert :: AST -> AST

@@ -177,16 +178,21 @@ inlineCommonOperators = everywhereTopDown $ applyAll $

177 collectArgs _ _ _ = Nothing

178 collectArgs _ _ _ = Nothing

178

179

179 isNFn :: Text -> Text -> Int -> AST -> Bool

180 isNFn :: Text -> Text -> Int -> AST -> Bool

180− isNFn expectMod prefix n (Indexer _ (StringLiteral _ name) (Var _ modName)) | modName == expectMod =

181+ isNFn expectMod prefix n (Indexer _ (Var _ name) (Var _ modName)) | modName == expectMod =

181 name == fromString (T.unpack prefix <> show n)

182 name == fromString (T.unpack prefix <> show n)

182 isNFn _ _ _ _ = False

183 isNFn _ _ _ _ = False

183

184

184 runFn :: Int -> AST -> AST

185 runFn :: Int -> AST -> AST

185− runFn = runFn' C.dataFunctionUncurried C.runFn App

186+ runFn = runFn' C.dataFunctionUncurried C.runFn (\ss f args ->

186−

187+ let len = length args

188+ typ = mkString $ uncurriedFnType len in

189+ if len > 0

190+ then App ss (App Nothing (StringLiteral Nothing typ) [f]) args

191+ else App ss f args)

187 runEffFn :: Text -> Text -> Int -> AST -> AST

192 runEffFn :: Text -> Text -> Int -> AST -> AST

188 runEffFn modName fnName = runFn' modName fnName $ \ss fn acc ->

193 runEffFn modName fnName = runFn' modName fnName $ \ss fn acc ->

194+ let typ = mkString . uncurriedFnType $ length acc in

189− Function ss Nothing [] (Block ss [Return ss (App ss fn acc)])

195+ Function ss Nothing [] (Block ss [Return ss (App ss (App Nothing (StringLiteral Nothing typ) [fn]) acc)])

190

196

191 runFn' :: Text -> Text -> (Maybe SourceSpan -> AST -> [AST] -> AST) -> Int -> AST -> AST

197 runFn' :: Text -> Text -> (Maybe SourceSpan -> AST -> [AST] -> AST) -> Int -> AST -> AST

192 runFn' modName runFnName res n = convert where

198 runFn' modName runFnName res n = convert where

@@ -205,14 +211,23 @@ inlineCommonOperators = everywhereTopDown $ applyAll $

205 convert (App _ (App _ op' [x]) [y]) | p op' = f x y

211 convert (App _ (App _ op' [x]) [y]) | p op' = f x y

206 convert other = other

212 convert other = other

207

213

214+ inlineUnsafeIndex :: (AST -> Bool) -> (AST -> AST -> AST) -> AST -> AST

215+ inlineUnsafeIndex p _ = convert where

216+ convert :: AST -> AST

217+ convert (App _ (App ss op' [x]) [y@NumericLiteral{}])

218+ | p op' = Indexer ss y x

219+ convert (App _ (App ss op' [x]) [y])

220+ | p op' = App ss (Var Nothing indexFn) [x, y]

221+ convert other = other

222+

208 isModFn :: (Text, PSString) -> AST -> Bool

223 isModFn :: (Text, PSString) -> AST -> Bool

209− isModFn (m, op) (Indexer _ (StringLiteral _ op') (Var _ m')) =

224+ isModFn (m, op) (Indexer _ (Var _ op') (Var _ m')) =

210− m == m' && op == op'

225+ m == m' && decodeString op == Just op'

211 isModFn _ _ = False

226 isModFn _ _ = False

212

227

213 isModFnWithDict :: (Text, PSString) -> AST -> Bool

228 isModFnWithDict :: (Text, PSString) -> AST -> Bool

214− isModFnWithDict (m, op) (App _ (Indexer _ (StringLiteral _ op') (Var _ m')) [Var _ _]) =

229+ isModFnWithDict (m, op) (App _ (Indexer _ (Var _ op') (Var _ m')) [Var _ _]) =

215− m == m' && op == op'

230+ m == m' && decodeString op == Just op'

216 isModFnWithDict _ _ = False

231 isModFnWithDict _ _ = False

217

232

218-- (f <<< g $ x) = f (g x)

233-- (f <<< g $ x) = f (g x)

@@ -265,11 +280,12 @@ inlineUnsafeCoerce = everywhereTopDown convert where

265

280

266inlineUnsafePartial :: AST -> AST

281inlineUnsafePartial :: AST -> AST

267inlineUnsafePartial = everywhereTopDown convert where

282inlineUnsafePartial = everywhereTopDown convert where

268− convert (App ss (Indexer _ (Var _ unsafePartial) (Var _ partialUnsafe)) [ comp ])

283+ convert (App ss fn [ comp ])

269− | unsafePartial == C.unsafePartial && partialUnsafe == C.partialUnsafe

284+ | isDict fnUnsafePartial fn

270− -- Apply to undefined here, the application should be optimized away

285+ = App ss comp []

271− -- if it is safe to do so

286+ where

272− = App ss comp [ Var ss undefinedName ]

287+ fnUnsafePartial :: forall a b. (IsString a, IsString b) => (a, b)

288+ fnUnsafePartial = (C.partialUnsafe, C.unsafePartial)

273 convert other = other

289 convert other = other

274

290

275semiringNumber :: forall a b. (IsString a, IsString b) => (a, b)

291semiringNumber :: forall a b. (IsString a, IsString b) => (a, b)

src/CodeGen/IL/Optimizer/MagicDo.hs+1−1

@@ -13,7 +13,7 @@ import Language.PureScript.CoreImp.Optimizer.Common hiding (isDict)

13import Language.PureScript.PSString (PSString, decodeString, mkString)

14import qualified Language.PureScript.Constants as C

15

16−import CodeGen.IL.Common (moduleNameToIL', undefinedName, unusedName)

16+import CodeGen.IL.Common (undefinedName, unusedName)

17import CodeGen.IL.Optimizer.Common

18

19-- | Inline type class dictionaries for >>= and return for the Eff monad

src/CodeGen/IL/Optimizer/TCO.hs+9−5

@@ -1,4 +1,4 @@

1−module CodeGen.IL.Optimizer.TCO (tco) where

1+module CodeGen.IL.Optimizer.TCO (tco, tcoLoop) where

2

3import Prelude.Compat

4

@@ -11,19 +11,22 @@ import CodeGen.IL.Common

11

12import qualified Language.PureScript.Constants as C

13

14+tcoLoop :: Text

15+tcoLoop = "ṩtco_loop"

16+

14tco :: AST -> AST -> AST

17tco :: AST -> AST -> AST

15tco mn = everywhere convert where

18tco mn = everywhere convert where

16 tcoVar :: Text -> Text

19 tcoVar :: Text -> Text

17− tcoVar arg = "ᵗ" <> arg

20+ tcoVar arg = "ṩtco_var_" <> arg

18

21

19 copyVar :: Text -> Text

22 copyVar :: Text -> Text

20− copyVar arg = "ᶜ" <> arg

23+ copyVar arg = "ṩcopy_" <> arg

21

24

22 tcoDone :: Text

25 tcoDone :: Text

23− tcoDone = "ᵗᶜdone"

26+ tcoDone = "ṩtco_done"

24

27

25 tcoResult :: Text

28 tcoResult :: Text

26− tcoResult = "ᵗᶜresult"

29+ tcoResult = "ṩtco_result"

27

30

28 convert :: AST -> AST

31 convert :: AST -> AST

29 convert fn@(Function ss (Just name) args _)

32 convert fn@(Function ss (Just name) args _)

@@ -132,6 +135,7 @@ tco mn = everywhere convert where

132

135

133 isSelfCall :: Text -> AST -> Bool

136 isSelfCall :: Text -> AST -> Bool

134 isSelfCall ident (App _ (Var _ ident') _) = ident == ident'

137 isSelfCall ident (App _ (Var _ ident') _) = ident == ident'

138+ isSelfCall ident (App _ (Indexer _ (Var _ ident') (Var _ mn')) _) = mn' == "" && ident == ident'

135 isSelfCall ident (App _ (Indexer _ (Var _ ident') mn') _) = mn' == mn && ident == ident'

139 isSelfCall ident (App _ (Indexer _ (Var _ ident') mn') _) = mn' == mn && ident == ident'

136 isSelfCall ident (App _ fn _) = isSelfCall ident fn

140 isSelfCall ident (App _ fn _) = isSelfCall ident fn

137 isSelfCall _ _ = False

141 isSelfCall _ _ = False

src/CodeGen/IL/Printer.hs+100−31

@@ -7,6 +7,9 @@ module CodeGen.IL.Printer

7 , implHeaderSource

8 , implFooterSource

9 , isLiteral

10+ , modLabel

11+ , modPrefix

12+ , ffiLoader

10 ) where

13 ) where

11

14

12import Prelude.Compat

15import Prelude.Compat

@@ -30,7 +33,9 @@ import Language.PureScript.Crash

30import Language.PureScript.Names (Ident, runIdent)

33import Language.PureScript.Names (Ident, runIdent)

31import Language.PureScript.Pretty.Common

34import Language.PureScript.Pretty.Common

32import Language.PureScript.PSString (PSString, decodeString, mkString)

35import Language.PureScript.PSString (PSString, decodeString, mkString)

36+

33import CodeGen.IL.Common

37import CodeGen.IL.Common

38+import CodeGen.IL.Optimizer.TCO (tcoLoop)

34

39

35import qualified Language.PureScript.Constants as C

40import qualified Language.PureScript.Constants as C

36

41

@@ -72,6 +77,7 @@ literals = mkPattern' match'

72 , currentIndent

77 , currentIndent

73 , return $ emit "}"

78 , return $ emit "}"

74 ]

79 ]

80+ match (Var _ ident) | ident == C.undefined = return $ emit undefinedName

75 match (Var _ ident) = return $ emit ident

81 match (Var _ ident) = return $ emit ident

76 match (VariableIntroduction _ ident value) = mconcat <$> sequence

82 match (VariableIntroduction _ ident value) = mconcat <$> sequence

77 [ return . emit $ varDecl <> " " <> ident <> " " <> anyType

83 [ return . emit $ varDecl <> " " <> ident <> " " <> anyType

@@ -100,12 +106,36 @@ literals = mkPattern' match'

100 , prettyPrintIL' arg

106 , prettyPrintIL' arg

101 , return $ emit ")"

107 , return $ emit ")"

102 ]

108 ]

109+ match (App _ (Var _ fn) args) | fn == indexFn = mconcat <$> sequence

110+ [ return $ emit fn

111+ , return $ emit "("

112+ , intercalate (emit ", ") <$> forM args prettyPrintIL'

113+ , return $ emit ")"

114+ ]

103 match (App _ (Var _ fn) args) | fn == tcoLoop = mconcat <$> sequence

115 match (App _ (Var _ fn) args) | fn == tcoLoop = mconcat <$> sequence

104 [ return $ emit fn

116 [ return $ emit fn

105 , return $ emit "("

117 , return $ emit "("

106 , intercalate (emit ", ") <$> forM args prettyPrintIL'

118 , intercalate (emit ", ") <$> forM args prettyPrintIL'

107 , return $ emit ")"

119 , return $ emit ")"

108 ]

120 ]

121+ match (App _ (App Nothing (StringLiteral Nothing fnx) [fn@Function{}]) args)

122+ | Just ftype <- decodeString fnx

123+ , "Fn" `T.isPrefixOf` ftype = mconcat <$> sequence

124+ [ prettyPrintIL' fn

125+ , return $ emit "("

126+ , intercalate (emit ", ") <$> forM args prettyPrintIL'

127+ , return $ emit ")"

128+ ]

129+ match (App _ (App Nothing (StringLiteral Nothing fnx) [fn]) args)

130+ | Just ftype <- decodeString fnx

131+ , "Fn" `T.isPrefixOf` ftype = mconcat <$> sequence

132+ [ prettyPrintIL' fn

133+ , return $ emit ".("

134+ , return $ emit ftype

135+ , return $ emit ")("

136+ , intercalate (emit ", ") <$> forM args prettyPrintIL'

137+ , return $ emit ")"

138+ ]

109 match app@(App{})

139 match app@(App{})

110 | (val, args) <- unApp app []

140 | (val, args) <- unApp app []

111 , length args > 1

141 , length args > 1

@@ -175,15 +205,36 @@ literals = mkPattern' match'

175 , prettyPrintIL' (Var Nothing $ withPrefix name)

205 , prettyPrintIL' (Var Nothing $ withPrefix name)

176 , return $ emit "()"

206 , return $ emit "()"

177 ]

207 ]

178− match (Indexer _ prop val) = mconcat <$> sequence

208+ match (Indexer _ prop@StringLiteral{} val@ObjectLiteral{}) = mconcat <$> sequence

179− [ return $ emit "Get("

180− , prettyPrintIL' val

209+ [ prettyPrintIL' val

181− , return $ emit ", "

210+ , return $ emit "["

182 , prettyPrintIL' prop

211 , prettyPrintIL' prop

183− , return $ emit ")"

212+ , return $ emit "]"

213+ ]

214+ match (Indexer _ prop@StringLiteral{} val) = mconcat <$> sequence

215+ [ prettyPrintIL' val

216+ , return $ emit ".("

217+ , return $ emit dictType

218+ , return $ emit ")["

219+ , prettyPrintIL' prop

220+ , return $ emit "]"

221+ ]

222+ match (Indexer _ index val@ArrayLiteral{}) = mconcat <$> sequence

223+ [ prettyPrintIL' val

224+ , return $ emit "["

225+ , prettyPrintIL' index

226+ , return $ emit "]"

227+ ]

228+ match (Indexer _ index val) = mconcat <$> sequence

229+ [ prettyPrintIL' val

230+ , return $ emit ".("

231+ , return $ emit arrayType

232+ , return $ emit ")["

233+ , prettyPrintIL' index

234+ , return $ emit "]"

184 ]

235 ]

185 match (InstanceOf _ val ty) = mconcat <$> sequence

236 match (InstanceOf _ val ty) = mconcat <$> sequence

186− [ return $ emit "Contains("

237+ [ return $ emit "Is("

187 , prettyPrintIL' val

238 , prettyPrintIL' val

188 , return $ emit ", "

239 , return $ emit ", "

189 , prettyPrintIL' ty

240 , prettyPrintIL' ty

@@ -238,8 +289,6 @@ literals = mkPattern' match'

238 -- match (Throw _ _) = return mempty

289 -- match (Throw _ _) = return mempty

239 match (Throw _ value) = mconcat <$> sequence

290 match (Throw _ value) = mconcat <$> sequence

240 [ return $ emit "panic("

291 [ return $ emit "panic("

241− , return $ emit "\"PatternMatchFailure: \""

242− , return $ emit " + "

243 , prettyPrintIL' value

292 , prettyPrintIL' value

244 , return $ emit ")"

293 , return $ emit ")"

245 ]

294 ]

@@ -347,7 +396,7 @@ prettyPrintIL' = A.runKleisli $ runPattern matchValue

347 matchValue = buildPrettyPrinter operators (literals <+> fmap parensPos matchValue)

396 matchValue = buildPrettyPrinter operators (literals <+> fmap parensPos matchValue)

348 operators :: (Emit gen) => OperatorTable PrinterState AST gen

397 operators :: (Emit gen) => OperatorTable PrinterState AST gen

349 operators =

398 operators =

350− OperatorTable [ [ unary New "box" ]

399+ OperatorTable [ [ unary New "?" ]

351 , [ unary Not "!"

400 , [ unary Not "!"

352 , unary BitwiseNot "~"

401 , unary BitwiseNot "~"

353 , unary Positive "+"

402 , unary Positive "+"

@@ -358,8 +407,7 @@ prettyPrintIL' = A.runKleisli $ runPattern matchValue

358 , [ binary Add "+"

407 , [ binary Add "+"

359 , binary Subtract "-" ]

408 , binary Subtract "-" ]

360 , [ binary ShiftLeft "<<"

409 , [ binary ShiftLeft "<<"

361− , binary ShiftRight ">>"

410+ , binary ShiftRight ">>" ]

362− , binary ZeroFillShiftRight ">>>" ]

363 , [ binary LessThan "<"

411 , [ binary LessThan "<"

364 , binary LessThanOrEqualTo "<="

412 , binary LessThanOrEqualTo "<="

365 , binary GreaterThan ">"

413 , binary GreaterThan ">"

@@ -398,19 +446,25 @@ interfaceSource :: Text -> [(Text,Bool)] -> [Ident] -> Text

398interfaceSource _ _ _ = ""

446interfaceSource _ _ _ = ""

399

447

400implHeaderSource :: Text -> [Text] -> Text -> Text

448implHeaderSource :: Text -> [Text] -> Text -> Text

401−implHeaderSource mn imports _ =

449+implHeaderSource mn imports otherPrefix =

402 "// Code generated by psgo. DO NOT EDIT.\n\n" <>

450 "// Code generated by psgo. DO NOT EDIT.\n\n" <>

403− "package " <> (if mn == "Main" then "main" else mn) <> "\n\n" <>

451+ "package " <> (if mn == "Main" || mn == "Test_Main" then "main" else mn) <> "\n\n" <>

404− "import . \"purescript\"\n" <>

452+ "import . \"" <> runtime <> "\"\n" <>

405− (if mn == "Main"

453+ (if mn == "Main" || mn == "Test_Main"

406− then "import \"ffi\"\n"

454+ then "import _ \"" <> otherPrefix <> "/" <> ffiLoader <> "\"\n"

407− else "") <>

455+ else "\n") <>

456+ "import (\n" <>

408− T.concat imports <> "\n" <>

457+ (T.concat $ formatImport <$> imports) <> ")\n\n" <>

409− "type IGNORE_UNUSED_IMPORTS = bool\n" <>

458+ "type _ = Any\n\n"

410− "type _ = IGNORE_UNUSED_RUNTIME\n" <>

459+ where

411− (if mn == "Main"

460+ formatImport :: Text -> Text

412− then "\nconst _ = ffi.Loader\n\n"

461+ formatImport s =

413− else "\n")

462+ "\t\"" <> otherPrefix <> "/" <> modPrefix <> "/" <> moduleRenamer s <> "\"\n"

463+ moduleRenamer :: Text -> Text

464+ moduleRenamer s

465+ | (s', sfx) <- T.breakOn moduleRenamerMarker s,

466+ not $ T.null sfx = s'

467+ moduleRenamer s = s

414

468

415implFooterSource :: Text -> [Ident] -> Text

469implFooterSource :: Text -> [Ident] -> Text

416implFooterSource mn foreigns =

470implFooterSource mn foreigns =

@@ -418,7 +472,7 @@ implFooterSource mn foreigns =

418 (if null foreigns

472 (if null foreigns

419 then ""

473 then ""

420 else ("// Foreign values\n\n" <>

474 else ("// Foreign values\n\n" <>

421− "var " <> foreignDict <> " = " <> dictType <> "{}\n\n" <>

475+ "var " <> foreignDict <> " = "<> foreignMod <> "(\"" <> mn <> "\")\n\n" <>

422 (T.concat $ (\foreign' ->

476 (T.concat $ (\foreign' ->

423 let name = moduleIdentToIL foreign' in

477 let name = moduleIdentToIL foreign' in

424 varDecl <> " " <> initName name <> " Once\n" <>

478 varDecl <> " " <> initName name <> " Once\n" <>

@@ -428,17 +482,17 @@ implFooterSource mn foreigns =

428 "() Any { \n" <>

482 "() Any { \n" <>

429 " " <> initName name <> ".Do(func() {\n" <>

483 " " <> initName name <> ".Do(func() {\n" <>

430 " " <> valueName name <> " = " <>

484 " " <> valueName name <> " = " <>

431− "SafeGet(" <> foreignDict <> ", " <>

485+ "Get(" <> foreignDict <> ", " <>

432− (stringLiteral $ mkString name) <> ")\n" <>

486+ (stringLiteral . mkString $ runIdent foreign') <> ")\n" <>

433 " })\n" <>

487 " })\n" <>

434 " return " <> valueName name <> "\n" <>

488 " return " <> valueName name <> "\n" <>

435 "}\n\n") <$> foreigns))) <>

489 "}\n\n") <$> foreigns))) <>

436− if mn == "Main" then mainSource else "\n"

490+ if mn == "Main" || mn == "Test.Main" then mainSource else "\n"

437 where

491 where

438 mainSource :: Text

492 mainSource :: Text

439 mainSource = "\

493 mainSource = "\

440 \func main() {\n\

494 \func main() {\n\

441− \ Run(PS__main())\n\

495+ \ Run(Ꞌmain())\n\

442 \}\n\n\

496 \}\n\n\

443 \"

497 \"

444

498

@@ -448,11 +502,26 @@ varDecl = "var"

448renderArg :: Text -> Text -> Text

502renderArg :: Text -> Text -> Text

449renderArg decl arg = arg <> " " <> decl

503renderArg decl arg = arg <> " " <> decl

450

504

505+foreignMod :: Text

506+foreignMod = "Foreign"

507+

451foreignDict :: Text

508foreignDict :: Text

452−foreignDict = "Foreign"

509+foreignDict = "foreign"

510+

511+modLabel :: Text

512+modLabel = "purescript-native"

513+

514+modPrefix :: Text

515+modPrefix = modLabel <> "/output"

516+

517+runtime :: Text

518+runtime = "github.com/" <> modLabel <> "/go-runtime"

519+

520+ffiLoader :: Text

521+ffiLoader = modLabel <> "/ffi-loader"

453

522

454initName :: Text -> Text

523initName :: Text -> Text

455−initName s = "ₒ" <> s

524+initName s = "ᛌ" <> s <> "_once"

456

525

457valueName :: Text -> Text

526valueName :: Text -> Text

458−valueName s = "ₐ" <> s

527+valueName s = "ᛧ" <> s

src/Tests.hs+11−12

@@ -31,18 +31,13 @@ runTests = do

31 let srcDir = outputDir </> "src"

32 createDirectory srcDir

33

34− callProcess "git" ["clone", "--branch", "v0.13.0", "--depth", "1", "https://github.com/purescript/purescript.git"]

34+ callProcess "git" ["clone", "--branch", "v0.13.8", "--depth", "1", "https://github.com/purescript/purescript.git"]

35 let passingDir = baseDir </> "purescript" </> "tests" </> "purs" </> "passing"

36 passingTestCases <- sort . filter (".purs" `isSuffixOf`) <$> getDirectoryContents passingDir

37

38 setCurrentDirectory outputDir

39− callProcess "pscpp" ["--makefile"]

40

39

41 fetchPackages

40 fetchPackages

42− callProcess "git" ["clone", "--depth", "1", "https://github.com/andyarvanitis/purescript-cpp-ffi.git", "ffi"]

43−

44− callProcess "rm" ["-rf", ".psc-package/psc-0.13.0/prelude/v4.1.0"]

45− callProcess "git" ["clone", "--branch", "v4.1.1", "--depth", "1", "https://github.com/purescript/purescript-prelude.git", ".psc-package/psc-0.13.0/prelude/v4.1.0"]

46

41

47 let tests = filter (`notElem` skipped) passingTestCases

42 let tests = filter (`notElem` skipped) passingTestCases

48

43

@@ -65,14 +60,15 @@ runTests = do

65 testCaseDirExists <- doesDirectoryExist testCaseDir

60 testCaseDirExists <- doesDirectoryExist testCaseDir

66 when testCaseDirExists $ callProcess "cp" ["-R", testCaseDir, srcDir]

61 when testCaseDirExists $ callProcess "cp" ["-R", testCaseDir, srcDir]

67

62

68− callProcess "make" ["clean"]

63+ callProcess "rm" ["-rf", "output"]

69− callProcess "make" ["debug", "-j8"]

64+ callProcess "rm" ["-rf", "Main"]

65+ callProcess "spago" ["build"]

70 --

66 --

71− -- Run C++ files

67+ -- Run executable file

72 --

68 --

73 outputFile <- openFile (tmp </> logpath </> logfile) AppendMode

69 outputFile <- openFile (tmp </> logpath </> logfile) AppendMode

74 hPutStrLn outputFile ("\n" ++ inputFile ++ ":")

70 hPutStrLn outputFile ("\n" ++ inputFile ++ ":")

75− proc <- runProcess ("output" </> "bin" </> "main") [] Nothing Nothing Nothing (Just outputFile) Nothing

71+ proc <- runProcess ("./" </> "Main") [] Nothing Nothing Nothing (Just outputFile) Nothing

76

72

77 removeFile (srcDir </> inputFile)

73 removeFile (srcDir </> inputFile)

78 when testCaseDirExists $ callProcess "rm" ["-rf", srcDir </> (takeWhile (/='.') inputFile)]

74 when testCaseDirExists $ callProcess "rm" ["-rf", srcDir </> (takeWhile (/='.') inputFile)]

@@ -116,8 +112,11 @@ packages =

116fetchPackages :: IO ()

112fetchPackages :: IO ()

117-------------------------------------------------------------------------------

113-------------------------------------------------------------------------------

118fetchPackages = do

114fetchPackages = do

119− callProcess "psc-package" ["init"]

115+ callProcess "spago" ["init"]

116+ callCommand "sed '$s/\$}\$/, backend = \"psgo\"\\1/' < spago.dhall | dhall format > spago.tmp"

117+ callCommand "mv spago.tmp spago.dhall"

118+

120− mapM (callProcess "psc-package" . (\p -> ["install", p])) packages

119+ mapM (callProcess "spago" . (\p -> ["install", p])) packages

121 return ()

120 return ()

122

121

123-------------------------------------------------------------------------------

122-------------------------------------------------------------------------------

stack.nix+18−3

@@ -1,8 +1,23 @@

1−{ pkgs ? import <nixpkgs> {}, ghc ? pkgs.ghc }:

1+#

2+# You may need to manually run `unset STACK_IN_NIX_SHELL`

3+# (doesn't work from a `shellHook`; see: https://github.com/commercialhaskell/stack/issues/5000

4+#

5+#

6+# You may need to set LC_ALL when building, e.g.

7+# LC_ALL=en_US.iso88591 stack --nix build; see e.g. https://github.com/koalaman/shellcheck/issues/324

8+#

9+#

10+{ pkgs ?

11+ import (builtins.fetchTarball {

12+ name = "nixos-release-19.03";

13+ url = https://github.com/nixos/nixpkgs/archive/34c7eb7545d155cc5b6f499b23a7cb1c96ab4d59.tar.gz;

14+ sha256 = "11z6ajj108fy2q5g8y4higlcaqncrbjm3dnv17pvif6avagw4mcb";

15+ }) {}

16+}:

2

17

3pkgs.haskell.lib.buildStackProject {

18pkgs.haskell.lib.buildStackProject {

4 name = "default-stack-shell";

19 name = "default-stack-shell";

5− inherit ghc;

20+ ghc = pkgs.haskell.compiler.ghc865;

6− buildInputs = with pkgs; [git git-lfs gmp zlib];

21+ buildInputs = with pkgs; [git git-lfs gmp ncurses zlib];

7 LANG = "en_US.UTF-8";

22 LANG = "en_US.UTF-8";

8}

23}

stack.yaml+15−65

@@ -1,74 +1,24 @@

1−# This file was automatically generated by 'stack init'

1+resolver: lts-13.26

2−#

3−# Some commonly used options have been documented as comments in this file.

4−# For advanced use and comprehensive documentation of the format, please see:

5−# https://docs.haskellstack.org/en/stable/yaml_configuration/

6

2

7−# Resolver to choose a 'specific' stackage snapshot or a compiler version.

8−# A snapshot resolver dictates the compiler version and the set of packages

9−# to be used for project dependencies. For example:

10−#

11−# resolver: lts-3.5

12−# resolver: nightly-2015-09-21

13−# resolver: ghc-7.10.2

14−# resolver: ghcjs-0.1.0_ghc-7.10.2

15−# resolver:

16−# name: custom-snapshot

17−# location: "./custom-snapshot.yaml"

18−resolver: lts-13.12

19−

20−# User packages to be built.

21−# Various formats can be used as shown in the example below.

22−#

23−# packages:

24−# - some-directory

25−# - https://example.com/foo/bar/baz-0.0.2.tar.gz

26−# - location:

27−# git: https://github.com/commercialhaskell/stack.git

28−# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a

29−# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a

30−# extra-dep: true

31−# subdirs:

32−# - auto-update

33−# - wai

34−#

35−# A package marked 'extra-dep: true' will only be built if demanded by a

36−# non-dependency (i.e. a user package), and its test suites and benchmarks

37−# will not be run. This is useful for tweaking upstream packages.

38packages:

3packages:

39- .

4- .

40−# Dependency packages to be pulled from upstream that are not in the resolver

5+

41−# (e.g., acme-missiles-0.3)

42extra-deps:

6extra-deps:

43−- git: https://github.com/purescript/purescript

7+- git: https://github.com/purescript/purescript

44− commit: 738aaa2f21097c7f18aa8100b16ae52316addb04

8+ commit: 9cad73ed8ea7df3011032ddbd2f3de5a0c08629c

9+- happy-1.19.9

10+- language-javascript-0.7.0.0

45- network-3.0.1.1

11- network-3.0.1.1

46−- pipes-http-1.0.5

12+- these-1.0.1

47−

13+- semialign-1

48−# Override default flag values for local packages and extra-deps

49−# flags: {}

50−

51−# Extra package databases containing global packages

52−# extra-package-dbs: []

53−

54−# Control whether we use the GHC we find on the path

55−# system-ghc: true

56−#

57−# Require a specific version of stack, using version ranges

58−# require-stack-version: -any # Default

59−# require-stack-version: ">=1.6"

60−#

61−# Override the architecture used by stack, especially useful on Windows

62−# arch: i386

63−# arch: x86_64

64−#

65−# Extra directories used by stack for building

66−# extra-include-dirs: [/path/to/dir]

67−# extra-lib-dirs: [/path/to/dir]

68−#

69−# Allow a newer minor version of GHC than the snapshot specifies

70−# compiler-check: newer-minor

71

14

72nix:

15nix:

16+ enable: false

73 shell-file: stack.nix

17 shell-file: stack.nix

74

18

19+flags:

20+ aeson-pretty:

21+ lib-only: true

22+ these:

23+ assoc: false

24+ quickcheck: false

support/Makefiledeleted−124

@@ -1,124 +0,0 @@

1−# PureScript to native binary (via C++) Makefile

2−#

3−# Run 'make' or 'make release' to build an optimized release build

4−# Run 'make debug' to build a non-optimized build suitable for debugging

5−#

6−# You can also perform a parallel build with 'make -jN', where N is the

7−# number of cores to use.

8−#

9−# PURS, SRC, OUTPUT, and BIN can all be overridden with the

10−# command itself. For example: 'make BIN=myutil'

11−#

12−# Flags can be added to either the codegen or native build phases.

13−# For example: 'make PURSFLAGS=--codegen,js CXXFLAGS=-DDEBUG LDFLAGS=lgmp'

14−#

15−# You can also edit the generated version of this file directly.

16−#

17−PURS := purs

18−PSC_PACKAGE := psc-package

19−PSGO := psgo

20−SRC := src

21−OUTPUT := output

22−CC_SRC := $(OUTPUT)/src

23−FFI_SRC := ffi

24−BIN := main

25−

26−override PURSFLAGS += compile --codegen corefn

27−override CXXFLAGS += --std=c++11

28−

29−DEBUG := "-DDEBUG -g"

30−RELEASE := "-DNDEBUG -O3"

31−

32−INCLUDES := -I $(CC_SRC)

33−BIN_DIR := $(OUTPUT)/bin

34−

35−PACKAGE_SOURCES = $(subst \,/,$(shell $(PSC_PACKAGE) sources))

36−PURESCRIPT_PKGS := $(firstword $(subst /, ,$(PACKAGE_SOURCES)))

37−

38−## Not all environments support globstar (** dir pattern)

39−rwildcard=$(wildcard $1$2) $(foreach d,$(wildcard $1*),$(call rwildcard,$d/,$2))

40−

41−unspecified:

42− @echo

43− @echo "Please specify the type of build you want: 'debug' or 'release'"

44− @echo

45− @echo " debug => not optimized (your app will run slower), good for"

46− @echo " running in a source-level debugger, more (descriptive)"

47− @echo " runtime exceptions"

48− @echo

49− @echo " release => optimized (your app will run faster), less helpful when debugging"

50− @echo

51−

52−debug: codegen

53− go build -o $(BIN_DIR)/$(BIN) $(BIN)

54−

55−release: codegen

56− go build -o $(BIN_DIR)/$(BIN) $(BIN)

57−

58−.PHONY: corefn

59−corefn: PURESCRIPT_PKG_SRCS=$(foreach d,$(PACKAGE_SOURCES),$(call rwildcard,$(firstword $(subst *, ,$(d))),*.purs))

60−corefn: PURESCRIPT_SRCS=$(call rwildcard,$(SRC)/,*.purs)

61−corefn: $(PURESCRIPT_PKGS)

62− @$(PURS) $(PURSFLAGS) --output $(OUTPUT) $(PURESCRIPT_PKG_SRCS) $(PURESCRIPT_SRCS)

63−

64−.PHONY: codegen

65−codegen: COREFN_SRCS=$(call rwildcard,$(OUTPUT)/,corefn.json)

66−codegen: corefn

67− @$(PSGO) $(PSGOFLAGS) $(COREFN_SRCS)

68−

69−$(PURESCRIPT_PKGS):

70− @echo "Getting packages using" $(PSC_PACKAGE) "..."

71− @$(PSC_PACKAGE) update

72−

73−SRCS := $(call rwildcard,$(CC_SRC)/,*.cpp)

74−SRCS += $(call rwildcard,$(FFI_SRC)/,*.cpp)

75−SRCS += $(call rwildcard,$(FFI_SRC)/,*.cc)

76−SRCS += $(call rwildcard,$(FFI_SRC)/,*.mm)

77−SRCS += $(call rwildcard,$(FFI_SRC)/,*.c)

78−SRCS += $(call rwildcard,$(FFI_SRC)/,*.m)

79−

80−OBJS1 = $(SRCS:.cpp=.o)

81−OBJS2 = $(OBJS1:.cc=.o)

82−OBJS3 = $(OBJS2:.mm=.o)

83−OBJS4 = $(OBJS3:.c=.o)

84−OBJS = $(OBJS4:.m=.o)

85−DEPS = $(OBJS:.o=.d)

86−

87−$(BIN): $(OBJS)

88− @echo "Linking" $(BIN_DIR)/$(BIN)

89− @mkdir -p $(BIN_DIR)

90− @$(CXX) $^ -o $(BIN_DIR)/$@ $(LDFLAGS)

91−

92−-include $(DEPS)

93−

94−%.o: %.cpp

95− @echo "Creating" $@ "(C++)"

96− @$(CXX) $(CXXFLAGS) $(INCLUDES) -MMD -MP -c $< -o $@

97−

98−%.o: %.cc

99− @echo "Creating" $@ "(C++)"

100− @$(CXX) $(CXXFLAGS) $(INCLUDES) -MMD -MP -c $< -o $@

101−

102−%.o: %.mm

103− @echo "Creating" $@ "(Objective-C++)"

104− @$(CXX) $(CXXFLAGS) $(INCLUDES) -MMD -MP -c $< -o $@

105−

106−%.o: %.c

107− @echo "Creating" $@ "(C)"

108− @$(CXX) $(CFLAGS) $(INCLUDES) -MMD -MP -c $< -o $@

109−

110−%.o: %.m

111− @echo "Creating" $@ "(Objective-C)"

112− @$(CXX) $(CFLAGS) $(INCLUDES) -MMD -MP -c $< -o $@

113−

114−.PHONY: all

115−all: release

116−

117−.PHONY: clean

118−clean:

119− @-rm -f $(OBJS) $(DEPS)

120− @-rm -rf $(OUTPUT)

121−

122−.PHONY: run

123−run:

124− @$(BIN_DIR)/$(BIN) $(ARGS)

support/ffi-loader.gonew file+30

@@ -0,0 +1,30 @@

1+package ffi_loader

2+

3+// Load PureScript standard library FFI packages. Comment out the ones you don't need for

4+// faster/smaller builds.

5+

6+import (

7+ _ "github.com/purescript-native/go-ffi/purescript-arrays"

8+ _ "github.com/purescript-native/go-ffi/purescript-assert"

9+ _ "github.com/purescript-native/go-ffi/purescript-console"

10+ _ "github.com/purescript-native/go-ffi/purescript-effect"

11+ _ "github.com/purescript-native/go-ffi/purescript-enums"

12+ _ "github.com/purescript-native/go-ffi/purescript-exceptions"

13+ _ "github.com/purescript-native/go-ffi/purescript-foldable-traversable"

14+ _ "github.com/purescript-native/go-ffi/purescript-functions"

15+ _ "github.com/purescript-native/go-ffi/purescript-globals"

16+ _ "github.com/purescript-native/go-ffi/purescript-integers"

17+ _ "github.com/purescript-native/go-ffi/purescript-lazy"

18+ _ "github.com/purescript-native/go-ffi/purescript-math"

19+ _ "github.com/purescript-native/go-ffi/purescript-partial"

20+ _ "github.com/purescript-native/go-ffi/purescript-prelude"

21+ _ "github.com/purescript-native/go-ffi/purescript-random"

22+ _ "github.com/purescript-native/go-ffi/purescript-refs"

23+ _ "github.com/purescript-native/go-ffi/purescript-st"

24+ _ "github.com/purescript-native/go-ffi/purescript-strings"

25+ _ "github.com/purescript-native/go-ffi/purescript-unfoldable"

26+)

27+

28+// Add your own FFI packages here.

29+

30+import ()

support/go.mod.ffi-loadernew file+2

@@ -0,0 +1,2 @@

1+module $PROJECT/purescript-native/ffi-loader

2+

support/go.mod.outputnew file+2

@@ -0,0 +1,2 @@

1+module $PROJECT/purescript-native/output

2+

support/go.mod.workingnew file+1

@@ -0,0 +1 @@

1+module $PROJECT/example