golang..a17d147 · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

on a17d147 help sign in

.gitignore−15

since splitsnapshots

unifiedsplit

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

1dist

2cabal-dev

3−.cabal-sandbox

4−cabal.sandbox.config

5*.o

3*.o

6*.hi

4*.hi

7*.chi

5*.chi

8*.chs.h

6*.chs.h

9*.lksh*

7*.lksh*

10.virthualenv

8.virthualenv

11−.psci_modules/

12−.test_modules/

13−bower_components/

14−node_modules

15−tmp/

16−.stack-work/

17−stack.yaml.lock

18−output

19−examples/docs/docs/

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

21−.psc-ide-port

22−.vscode/

23−result

.travis.ymlnew file+3

@@ -0,0 +1,3 @@

1+language: haskell

2+notifications:

3+ email: false

ChangeLog.mddeleted−3

@@ -1,3 +0,0 @@

1−# Changelog for pscpp

2−

3−## Unreleased changes

LICENSE+16−26

@@ -1,30 +1,20 @@

1+The MIT License (MIT)

5−Redistribution and use in source and binary forms, with or without

5+Permission is hereby granted, free of charge, to any person obtaining a copy of

6+this software and associated documentation files (the "Software"), to deal in

7+the Software without restriction, including without limitation the rights to

8+use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of

9+the Software, and to permit persons to whom the Software is furnished to do so,

6−modification, are permitted provided that the following conditions are met:

10+subject to the following conditions:

8− * Redistributions of source code must retain the above copyright

12+The above copyright notice and this permission notice shall be included in all

9− notice, this list of conditions and the following disclaimer.

13+copies or substantial portions of the Software.

11− * Redistributions in binary form must reproduce the above

15+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR

12− copyright notice, this list of conditions and the following

13− disclaimer in the documentation and/or other materials provided

14− with the distribution.

15−

16− * Neither the name of Author name here nor the names of other

17− contributors may be used to endorse or promote products derived

18− from this software without specific prior written permission.

19−

20−THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS

21−"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT

22−LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR

16+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS

23−A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT

17+FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR

24−OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,

18+COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER

25−SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT

26−LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,

27−DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY

28−THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT

29−(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE

19+IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN

30−OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

20+CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

PureScript.cabalnew file+44

@@ -0,0 +1,44 @@

1+name: Purescript

2+version: 0.0.1

3+cabal-version: >=1.2

4+build-type: Simple

5+license: MIT

6+license-file: LICENSE

7+copyright: (c) Phil Freeman 2013

8+maintainer: Phil Freeman <paf31@cantab.net>

9+stability: experimental

10+synopsis: PureScript Programming Language Compiler

11+description: A small compile-to-JS language with extensible records and type-safe blocks

12+author: Phil Freeman <paf31@cantab.net>

13+data-dir: ""

14+

15+library

16+ build-depends: base -any, syb -any, cmdtheline -any,

17+ containers -any, mtl -any, transformers -any, parsec -any,

18+ utf8-string -any

19+ exposed-modules: PureScript.CodeGen.Pretty.Types PureScript

20+ PureScript.Declarations PureScript.Names

21+ PureScript.TypeChecker.Synonyms PureScript.CodeGen.Externs

22+ PureScript.CodeGen.JS PureScript.CodeGen.Common.Gen

23+ PureScript.CodeGen.Common Main PureScript.CodeGen PureScript.Kinds

24+ PureScript.Parser PureScript.TypeChecker PureScript.Types

25+ PureScript.Values PureScript.Parser.Common

26+ PureScript.Parser.Declarations PureScript.Parser.Types

27+ PureScript.Parser.Values PureScript.TypeChecker.Kinds

28+ PureScript.TypeChecker.Monad PureScript.TypeChecker.Types

29+ PureScript.Parser.State

30+ exposed: True

31+ buildable: True

32+ hs-source-dirs: src

33+ other-modules: PureScript.Parser.Kinds

34+ PureScript.CodeGen.Pretty.Kinds

35+

36+executable psc

37+ build-depends: base -any, cmdtheline -any, containers -any,

38+ mtl -any, transformers -any, parsec -any, utf8-string -any

39+ main-is: Main.hs

40+ buildable: True

41+ hs-source-dirs: src

42+ other-modules: PureScript.Parser.Kinds

43+ PureScript.CodeGen.Pretty.Kinds PureScript.CodeGen.Pretty.Types

44+

README-go.mddeleted−48

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

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+13−37

@@ -1,41 +1,17 @@

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

1+purescript

2+==========

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+[![Build Status](https://secure.travis-ci.org/paf31/purescript.png?branch=master)](http://travis-ci.org/paf31/purescript)

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+A small strongly, statically typed compile-to-JS language with basic extensible records and type-safe blocks

7−#### Platforms

8+## Current Features

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

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

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

14− * Go: `go` version 1.12.7

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

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

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

18− * Default version of `go`

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

21−

10+- Full Type Inference

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

11+- Higher Kinded Polymorphism

23−

12+- Support for basic Javascript types

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/))

13+- Extensible records

25−

14+- Type-safe blocks with for/while/assignment etc.

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

15+- Functions with multiple arguments

27−

16+- Pattern matching

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

17+- Simple FFI

29−

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.

34−

35−

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

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)

39−

40−

41−---

Setup.hsdeleted−2

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

1−import Distribution.Simple

2−main = defaultMain

Setup.lhsnew file+6

@@ -0,0 +1,6 @@

1+#!/usr/bin/runhaskell

2+> module Main where

3+> import Distribution.Simple

4+> main :: IO ()

5+> main = defaultMain

app/Main.hsdeleted−250

@@ -1,250 +0,0 @@

1−{-# LANGUAGE OverloadedStrings #-}

2−{-# LANGUAGE RankNTypes #-}

3−{-# LANGUAGE TemplateHaskell #-}

4−

5−module Main where

6−

7−import Control.Monad (when)

8−import qualified Control.Monad.Parallel as Par

9−import Data.Aeson

10−import Data.Aeson.Types

11−import Data.Char

12−import Data.FileEmbed (embedFile)

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

14−import Data.Maybe

15−import Data.Monoid ((<>))

16−import Data.Version

17−import Control.Monad.Supply

18−import Control.Monad.Supply.Class

19−import Text.Printf

20−

21−import System.Environment

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

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

24−import System.FilePath.Find

25−import System.Process

26−

27−import Data.Text (Text)

28−import qualified Data.Text as T

29−import qualified Data.Text.Encoding as T

30−import qualified Data.Text.Lazy as L

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

32−import qualified Data.ByteString as B

33−

34−import Development.GitRev

35−

36−import Language.PureScript.AST.Literals

37−import Language.PureScript.CoreFn

38−import Language.PureScript.CoreFn.FromJSON

39−

40−import CodeGen.IL

41−import CodeGen.IL.Common

42−import CodeGen.IL.Printer

43−

44−import Tests

45−

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

47−

48−parseJson :: Text -> Value

49−parseJson text

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

51− | otherwise = error "Bad json"

52−

53−jsonToModule :: Value -> Module Ann

54−jsonToModule value =

55− case parse moduleFromJSON value of

56− Success (_, r) -> r

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')

77−

78−main :: IO ()

79−main = do

80− args <- getArgs

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

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

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

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

85− then runTests

86− else do

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

88− then do

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

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

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 =

122− let filepath = takeDirectory (head files) in

123− joinPath $ (init $ splitDirectories filepath)

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

125− generateFiles opts files = do

126− let baseOutpath = basePath files

127− writeSupportFiles baseOutpath

128− Par.mapM (generateCode opts baseOutpath) files

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]

138− return ()

139−

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

141−generateCode opts baseOutpath jsonFile = do

142− jsonModTime <- getModificationTime jsonFile

143− let filepath = takeDirectory jsonFile

144− dirparts = splitDirectories $ filepath

145− mname = last dirparts

146− basedir = joinPath $ init dirparts

147− mname' = T.pack mname

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

149− exists <- doesFileExist possibleFileName

150− if exists

151− then do

152− modTime <- getModificationTime possibleFileName

153− when (modTime < jsonModTime) $

154− transpile opts baseOutpath jsonFile

155− else transpile opts baseOutpath jsonFile

156−

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

158−transpile opts baseOutpath jsonFile = do

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

160− project <- projectEnv

161− let module' = jsonToModule $ parseJson jsonText

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

163− let mn = moduleNameToIL' $ moduleName module'

164− implementation = prettyPrintIL asts

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

166− implPath = outpath </> implFileName mn

167− createDirectoryIfMissing True outpath

168− putStrLn implPath

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

170−

171−writeSupportFiles :: FilePath -> IO ()

172−writeSupportFiles baseOutpath = do

173− currentDir <- getCurrentDirectory

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

175− ffiOutpath = currentDir </> subdir

176− createDirectoryIfMissing True baseOutpath

177− createDirectoryIfMissing True ffiOutpath

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

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

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

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

182− where

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

184− writeModuleFile outputdir path modText = do

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

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

204−

205−implFileName :: Text -> FilePath

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

211−

212−help :: String

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

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

215− \Available options:\n\

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

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

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

219− \ executable\n\

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

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

222− \See also:\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.nixdeleted−23

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

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−}

examples/.gitignorenew file+1

@@ -0,0 +1 @@

1+tests

examples/Arrays.psnew file+13

@@ -0,0 +1,13 @@

1+test1 = \arr -> arr[0] + arr[1]

3+test2 = \arr -> case arr of

4+ [x, y] -> x + y

5+ [x] -> x

6+ [] -> 0

7+ [x, y : _] -> x + y

9+data Tree = One Number | Some [Tree]

10+

11+test3 = \tree, sum -> case tree of

12+ One n -> n

13+ Some [n1, n2 : rest] -> test3(n1, sum) * 10 + test3(n2, sum) * 5 + sum(rest)

examples/Assign.psnew file+5

@@ -0,0 +1,5 @@

1+sum = \n -> do

2+ var x = 0

3+ for i <- 0 until n:

4+ x = x + i

5+ return x

examples/Conditional.psnew file+5

@@ -0,0 +1,5 @@

1+fns = \f -> if f true then f else \x -> x

3+bin = \x -> if x && !x then x else x

5+not = \x -> if x then false else true

examples/Console.jsnew file+19

@@ -0,0 +1,19 @@

1+// data IO a = \ -> a

3+// ret :: forall a. a -> IO a

4+var ret = function(a) {

5+ return function() { return a; };

6+}

8+// (>>=) :: forall a b. IO a -> (a -> IO b) -> IO b

9+var $62$62$61 = function(first) {

10+ return function (f) {

11+ return function () {

12+ var a = first();

13+ return f(a)();

14+ };

15+ };

16+};

17+

18+// putStrLn :: String -> IO {}

19+var putStrLn = function(str) { return function() { console.log(str); return {}; }; };

examples/Console.psnew file+19

@@ -0,0 +1,19 @@

1+data IO a = IO

3+extern ret :: forall a. a -> IO a

5+extern (>>=) :: forall a b. IO a -> (a -> IO b) -> IO b

7+(*>) = \a -> \b -> a >>= \x -> b

9+extern putStrLn :: String -> IO {}

10+

11+replicateM_ :: forall a. Number -> IO a -> IO {}

12+replicateM_ = \n -> \x -> do

13+ var io = ret {}

14+ for i <- 0 until n:

15+ io = x *> io

16+ return io

17+

18+main = replicateM_ 10 (putStrLn "Hello World!")

19+

examples/ExternData.psnew file+13

@@ -0,0 +1,13 @@

1+extern data IO :: * -> *

3+extern fmap :: forall a b. IO a -> (a -> b) -> IO b

5+extern ret :: forall a. a -> IO a

7+extern bind :: forall a b. IO a -> (a -> IO b) -> IO b

9+extern showMessage :: String -> IO { }

10+

11+extern prompt :: IO String

12+

13+main = prompt `bind` \s -> showMessage s

examples/FFI.psnew file+5

@@ -0,0 +1,5 @@

1+extern foo :: (String) -> String

3+bar :: (String) -> String

5+bar = \x -> foo(x ++ "bar")

examples/Foreach.jsnew file+1

@@ -0,0 +1 @@

1+console.log(sum([1,2,3,4,5]));

examples/Foreach.psnew file+5

@@ -0,0 +1,5 @@

1+sum = \ns -> do

2+ var total = 0

3+ foreach n in ns:

4+ total = total + n

5+ return total

examples/Guards.psnew file+3

@@ -0,0 +1,3 @@

1+collatz = \x -> case x of

2+ y | y % 2 == 0 -> y / 2

3+ y -> y * 3 + 1

examples/IfThenElse.psnew file+24

@@ -0,0 +1,24 @@

1+testIf = do

2+ var x = 0

3+ if x == 0:

4+ x = x + 1

5+ return x

7+testIfElse = do

8+ var x = 0

9+ if x == 0:

10+ x = x + 1

11+ else:

12+ x = x - 1

13+ return x

14+

15+testIfElseIf = \x -> do

16+ var y = x

17+ while y > 1:

18+ if y % 3 == 0:

19+ y = y / 3

20+ else if y % 3 == 1:

21+ y = (y - 1) % 3

22+ else:

23+ y = y * 4 + 1

24+ return y

examples/List.jsnew file+7

@@ -0,0 +1,7 @@

1+var l1 = Cons({ head: 1, tail: Nil });

2+var l2 = Cons({ head: 2, tail: Nil });

3+var l3 = Cons({ head: l1, tail: Cons({ head: l2, tail: Nil }) });

4+var flat = flatten(l3);

5+var f1 = flat.value.head;

6+var f2 = flat.value.tail.value.head

7+console.log([f1, f2]);

examples/List.psnew file+22

@@ -0,0 +1,22 @@

1+data List a

2+ = Nil

3+ | Cons

4+ { head :: a

5+ ; tail :: List a

6+ }

8+isNull = \l -> case l of

9+ Nil -> true

10+ _ -> false

11+

12+concat = \l1 -> \l2 -> case l1 of

13+ Nil -> l2

14+ Cons x -> Cons

15+ { head: x.head

16+ , tail: concat x.tail l2

17+ }

18+

19+flatten = \xss -> case xss of

20+ Nil -> Nil

21+ Cons cons -> concat cons.head (flatten cons.tail)

22+

examples/Match.psnew file+3

@@ -0,0 +1,3 @@

1+data Foo a = Foo

3+foo = \f -> case f of Foo -> "foo"

examples/Maybe.jsnew file+5

@@ -0,0 +1,5 @@

1+console.log(bind(Just("a"))(function(a) {

2+ return bind(Just("b"))(function(b) {

3+ return Just(a + b);

4+ });

5+}));

examples/Maybe.psnew file+10

@@ -0,0 +1,10 @@

1+data Maybe a = Nothing | Just a

3+maybe :: forall a b. b -> (a -> b) -> Maybe a -> b

4+maybe = \b -> \f -> \m -> case m of

5+ Nothing -> b

6+ Just a -> f a

8+fmap = \m -> \f -> maybe Nothing (\a -> Just (f a)) m

10+bind = \m -> \f -> maybe Nothing f m

examples/NamedPatterns.psnew file+6

@@ -0,0 +1,6 @@

1+foo = \x -> case x of

2+ y@{ foo = "Foo" } -> y

3+ y -> (do

4+ var copy = y

5+ copy.foo = "Bar"

6+ return copy)

examples/Nested.psnew file+3

@@ -0,0 +1,3 @@

1+data Extend r a = Extend { prev :: r a; next :: a }

3+data Matrix r a = Square (r (r a)) | Bigger (Matrix (Extend r) a)

examples/Objects.psnew file+9

@@ -0,0 +1,9 @@

1+test = \x -> x.foo + x.bar

3+append = \o -> { foo: o.foo, bar: 1 }

5+apTest = append({foo : "Foo", baz: "Baz"})

7+f = (\a -> a.b.c) { b: { c: 1, d: "Hello" }, e: "World" }

9+g = (\a -> a.f { x: 1, y: "y" }) { f: \o -> o.x + 1 }

examples/Operators.psnew file+21

@@ -0,0 +1,21 @@

1+test1 = \x, y, z -> x * y + z(x)(y)

3+test2 = (\x -> x.foo false) { foo : \_ -> 1 }

5+test3 = (\x, y -> x)(1 + 2 * (1 + 2), true && (false || false))

7+k = \x -> \y -> x

9+test4 = 1 `k` 2

10+

11+infixl 5 %%

12+

13+(%%) = \x -> \y -> x * y + y

14+

15+test5 = 1 %% 2 %% 3

16+

17+test6 = ((\x -> x) `k` 2) 3

18+

19+(<>) = \s1 -> \s2 -> s1 ++ s2

20+

21+test7 = "Hello" <> "World!"

examples/Patterns.psnew file+8

@@ -0,0 +1,8 @@

1+test = \x -> case x of

2+ { str = "Foo", bool = true } -> true

3+ { str = "Bar", bool = b } -> b

4+ _ -> false

6+f = \o -> case o of

7+ { foo = "Foo" } -> o.bar

8+ _ -> 0

examples/Person.psnew file+7

@@ -0,0 +1,7 @@

1+data Person = Person { name :: String; age :: Number }

3+extern itoa :: Number -> String

5+showPerson :: Person -> String

6+showPerson = \p -> case p of

7+ Person o -> o.name ++ ", aged " ++ itoa(o.age)

examples/Recursion.psnew file+4

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

1+fib = \n -> case n of

2+ 0 -> 1

3+ 1 -> 1

4+ n -> fib (n - 1) + fib (n - 2)

examples/TypeDecl.psnew file+12

@@ -0,0 +1,12 @@

1+id :: forall a. (a) -> a

2+id = \x -> x

4+k :: String -> Number -> String

5+k = \x -> \y -> x

7+iterate :: forall a. Number -> (a -> a) -> a -> a

8+iterate = \n -> \f -> \a -> do

9+ var result = a

10+ for i <- 0 until n:

11+ result = f result

12+ return result

examples/TypeSynonyms.psnew file+29

@@ -0,0 +1,29 @@

1+type Lens a b =

2+ { get :: a -> b

3+ ; set :: a -> b -> a

4+ }

6+composeLenses :: forall a b c. Lens a b -> Lens b c -> Lens a c

7+composeLenses = \l1 -> \l2 ->

8+ { get: \a -> l2.get (l1.get a)

9+ , set: \a -> \c -> do

10+ var b = l1.get a

11+ var b1 = l2.set b c

12+ return l1.set a b1

13+ }

14+

15+type Pair a b = { fst :: a; snd :: b }

16+

17+fst :: forall a b. Lens (Pair a b) a

18+fst = {

19+ get: \p -> p.fst,

20+ set: \p -> \a -> { fst: a, snd: p.snd }

21+}

22+

23+test1 :: forall a b c. Lens (Pair (Pair a b) c) a

24+test1 = composeLenses fst fst

25+

26+extern head :: forall a. Lens [a] a

27+

28+test2 :: forall a b c. Lens (Pair [Pair a b] c) a

29+test2 = composeLenses fst (composeLenses head fst)

examples/failing/KindError.psnew file+1

@@ -0,0 +1 @@

1+data KindError f g a = One f a | Two f

examples/failing/ReadShow.psnew file+5

@@ -0,0 +1,5 @@

1+extern read :: forall a. String -> a

3+extern show :: forall a. a -> String

5+test = \x -> show (read x)

examples/failing/TypeError.psnew file+1

@@ -0,0 +1 @@

1+test = \f -> \x, y, z -> f x y + f x y z

examples/iota.psnew file+5

@@ -0,0 +1,5 @@

1+s = \x -> \y -> \z -> x z (y z)

3+k = \x -> \y -> x

5+iota = \x -> x s k

examples/runAll.testnew file+23

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

1+# Maybe

2+mkdir -p tests && ../dist/build/psc/psc Maybe.ps -o tests/Maybe.js && cat tests/Maybe.js Maybe.js | node

3+<<<

4+>>>

5+{ ctor: 'Just', value: 'ab' }

6+>>>2

7+>>>= 0

9+# List

10+mkdir -p tests && ../dist/build/psc/psc List.ps -o tests/List.js && cat tests/List.js List.js | node

11+<<<

12+>>>

13+[ 1, 2 ]

14+>>>2

15+>>>= 0

16+

17+# Foreach

18+mkdir -p tests && ../dist/build/psc/psc Foreach.ps -o tests/Foreach.js && cat tests/Foreach.js Foreach.js | node

19+<<<

20+>>>

21+15

22+>>>2

23+>>>= 0

examples/runMain.jsnew file+1

@@ -0,0 +1 @@

1+main();

examples/s.psnew file+1

@@ -0,0 +1 @@

1+s = \x, y, z -> x z (y z)

package.yamldeleted−86

@@ -1,86 +0,0 @@

1−name: psgo

2−version: 0.1.0.0

3−github: "andyarvanitis/purescript-native"

4−license: BSD3

5−author: "Andy Arvanitis"

6−maintainer: "example@example.com"

7−copyright: "2018 Andy Arvanitis"

8−

9−extra-source-files:

10−- README.md

11−- ChangeLog.md

12−- stack.yaml

13−- support/*

14−

15−# Metadata used when publishing your package

16−# synopsis: Short description of your package

17−# category: Web

18−

19−# To avoid duplicated efforts in documentation and dealing with the

20−# complications of embedding Haddock markup inside cabal files, it is

21−# common to point users to the README.md file.

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

23−

24−dependencies:

25−- base >= 4.7 && < 5

26−- bytestring >= 0.10.8.2 && < 0.11

27−- purescript

28−- base-compat >=0.6.0

29−- protolude >=0.1.6

30−- text

31−- containers

32−- filepath

33−- monad-parallel >= 0.7.2.2 && <0.8

34−- pattern-arrows >=0.0.2 && <0.1

35−- safe >=0.3.9 && <0.4

36−- transformers >=0.3.0 && <0.6

37−- mtl >=2.1.0 && <2.3.0

38−- aeson >=1.0 && <1.5

39−- directory

40−- process

41−- file-embed

42−- filemanip

43−- gitrev

44−

45−library:

46− source-dirs: src

47− default-extensions:

48− - ConstraintKinds

49− - DataKinds

50− - DeriveFunctor

51− - EmptyDataDecls

52− - FlexibleContexts

53− - KindSignatures

54− - LambdaCase

55− - MultiParamTypeClasses

56− - NoImplicitPrelude

57− - PatternGuards

58− - PatternSynonyms

59− - RankNTypes

60− - RecordWildCards

61− - OverloadedStrings

62− - ScopedTypeVariables

63− - TupleSections

64− - ViewPatterns

65−

66−executables:

67− psgo:

68− main: Main.hs

69− source-dirs: app

70− ghc-options:

71− - -threaded

72− - -rtsopts

73− - -with-rtsopts=-N

74− dependencies:

75− - psgo

76−

77−tests:

78− psgo-test:

79− main: Spec.hs

80− source-dirs: test

81− ghc-options:

82− - -threaded

83− - -rtsopts

84− - -with-rtsopts=-N

85− dependencies:

86− - psgo

psgo.cabaldeleted−145

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

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

src/CodeGen/IL.hsdeleted−321

@@ -1,321 +0,0 @@

1−-- | This module generates code in the core imperative representation from

2−-- elaborated PureScript code.

3−module CodeGen.IL

4− ( module AST

5− , module Common

6− , moduleToIL

7− ) where

8−

9−import Prelude.Compat

10−import Protolude (ordNub)

11−

12−import Control.Arrow ((&&&))

13−import Control.Monad (forM, liftM, replicateM, void)

14−import Control.Monad.Supply.Class

15−

16−import Data.List ((\\), delete, intersect, nub)

17−import qualified Data.Foldable as F

18−import qualified Data.Map as M

19−import Data.Maybe (fromMaybe, isNothing, mapMaybe)

20−import Data.Monoid ((<>))

21−import Data.String (fromString)

22−import Data.Text (Text)

23−import qualified Data.Text as T

24−

25−import Language.PureScript.AST.SourcePos

26−import Language.PureScript.CoreImp.AST (AST)

27−import qualified Language.PureScript.CoreImp.AST as AST

28−import Language.PureScript.CoreFn

29−import Language.PureScript.Crash

30−import Language.PureScript.Names

31−import Language.PureScript.Options

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

33−import Language.PureScript.Traversals (sndM)

34−import qualified Language.PureScript.Constants as C

35−

36−import System.FilePath.Posix ((</>))

37−

38−import CodeGen.IL.Common as Common

39−import CodeGen.IL.Optimizer

40−import CodeGen.IL.Printer

41−

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

43−

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

45−-- module.

46−moduleToIL

47− :: forall m

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

49− . (Monad m, MonadSupply m)

50− => Module Ann

51− -> Text

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

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

54− do

55− ilDecls <- mapM (bindToIL ModuleDecl) decls

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

57− let optimized' = concat optimized

58− values = annotValue <$> optimized'

59− foreigns' = moduleIdentToIL <$> foreigns

60− interface = interfaceSource modName values foreigns

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

62− implHeader = implHeaderSource modName imports project

63− implFooter = implFooterSource (runModuleName mn) foreigns

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

65− where

66− modName = moduleNameToIL mn

67− modName' = AST.Var Nothing modName

68−

69− annotValue :: AST -> (Text, Bool)

70− annotValue (AST.Function _ (Just name) [] (AST.Block _ [AST.Return _ ret]))

71− | isLiteral ret = (name, True)

72− annotValue (AST.Function _ (Just name) [] _) = (name, False)

73− annotValue _ = error "Unexpected top-level value form"

74−

75− -- | Extracts all declaration names from a binding group.

76− getNames :: Bind Ann -> [Ident]

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

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

79−

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

81− --

82− importToIL :: AST -> [Text]

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

84− where

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

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

87− modRef _ = []

88− extract :: Text -> Text

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

90−

91− -- |

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

93− --

94− bindToIL :: DeclType -> Bind Ann -> m [AST]

95− bindToIL dt (NonRec ann ident val) = return <$> nonRecToIL dt ann ident val

96− bindToIL dt (Rec vals) = forM vals (uncurry . uncurry $ nonRecToIL dt')

97− where

98− dt' = if dt == LetDecl then RecLetDecl else dt

99−

100− -- | Generate code in the simplified intermediate representation for a single non-recursive

101− -- declaration.

102− --

103− -- The main purpose of this function is to handle code generation for comments.

104− nonRecToIL :: DeclType -> Ann -> Ident -> Expr Ann -> m AST

105− nonRecToIL dt a i e@(extractAnn -> (_, com, _, _)) | not (null com) = do

106− -- withoutComment <- asks optionsNoComments

107− let withoutComment = False

108− if withoutComment

109− then nonRecToIL dt a i (modifyAnn removeComments e)

110− else AST.Comment Nothing com <$> nonRecToIL dt a i (modifyAnn removeComments e)

111− nonRecToIL ModuleDecl (ss, _, _, _) ident val = do

112− il <- valueToIL val

113− pure $ AST.Function Nothing (Just $ moduleIdentToIL ident) [] (AST.Block Nothing [AST.Return Nothing il])

114− nonRecToIL RecLetDecl (ss, _, _, _) ident val = do

115− ilExpr <- valueToIL val

116− pure $ AST.Assignment Nothing (AST.Var Nothing $ identToIL ident) ilExpr

117− nonRecToIL _ (ss, _, _, _) ident val = do

118− il <- valueToIL val

119− pure $ AST.VariableIntroduction Nothing (identToIL ident) (Just il)

120−

121− -- | Generate code in the simplified intermediate representation for a variable based on a

122− -- PureScript identifier.

123− var :: Ident -> AST

124− var = AST.Var Nothing . identToIL

125−

126− accessorString :: PSString -> AST -> AST

127− accessorString prop = AST.Indexer Nothing (AST.StringLiteral Nothing prop)

128−

129− -- | Generate code in the simplified intermediate representation for a value or expression.

130−

131− valueToIL :: Expr Ann -> m AST

132− valueToIL (Literal (pos, _, _, _) l) = literalToValueIL pos l

133− valueToIL (Accessor _ prop val) =

134− accessorString prop <$> valueToIL val

135− valueToIL (ObjectUpdate _ o ps) = do

136− obj <- valueToIL o

137− updates <- mapM (sndM valueToIL) ps

138− obj' <- freshName'

139− let objVar = AST.Var Nothing obj'

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

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

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

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

144− valueToIL (Abs _ arg val) = do

145− ret <- valueToIL val

146− let ilArg = case arg of

147− UnusedIdent -> []

148− _ -> [identToIL arg]

149− return $ AST.Function Nothing Nothing ilArg (AST.Block Nothing [AST.Return Nothing ret])

150− valueToIL e@App{} = do

151− let (f, args) = unApp e []

152− args' <- mapM valueToIL args

153− fn <- valueToIL f

154− case f of

155− Var (_, _, _, Just IsNewtype) _ -> return (head args')

156− _ -> flip (foldl (\fn a -> AST.App Nothing fn [a])) args' <$> valueToIL f

157− where

158− unApp :: Expr Ann -> [Expr Ann] -> (Expr Ann, [Expr Ann])

159− unApp (App _ val arg) args = unApp val (arg : args)

160− unApp other args = (other, args)

161− valueToIL (Var _ ident) = return $ varToIL ident

162− valueToIL (Case (ss, _, _, _) values binders) = do

163− vals <- mapM valueToIL values

164− bindersToIL ss binders vals

165− valueToIL (Let _ ds val) = do

166− let recurs = concatMap getNames $ filter isRec ds

167− recurDs = (\v -> AST.VariableIntroduction Nothing (identToIL v) Nothing) <$> recurs

168− ds' <- concat <$> mapM (bindToIL LetDecl) ds

169− ret <- valueToIL val

170− return $ AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing (recurDs ++ ds' ++ [AST.Return Nothing ret]))) []

171− where

172− isRec :: Bind Ann -> Bool

173− isRec (Rec _) = True

174− isRec _ = False

175− valueToIL (Constructor (_, _, _, Just IsNewtype) _ (ProperName ctor) _) = error "IsNewtype"

176− valueToIL (Constructor _ _ (ProperName ctor) fields) =

177− let body = AST.ObjectLiteral Nothing $ (mkString ctor, AST.BooleanLiteral Nothing True) :

178− ((\field -> (mkString (identToIL field), var field)) `map` fields)

179− fn = foldr (\f inner -> AST.Function Nothing Nothing [identToIL f] (AST.Block Nothing [AST.Return Nothing inner])) body fields

180− in return fn

181−

182−

183− iife :: Text -> [AST] -> AST

184− iife v exprs = AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing $ exprs ++ [AST.Return Nothing $ AST.Var Nothing v])) []

185−

186− literalToValueIL :: SourceSpan -> Literal (Expr Ann) -> m AST

187− literalToValueIL ss (NumericLiteral (Left i)) = return $ AST.NumericLiteral (Just ss) (Left i)

188− literalToValueIL ss (NumericLiteral (Right n)) = return $ AST.NumericLiteral (Just ss) (Right n)

189− literalToValueIL ss (StringLiteral s) = return $ AST.StringLiteral (Just ss) s

190− literalToValueIL ss (CharLiteral c) = return $ AST.StringLiteral (Just ss) (fromString [c])

191− literalToValueIL ss (BooleanLiteral b) = return $ AST.BooleanLiteral (Just ss) b

192− literalToValueIL ss (ArrayLiteral xs) = AST.ArrayLiteral (Just ss) <$> mapM valueToIL xs

193− literalToValueIL ss (ObjectLiteral ps) = AST.ObjectLiteral (Just ss) <$> mapM (sndM valueToIL) ps

194−

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

196− -- variable.

197− varToIL :: Qualified Ident -> AST

198− varToIL (Qualified Nothing ident) = var ident

199− varToIL qual = qualifiedToIL id qual

200−

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

202− -- variable that may have a qualified name.

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

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

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

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

207−

208− -- foreignIdent :: Ident -> AST

209− -- foreignIdent ident = accessorString (mkString $ runIdent ident) (AST.Var Nothing "$foreign")

210−

211− -- | Generate code in the simplified intermediate representation for pattern match binders

212− -- and guards.

213− bindersToIL :: SourceSpan -> [CaseAlternative Ann] -> [AST] -> m AST

214− bindersToIL ss binders vals = do

215− valNames <- replicateM (length vals) freshName'

216− let assignments = zipWith (AST.VariableIntroduction Nothing) valNames (map Just vals)

217− ils <- forM binders $ \(CaseAlternative bs result) -> do

218− ret <- guardsToIL result

219− go valNames ret bs

220− return $ AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing (assignments ++ concat ils ++ [AST.Throw Nothing (AST.StringLiteral Nothing $ mkString failedPatternMessage)])))

221− []

222− where

223− go :: [Text] -> [AST] -> [Binder Ann] -> m [AST]

224− go _ done [] = return done

225− go (v:vs) done' (b:bs) = do

226− done'' <- go vs done' bs

227− binderToIL v done'' b

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

229−

230− failedPatternMessage :: Text

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

232−

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

234− guardsToIL (Left gs) = traverse genGuard gs where

235− genGuard (cond, val) = do

236− cond' <- valueToIL cond

237− val' <- valueToIL val

238− return

239− (AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo cond' (AST.BooleanLiteral Nothing True))

240− (AST.Block Nothing [AST.Return Nothing val']) Nothing)

241−

242− guardsToIL (Right v) = return . AST.Return Nothing <$> valueToIL v

243−

244− -- | Generate code in the simplified intermediate representation for a pattern match

245− -- binder.

246− binderToIL :: Text -> [AST] -> Binder Ann -> m [AST]

247− binderToIL _ done NullBinder{} = return done

248− binderToIL varName done (LiteralBinder _ l) =

249− literalToBinderIL varName done l

250− binderToIL varName done (VarBinder _ ident) =

251− return (AST.VariableIntroduction Nothing (identToIL ident) (Just (AST.Var Nothing varName)) : done)

252− binderToIL varName done (ConstructorBinder (_, _, _, Just IsNewtype) _ _ [b]) =

253− binderToIL varName done b

254− binderToIL varName done (ConstructorBinder (_, _, _, Just (IsConstructor ctorType fields)) _ (Qualified _ (ProperName ctor)) bs) = do

255− il <- go (zip fields bs) done

256− return $ case ctorType of

257− ProductType -> il

258− SumType ->

259− [AST.IfElse Nothing (AST.InstanceOf Nothing (AST.Var Nothing varName) (AST.StringLiteral Nothing (mkString ctor)))

260− (AST.Block Nothing il)

261− Nothing]

262− where

263− go :: [(Ident, Binder Ann)] -> [AST] -> m [AST]

264− go [] done' = return done'

265− go ((field, binder) : remain) done' = do

266− argVar <- freshName'

267− done'' <- go remain done'

268− il <- binderToIL argVar done'' binder

269− return (AST.VariableIntroduction Nothing argVar (Just $ accessorString (mkString $ identToIL field) $ AST.Var Nothing varName) : il)

270−

271− binderToIL _ _ ConstructorBinder{} =

272− internalError "binderToIL: Invalid ConstructorBinder in binderToIL"

273− binderToIL varName done (NamedBinder _ ident binder) = do

274− il <- binderToIL varName done binder

275− return (AST.VariableIntroduction Nothing (identToIL ident) (Just (AST.Var Nothing varName)) : il)

276−

277− literalToBinderIL :: Text -> [AST] -> Literal (Binder Ann) -> m [AST]

278− literalToBinderIL varName done (NumericLiteral num) =

279− return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.NumericLiteral Nothing num)) (AST.Block Nothing done) Nothing]

280− literalToBinderIL varName done (CharLiteral c) =

281− return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.StringLiteral Nothing (fromString [c]))) (AST.Block Nothing done) Nothing]

282− literalToBinderIL varName done (StringLiteral str) =

283− return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.StringLiteral Nothing str)) (AST.Block Nothing done) Nothing]

284− literalToBinderIL varName done (BooleanLiteral True) =

285− return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.BooleanLiteral Nothing True)) (AST.Block Nothing done) Nothing]

286− literalToBinderIL varName done (BooleanLiteral False) =

287− return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.BooleanLiteral Nothing False)) (AST.Block Nothing done) Nothing]

288− -- return [AST.IfElse Nothing (AST.Unary Nothing AST.Not (AST.Var Nothing varName)) (AST.Block Nothing done) Nothing]

289− literalToBinderIL varName done (ObjectLiteral bs) = go done bs

290− where

291− go :: [AST] -> [(PSString, Binder Ann)] -> m [AST]

292− go done' [] = return done'

293− go done' ((prop, binder):bs') = do

294− propVar <- freshName'

295− done'' <- go done' bs'

296− il <- binderToIL propVar done'' binder

297− return (AST.VariableIntroduction Nothing propVar (Just (accessorString prop (AST.Var Nothing varName))) : il)

298− literalToBinderIL varName done (ArrayLiteral bs) = do

299− il <- go done 0 bs

300− return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo

301− (arrayLength $ AST.Var Nothing varName)

302− (AST.NumericLiteral Nothing (Left (fromIntegral $ length bs))))

303− (AST.Block Nothing il) Nothing]

304− where

305− go :: [AST] -> Integer -> [Binder Ann] -> m [AST]

306− go done' _ [] = return done'

307− go done' index (binder:bs') = do

308− elVar <- freshName'

309− done'' <- go done' (index + 1) bs'

310− il <- binderToIL elVar done'' binder

311− return (AST.VariableIntroduction Nothing elVar (Just (AST.Indexer Nothing (AST.NumericLiteral Nothing (Left index)) (AST.Var Nothing varName))) : il)

312−

313−emptyAnn :: Ann

314−emptyAnn = (SourceSpan "" (SourcePos 0 0) (SourcePos 0 0), [], Nothing, Nothing)

315−

316−arrayLength :: AST -> AST

317−arrayLength a = AST.App Nothing (AST.Var Nothing arrayLengthFn) [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.hsdeleted−196

@@ -1,196 +0,0 @@

1−-- | Common code generation utility functions

2−module CodeGen.IL.Common where

3−

4−import Prelude.Compat

5−

6−import Control.Monad.Supply.Class (MonadSupply, freshName)

7−import Data.Char

8−import Data.Maybe (maybe)

9−import Data.Monoid ((<>))

10−import Data.Text (Text)

11−import qualified Data.Text as T

12−

13−import Language.PureScript.Crash

14−import Language.PureScript.Names

15−

16−import qualified Language.PureScript.Constants as C

17−

18−moduleNameToIL :: ModuleName -> Text

19−moduleNameToIL (ModuleName mn) =

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

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

22−

23−moduleNameToIL' :: ModuleName -> Text

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

25−

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

27−--

28−-- * Alphanumeric characters are kept unmodified.

29−--

30−-- * Reserved IL identifiers are wrapped with '_'.

31−--

32−identToIL :: Ident -> Text

33−identToIL UnusedIdent = unusedName

34−identToIL (Ident "$__unused") = unusedName

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

36−identToIL (Ident name) = properToIL name

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

38−

39−moduleIdentToIL :: Ident -> Text

40−moduleIdentToIL UnusedIdent = unusedName

41−moduleIdentToIL (Ident name) | name == C.undefined = undefinedName

42−moduleIdentToIL (Ident name) = moduleProperToIL name

43−moduleIdentToIL (GenIdent _ _) = internalError "GenIdent in identToIL"

44−

45−undefinedName :: Text

46−undefinedName = "Undefined"

47−

48−unusedName :: Text

49−unusedName = "_"

50−

51−properToIL :: Text -> Text

52−properToIL name

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

54− | otherwise = T.concatMap identCharToText name

55−

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

57−-- ordinal value.

58−identCharToText :: Char -> Text

59−identCharToText 'ṩ' = "_ṩ"

60−identCharToText c | isAlphaNum c = T.singleton c

61−identCharToText '_' = "_"

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

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

64−

65−moduleProperToIL :: Text -> Text

66−moduleProperToIL = T.concatMap identCharToText

67−

68−-- | Checks whether an identifier name is reserved in IL.

69−nameIsILReserved :: Text -> Bool

70−nameIsILReserved name =

71− name `elem` ilAnyReserved

72−

73−-- | Checks whether a name matches a built-in value in IL.

74−nameIsILBuiltIn :: Text -> Bool

75−nameIsILBuiltIn name =

76− name `elem`

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"

92− ]

93−

94−ilAnyReserved :: [Text]

95−ilAnyReserved =

96− concat

97− [ ilKeywords

98− , ilLiterals

99− ]

100−

101−ilKeywords :: [Text]

102−ilKeywords =

103− [ "break"

104− , "case"

105− , "chan"

106− , "const"

107− , "continue"

108− , "default"

109− , "defer"

110− , "else"

111− , "fallthrough"

112− , "for"

113− , "func"

114− , "go"

115− , "goto"

116− , "if"

117− , "import"

118− , "interface"

119− , "map"

120− , "package"

121− , "range"

122− , "return"

123− , "select"

124− , "struct"

125− , "switch"

126− , "type"

127− , "var"

128− ]

129−

130−ilLiterals :: [Text]

131−ilLiterals =

132− [ "init"

133− , "nil"

134− , "int"

135− , "int8"

136− , "int16"

137− , "int32"

138− , "int64"

139− , "uint"

140− , "uint8"

141− , "uint16"

142− , "uint32"

143− , "uint64"

144− , "uintptr"

145− , "float32"

146− , "float64"

147− , "complex64"

148− , "complex128"

149− , "byte"

150− , "rune"

151− , "string"

152− ]

153−

154−withPrefix :: Text -> Text

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

156−

157−anyType :: Text

158−anyType = "Any"

159−

160−dictType :: Text

161−dictType = "Dict"

162−

163−arrayType :: Text

164−arrayType = "[]" <> anyType

165−

166−uncurriedFnType :: Int -> Text

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

168−

169−int :: Text

170−int = "int"

171−

172−float :: Text

173−float = "float64"

174−

175−bool :: Text

176−bool = "bool"

177−

178−string :: Text

179−string = "string"

180−

181−arrayLengthFn :: Text

182−arrayLengthFn = "Length"

183−

184−indexFn :: Text

185−indexFn = "Index"

186−

187−copyDictFn :: Text

188−copyDictFn = "CopyDict"

189−

190−freshName' :: MonadSupply m => m Text

191−freshName' = do

192− name <- freshName

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

194−

195−moduleRenamerMarker :: Text

196−moduleRenamerMarker = "__"

src/CodeGen/IL/Optimizer.hsdeleted−81

@@ -1,81 +0,0 @@

1−-- | This module optimizes code in the intermediate representation.

2−module CodeGen.IL.Optimizer (optimize) where

3−

4−import Prelude.Compat

5−

6−import Control.Monad.Supply.Class (MonadSupply)

7−import Data.Text (Text)

8−import Language.PureScript.CoreImp.AST

9−import Language.PureScript.CoreImp.Optimizer.Blocks

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

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

12−import Language.PureScript.CoreImp.Optimizer.Unused

13−

14−import CodeGen.IL.Common (unusedName)

15−import CodeGen.IL.Optimizer.Inliner

16−import CodeGen.IL.Optimizer.MagicDo

17−import CodeGen.IL.Optimizer.TCO

18−

19−import qualified Language.PureScript.Constants as C

20−

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

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

23−optimize mn il = do

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

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

26− =<< untilFixedPoint (return . magicDoST)

27− =<< untilFixedPoint (return . magicDoEff)

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

29− untilFixedPoint (return . collapseVarDeclarations) il''

30− where

31− tidyUp :: AST -> AST

32− tidyUp = applyAll

33− [ collapseNestedBlocks

34− , collapseNestedIfs

35− , collapseIfChecks

36− , removeCodeAfterReturnStatements

37− , unThunk

38− , etaConvert

39− , evaluateIifes

40− , inlineVariables

41− ]

42−

43−untilFixedPoint :: (Monad m, Eq a) => (a -> m a) -> a -> m a

44−untilFixedPoint f = go

45− where

46− go a = do

47− a' <- f a

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

49−

50−collapseIfChecks :: AST -> AST

51−collapseIfChecks = everywhere collapse where

52− collapse :: AST -> AST

53− collapse (IfElse _ (Binary _ EqualTo (BooleanLiteral _ True) (BooleanLiteral _ True)) (Block _ [exprs]) _) = exprs

54− collapse (IfElse _ (Binary _ EqualTo (Indexer _ (Var _ prop) (Var _ val)) (BooleanLiteral _ True)) (Block _ [exprs]) _)

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

56− collapse exprs = exprs

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

70−

71−ignoreUnusedResults :: AST -> AST

72−ignoreUnusedResults = everywhere $ removeFromBlock go

73− where

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

75− go [] = []

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

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

78− where

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

80− | otherwise = go sts

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

src/CodeGen/IL/Optimizer/Common.hsdeleted−18

@@ -1,18 +0,0 @@

1−-- | Common functions used by the various optimizer phases

2−module CodeGen.IL.Optimizer.Common where

3−

4−import Prelude.Compat

5−

6−import Data.Text (Text)

7−

8−import Language.PureScript.CoreImp.AST

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

10−

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

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

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

14−isDict _ _ = False

15−

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

17−isDict' xs il = any (`isDict` il) xs

18−

src/CodeGen/IL/Optimizer/Inliner.hsdeleted−435

@@ -1,435 +0,0 @@

1−-- | This module performs basic inlining of known functions

2−module CodeGen.IL.Optimizer.Inliner

3− ( inlineCommonValues

4− , inlineCommonOperators

5− , inlineFnComposition

6− , inlineUnsafeCoerce

7− , inlineUnsafePartial

8− ) where

9−

10−import Prelude.Compat

11−

12−import Control.Monad.Supply.Class (MonadSupply)

13−

14−import Data.Either (rights)

15−import Data.Maybe (fromMaybe)

16−import Data.String (IsString, fromString)

17−import Data.Text (Text)

18−import qualified Data.Text as T

19−

20−import Language.PureScript.PSString (PSString, decodeString, mkString)

21−import Language.PureScript.CoreImp.AST

22−import Language.PureScript.CoreImp.Optimizer.Common hiding (isDict, isDict')

23−import Language.PureScript.AST (SourceSpan(..))

24−import qualified Language.PureScript.Constants as C

25−

26−import CodeGen.IL.Common

27−import CodeGen.IL.Optimizer.Common

28−

29−-- TODO: Potential bug:

30−-- Shouldn't just inline this case: { var x = 0; x.toFixed(10); }

31−-- Needs to be: { 0..toFixed(10); }

32−-- Probably needs to be fixed in pretty-printer instead.

33−shouldInline :: AST -> Bool

34−shouldInline (Var _ _) = True

35−shouldInline (NumericLiteral _ _) = True

36−shouldInline (StringLiteral _ _) = True

37−shouldInline (BooleanLiteral _ _) = True

38−shouldInline (Indexer _ index val) = shouldInline index && shouldInline val

39−shouldInline _ = False

40−

41−inlineCommonValues :: AST -> AST

42−inlineCommonValues = everywhere convert

43− where

44− convert :: AST -> AST

45− convert (App ss fn [dict])

46− | isDict' [semiringNumber, semiringInt] dict && isDict fnZero fn = NumericLiteral ss (Left 0)

47− | isDict' [semiringNumber, semiringInt] dict && isDict fnOne fn = NumericLiteral ss (Left 1)

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 (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

55− | isDict ringInt dict && isDict fnSubtract fn = intOp ss Subtract ringInt x y

56− convert other = other

57− fnZero = (C.dataSemiring, C.zero)

58− fnOne = (C.dataSemiring, C.one)

59− fnBottom = (C.dataBounded, C.bottom)

60− fnTop = (C.dataBounded, C.top)

61− fnAdd = (C.dataSemiring, C.add)

62− fnMultiply = (C.dataSemiring, C.mul)

63− fnSubtract = (C.dataRing, C.sub)

64− fnNegate = (C.dataRing, C.negate)

65− intOp ss op (_, d) x y = Binary ss op (unbox x d) (unbox y d)

66−

67−inlineCommonOperators :: AST -> AST

68−inlineCommonOperators = everywhereTopDown $ applyAll $

69− [ binary semiringNumber opAdd Add

70− , binary semiringNumber opMul Multiply

71−

72− , binary ringNumber opSub Subtract

73− , unary ringNumber opNegate Negate

74−

75− , binary euclideanRingNumber opDiv Divide

76−

77− -- , binary eqNumber opEq EqualTo

78− -- , binary eqNumber opNotEq NotEqualTo

79− , binary eqInt opEq EqualTo

80− , binary eqInt opNotEq NotEqualTo

81− , binary eqString opEq EqualTo

82− , binary eqString opNotEq NotEqualTo

83− , binary eqChar opEq EqualTo

84− , binary eqChar opNotEq NotEqualTo

85− , binary eqBoolean opEq EqualTo

86− , binary eqBoolean opNotEq NotEqualTo

87−

88− , binary ordBoolean opLessThan LessThan

89− , binary ordBoolean opLessThanOrEq LessThanOrEqualTo

90− , binary ordBoolean opGreaterThan GreaterThan

91− , binary ordBoolean opGreaterThanOrEq GreaterThanOrEqualTo

92− , binary ordChar opLessThan LessThan

93− , binary ordChar opLessThanOrEq LessThanOrEqualTo

94− , binary ordChar opGreaterThan GreaterThan

95− , binary ordChar opGreaterThanOrEq GreaterThanOrEqualTo

96− , binary ordInt opLessThan LessThan

97− , binary ordInt opLessThanOrEq LessThanOrEqualTo

98− , binary ordInt opGreaterThan GreaterThan

99− , binary ordInt opGreaterThanOrEq GreaterThanOrEqualTo

100− , binary ordNumber opLessThan LessThan

101− , binary ordNumber opLessThanOrEq LessThanOrEqualTo

102− , binary ordNumber opGreaterThan GreaterThan

103− , binary ordNumber opGreaterThanOrEq GreaterThanOrEqualTo

104− , binary ordString opLessThan LessThan

105− , binary ordString opLessThanOrEq LessThanOrEqualTo

106− , binary ordString opGreaterThan GreaterThan

107− , binary ordString opGreaterThanOrEq GreaterThanOrEqualTo

108−

109− , binary semigroupString opAppend Add

110−

111− , binary heytingAlgebraBoolean opConj And

112− , binary heytingAlgebraBoolean opDisj Or

113− , unary heytingAlgebraBoolean opNot Not

114−

115− , binary' C.dataIntBits C.or BitwiseOr

116− , binary' C.dataIntBits C.and BitwiseAnd

117− , binary' C.dataIntBits C.xor BitwiseXor

118− , binary' C.dataIntBits C.shl ShiftLeft

119− , binary' C.dataIntBits C.shr ShiftRight

120− , unary' C.dataIntBits C.complement BitwiseNot

121−

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

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

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

125− ] ++

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

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

128− [ fn | i <- [0..10], fn <- [ mkEffFn C.effectUncurried C.mkEffectFn i, runEffFn C.effectUncurried C.runEffectFn i ] ]

129− where

130− binary :: (Text, PSString) -> (Text, PSString) -> BinaryOperator -> AST -> AST

131− binary dict@(_, d) fns op = convert where

132− convert :: AST -> AST

133− convert (App ss (App _ (App _ fn [dict']) [x]) [y])

134− | isDict dict dict' && isDict fns fn = Binary ss op (unbox x d) (unbox y d)

135− convert other = other

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

137− binary' moduleName opString op = convert where

138− convert :: AST -> AST

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

140− convert other = other

141− mn :: PSString

142− mn = mkString moduleName

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

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

145− convert :: AST -> AST

146− convert (App ss (App _ fn [dict']) [x]) | isDict dicts dict' && isDict fns fn = Unary ss op (unbox x d)

147− convert other = other

148− unary' :: Text -> PSString -> UnaryOperator -> AST -> AST

149− unary' moduleName fnName op = convert where

150− convert :: AST -> AST

151− convert (App ss fn [x]) | isDict (moduleName, fnName) fn = Unary ss op (unbox x fnName)

152− convert other = other

153−

154− mkFn :: Int -> AST -> AST

155− mkFn = mkFn' C.dataFunctionUncurried C.mkFn $ \ss1 ss2 ss3 args il ->

156− Function ss1 Nothing args (Block ss2 [Return ss3 il])

157−

158− mkEffFn :: Text -> Text -> Int -> AST -> AST

159− mkEffFn modName fnName = mkFn' modName fnName $ \ss1 ss2 ss3 args il ->

160− Function ss1 Nothing args (Block ss2 [Return ss3 (App ss3 il [])])

161−

162− mkFn' :: Text -> Text -> (Maybe SourceSpan -> Maybe SourceSpan -> Maybe SourceSpan -> [Text] -> AST -> AST) -> Int -> AST -> AST

163− mkFn' modName fnName res 0 = convert where

164− convert :: AST -> AST

165− convert (App _ mkFnN [Function s1 Nothing [_] (Block s2 [Return s3 il])]) | isNFn modName fnName 0 mkFnN =

166− res s1 s2 s3 [] il

167− convert other = other

168− mkFn' modName fnName res n = convert where

169− convert :: AST -> AST

170− convert orig@(App ss mkFnN [fn]) | isNFn modName fnName n mkFnN =

171− case collectArgs n [] fn of

172− Just (args, [Return ss' ret]) -> res ss ss ss' args ret

173− _ -> orig

174− convert other = other

175− collectArgs :: Int -> [Text] -> AST -> Maybe ([Text], [AST])

176− collectArgs 1 acc (Function _ Nothing [oneArg] (Block _ il)) | length acc == n - 1 = Just (reverse (oneArg : acc), il)

177− collectArgs m acc (Function _ Nothing [oneArg] (Block _ [Return _ ret])) = collectArgs (m - 1) (oneArg : acc) ret

178− collectArgs _ _ _ = Nothing

179−

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

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

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

183− isNFn _ _ _ _ = False

184−

185− runFn :: Int -> AST -> AST

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

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)

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

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

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

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

196−

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

198− runFn' modName runFnName res n = convert where

199− convert :: AST -> AST

200− convert il = fromMaybe il $ go n [] il

201−

202− go :: Int -> [AST] -> AST -> Maybe AST

203− go 0 acc (App ss runFnN [fn]) | isNFn modName runFnName n runFnN && length acc == n =

204− Just $ res ss fn acc

205− go m acc (App _ lhs [arg]) = go (m - 1) (arg : acc) lhs

206− go _ _ _ = Nothing

207−

208− inlineNonClassFunction :: (AST -> Bool) -> (AST -> AST -> AST) -> AST -> AST

209− inlineNonClassFunction p f = convert where

210− convert :: AST -> AST

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

212− convert other = other

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−

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

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

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

226− isModFn _ _ = False

227−

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

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

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

231− isModFnWithDict _ _ = False

232−

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

234−-- (f <<< g) = \x -> f (g x)

235−inlineFnComposition :: forall m. MonadSupply m => AST -> m AST

236−inlineFnComposition = everywhereTopDownM convert where

237− convert :: AST -> m AST

238− convert (App s1 (App s2 (App _ (App _ fn [dict']) [x]) [y]) [z])

239− | isFnCompose dict' fn = return $ App s1 x [App s2 y [z]]

240− | isFnComposeFlipped dict' fn = return $ App s2 y [App s1 x [z]]

241− convert app@(App ss (App _ (App _ fn [dict']) _) _)

242− | isFnCompose dict' fn || isFnComposeFlipped dict' fn = mkApps ss <$> goApps app <*> freshName'

243− convert other = return other

244−

245− mkApps :: Maybe SourceSpan -> [Either AST (Text, AST)] -> Text -> AST

246− mkApps ss fns a = App ss (Function ss Nothing [] (Block ss $ vars <> [Return Nothing comp])) []

247− where

248− vars = uncurry (VariableIntroduction ss) . fmap Just <$> rights fns

249− comp = Function ss Nothing [a] (Block ss [Return Nothing apps])

250− apps = foldr (\fn acc -> App ss (mkApp fn) [acc]) (Var ss a) fns

251−

252− mkApp :: Either AST (Text, AST) -> AST

253− mkApp = either id $ \(name, arg) -> Var (getSourceSpan arg) name

254−

255− goApps :: AST -> m [Either AST (Text, AST)]

256− goApps (App _ (App _ (App _ fn [dict']) [x]) [y])

257− | isFnCompose dict' fn = mappend <$> goApps x <*> goApps y

258− | isFnComposeFlipped dict' fn = mappend <$> goApps y <*> goApps x

259− goApps app@(App {}) = pure . Right . (,app) <$> freshName'

260− goApps other = pure [Left other]

261−

262− isFnCompose :: AST -> AST -> Bool

263− isFnCompose dict' fn = isDict semigroupoidFn dict' && isDict fnCompose fn

264−

265− isFnComposeFlipped :: AST -> AST -> Bool

266− isFnComposeFlipped dict' fn = isDict semigroupoidFn dict' && isDict fnComposeFlipped fn

267−

268− fnCompose :: forall a b. (IsString a, IsString b) => (a, b)

269− fnCompose = (C.controlSemigroupoid, C.compose)

270−

271− fnComposeFlipped :: forall a b. (IsString a, IsString b) => (a, b)

272− fnComposeFlipped = (C.controlSemigroupoid, C.composeFlipped)

273−

274−inlineUnsafeCoerce :: AST -> AST

275−inlineUnsafeCoerce = everywhereTopDown convert where

276− convert (App _ (Indexer _ (Var _ unsafeCoerceFn) (Var _ unsafeCoerce)) [ comp ])

277− | unsafeCoerceFn == C.unsafeCoerceFn && unsafeCoerce == C.unsafeCoerce

278− = comp

279− convert other = other

280−

281−inlineUnsafePartial :: AST -> AST

282−inlineUnsafePartial = everywhereTopDown convert where

283− convert (App ss fn [ comp ])

284− | isDict fnUnsafePartial fn

285− = App ss comp []

286− where

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

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

289− convert other = other

290−

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

292−semiringNumber = (C.dataSemiring, C.semiringNumber)

293−

294−semiringInt :: forall a b. (IsString a, IsString b) => (a, b)

295−semiringInt = (C.dataSemiring, C.semiringInt)

296−

297−ringNumber :: forall a b. (IsString a, IsString b) => (a, b)

298−ringNumber = (C.dataRing, C.ringNumber)

299−

300−ringInt :: forall a b. (IsString a, IsString b) => (a, b)

301−ringInt = (C.dataRing, C.ringInt)

302−

303−euclideanRingNumber :: forall a b. (IsString a, IsString b) => (a, b)

304−euclideanRingNumber = (C.dataEuclideanRing, C.euclideanRingNumber)

305−

306−-- eqNumber :: forall a b. (IsString a, IsString b) => (a, b)

307−-- eqNumber = (C.dataEq, C.eqNumber)

308−

309−eqInt :: forall a b. (IsString a, IsString b) => (a, b)

310−eqInt = (C.dataEq, C.eqInt)

311−

312−eqString :: forall a b. (IsString a, IsString b) => (a, b)

313−eqString = (C.dataEq, C.eqString)

314−

315−eqChar :: forall a b. (IsString a, IsString b) => (a, b)

316−eqChar = (C.dataEq, C.eqChar)

317−

318−eqBoolean :: forall a b. (IsString a, IsString b) => (a, b)

319−eqBoolean = (C.dataEq, C.eqBoolean)

320−

321−ordBoolean :: forall a b. (IsString a, IsString b) => (a, b)

322−ordBoolean = (C.dataOrd, C.ordBoolean)

323−

324−ordNumber :: forall a b. (IsString a, IsString b) => (a, b)

325−ordNumber = (C.dataOrd, C.ordNumber)

326−

327−ordInt :: forall a b. (IsString a, IsString b) => (a, b)

328−ordInt = (C.dataOrd, C.ordInt)

329−

330−ordString :: forall a b. (IsString a, IsString b) => (a, b)

331−ordString = (C.dataOrd, C.ordString)

332−

333−ordChar :: forall a b. (IsString a, IsString b) => (a, b)

334−ordChar = (C.dataOrd, C.ordChar)

335−

336−semigroupString :: forall a b. (IsString a, IsString b) => (a, b)

337−semigroupString = (C.dataSemigroup, C.semigroupString)

338−

339−boundedBoolean :: forall a b. (IsString a, IsString b) => (a, b)

340−boundedBoolean = (C.dataBounded, C.boundedBoolean)

341−

342−heytingAlgebraBoolean :: forall a b. (IsString a, IsString b) => (a, b)

343−heytingAlgebraBoolean = (C.dataHeytingAlgebra, C.heytingAlgebraBoolean)

344−

345−semigroupoidFn :: forall a b. (IsString a, IsString b) => (a, b)

346−semigroupoidFn = (C.controlSemigroupoid, C.semigroupoidFn)

347−

348−opAdd :: forall a b. (IsString a, IsString b) => (a, b)

349−opAdd = (C.dataSemiring, C.add)

350−

351−opMul :: forall a b. (IsString a, IsString b) => (a, b)

352−opMul = (C.dataSemiring, C.mul)

353−

354−opEq :: forall a b. (IsString a, IsString b) => (a, b)

355−opEq = (C.dataEq, C.eq)

356−

357−opNotEq :: forall a b. (IsString a, IsString b) => (a, b)

358−opNotEq = (C.dataEq, C.notEq)

359−

360−opLessThan :: forall a b. (IsString a, IsString b) => (a, b)

361−opLessThan = (C.dataOrd, C.lessThan)

362−

363−opLessThanOrEq :: forall a b. (IsString a, IsString b) => (a, b)

364−opLessThanOrEq = (C.dataOrd, C.lessThanOrEq)

365−

366−opGreaterThan :: forall a b. (IsString a, IsString b) => (a, b)

367−opGreaterThan = (C.dataOrd, C.greaterThan)

368−

369−opGreaterThanOrEq :: forall a b. (IsString a, IsString b) => (a, b)

370−opGreaterThanOrEq = (C.dataOrd, C.greaterThanOrEq)

371−

372−opAppend :: forall a b. (IsString a, IsString b) => (a, b)

373−opAppend = (C.dataSemigroup, C.append)

374−

375−opSub :: forall a b. (IsString a, IsString b) => (a, b)

376−opSub = (C.dataRing, C.sub)

377−

378−opNegate :: forall a b. (IsString a, IsString b) => (a, b)

379−opNegate = (C.dataRing, C.negate)

380−

381−opDiv :: forall a b. (IsString a, IsString b) => (a, b)

382−opDiv = (C.dataEuclideanRing, C.div)

383−

384−opConj :: forall a b. (IsString a, IsString b) => (a, b)

385−opConj = (C.dataHeytingAlgebra, C.conj)

386−

387−opDisj :: forall a b. (IsString a, IsString b) => (a, b)

388−opDisj = (C.dataHeytingAlgebra, C.disj)

389−

390−opNot :: forall a b. (IsString a, IsString b) => (a, b)

391−opNot = (C.dataHeytingAlgebra, C.not)

392−

393−unbox :: AST -> PSString -> AST

394−unbox e d = select . inlineCommonValues $ inlineCommonOperators e

395− where

396− select :: AST -> AST

397− select e' =

398− case e' of

399− Var{} -> unbox' e'

400− App{} -> unbox' e'

401− Indexer{} -> unbox' e'

402− _ -> e'

403− unbox' :: AST -> AST

404− unbox' e' = maybe e' (\t -> App Nothing (StringLiteral Nothing t) [e']) $ unboxType d

405−

406−unboxType :: PSString -> Maybe PSString

407−unboxType s = do

408− t <- decodeString s

409− t' <- unboxType' t

410− return $ mkString t'

411− where

412− unboxType' :: Text -> Maybe Text

413− unboxType' t

414− | t == C.eqInt ||

415− t == C.semiringInt ||

416− t == C.ringInt ||

417− t == C.ordInt ||

418− t == C.dataIntBits

419− = Just int

420− | t == C.semiringNumber ||

421− t == C.ringNumber ||

422− t == C.ordNumber ||

423− t == C.euclideanRingNumber

424− = Just float

425− | t == C.eqBoolean ||

426− t == C.ordBoolean ||

427− t == C.heytingAlgebraBoolean

428− = Just bool

429− | t == C.eqChar ||

430− t == C.eqString ||

431− t == C.ordChar ||

432− t == C.ordString ||

433− t == C.semigroupString

434− = Just string

435− | otherwise = Nothing

src/CodeGen/IL/Optimizer/MagicDo.hsdeleted−146

@@ -1,146 +0,0 @@

1−-- | This module implements the "Magic Do" optimization, which inlines calls to return

2−-- and bind for the Eff monad, as well as some of its actions.

3−module CodeGen.IL.Optimizer.MagicDo (magicDoEffect, magicDoEff, magicDoST, inlineST) where

4−

5−import Prelude.Compat

6−import Protolude (ordNub)

7−

8−import Data.Maybe (fromJust, isJust)

9−import Data.Text (Text)

10−

11−import Language.PureScript.CoreImp.AST

12−import Language.PureScript.CoreImp.Optimizer.Common hiding (isDict)

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

14−import qualified Language.PureScript.Constants as C

15−

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

17−import CodeGen.IL.Optimizer.Common

18−

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

20−--

21−-- E.g.

22−--

23−-- Prelude[">>="](dict)(m1)(function(x) {

24−-- return ...;

25−-- })

26−--

27−-- becomes

28−--

29−-- function __do {

30−-- var x = m1();

31−-- ...

32−-- }

33−magicDoEff :: AST -> AST

34−magicDoEff = magicDo C.eff C.effDictionaries

35−

36−magicDoEffect :: AST -> AST

37−magicDoEffect = magicDo C.effect C.effectDictionaries

38−

39−magicDoST :: AST -> AST

40−magicDoST = magicDo C.st C.stDictionaries

41−

42−magicDo :: Text -> C.EffectDictionaries -> AST -> AST

43−magicDo effectModule C.EffectDictionaries{..} = everywhereTopDown convert

44− where

45− -- Desugar monomorphic calls to >>= and return for the Eff monad

46− convert :: AST -> AST

47− -- Desugar pure

48− convert (App _ (App _ pure' [val]) []) | isPure pure' = val

49− -- Desugar discard

50− convert (App _ (App _ bind [m]) [Function s1 Nothing [unused] (Block s2 il)]) | isDiscard bind && unused == unusedName =

51− Function s1 Nothing [] $ Block s2 (App s2 m [] : map applyReturns il )

52− -- Desugar bind

53− convert (App _ (App _ bind [m]) [Function s1 Nothing [arg] (Block s2 il)]) | isBind bind =

54− Function s1 Nothing [] $ Block s2 (VariableIntroduction s2 arg (Just (App s2 m [])) : map applyReturns il)

55− -- Desugar untilE

56− convert (App s1 (App _ f [arg]) []) | isEffFunc edUntil f =

57− App s1 (Function s1 Nothing [] (Block s1 [ While s1 (Unary s1 Not (App s1 arg [])) (Block s1 []), Return s1 $ ObjectLiteral s1 []])) []

58− -- Desugar whileE

59− convert (App _ (App _ (App s1 f [arg1]) [arg2]) []) | isEffFunc edWhile f =

60− App s1 (Function s1 Nothing [] (Block s1 [ While s1 (App s1 arg1 []) (Block s1 [ App s1 arg2 [] ]), Return s1 $ ObjectLiteral s1 []])) []

61− -- -- Inline __do returns

62− -- convert (Return _ (App _ (Function _ (Just ident) [] body) [])) | ident == fnName = body

63− -- Inline double applications

64− convert (App _ (App s1 (Function s2 Nothing [] (Block ss body)) []) []) =

65− App s1 (Function s2 Nothing [] (Block ss (applyReturns `fmap` body))) []

66− convert other = other

67− -- Check if an expression represents a monomorphic call to >>= for the Eff monad

68− isBind (App _ fn [dict]) | isDict (effectModule, edBindDict) dict && isBindPoly fn = True

69− isBind _ = False

70− -- Check if an expression represents a call to @discard@

71− isDiscard (App _ (App _ fn [dict1]) [dict2])

72− | isDict (C.controlBind, C.discardUnitDictionary) dict1 &&

73− isDict (effectModule, edBindDict) dict2 &&

74− isDiscardPoly fn = True

75− isDiscard _ = False

76−

77− -- Check if an expression represents a monomorphic call to pure or return for the Eff applicative

78− isPure (App _ fn [dict]) | isDict (effectModule, edApplicativeDict) dict && isPurePoly fn = True

79− isPure _ = False

80− -- Check if an expression represents the polymorphic >>= function

81− isBindPoly = isDict (C.controlBind, C.bind)

82− -- Check if an expression represents the polymorphic pure function

83− isPurePoly = isDict (C.controlApplicative, C.pure')

84− -- Check if an expression represents the polymorphic discard function

85− isDiscardPoly = isDict (C.controlBind, C.discard)

86− -- Check if an expression represents a function in the Effect module

87− isEffFunc name (Indexer _ (StringLiteral _ name') (Var _ eff)) = eff == effectModule && name == name'

88− isEffFunc _ _ = False

89−

90− applyReturns :: AST -> AST

91− applyReturns (Return ss ret) = Return ss (App ss ret [])

92− applyReturns (Block ss ils) = Block ss (map applyReturns ils)

93− applyReturns (While ss cond il) = While ss cond (applyReturns il)

94− applyReturns (For ss v lo hi il) = For ss v lo hi (applyReturns il)

95− applyReturns (ForIn ss v xs il) = ForIn ss v xs (applyReturns il)

96− applyReturns (IfElse ss cond t f) = IfElse ss cond (applyReturns t) (applyReturns `fmap` f)

97− applyReturns other = other

98−

99−-- | Inline functions in the ST module

100−inlineST :: AST -> AST

101−inlineST = everywhere convertBlock

102− where

103− -- Look for runST blocks and inline the STRefs there.

104− -- If all STRefs are used in the scope of the same runST, only using { read, write, modify }STRef then

105− -- we can be more aggressive about inlining, and actually turn STRefs into local variables.

106− convertBlock (App s1 f [arg]) | isSTFunc C.runST f =

107− let refs = ordNub . findSTRefsIn $ arg

108− usages = findAllSTUsagesIn arg

109− allUsagesAreLocalVars = all (\u -> let v = toVar u in isJust v && fromJust v `elem` refs) usages

110− localVarsDoNotEscape = all (\r -> length (r `appearingIn` arg) == length (filter (\u -> let v = toVar u in v == Just r) usages)) refs

111− in App s1 (everywhere (convert (allUsagesAreLocalVars && localVarsDoNotEscape)) arg) []

112− convertBlock other = other

113− -- Convert a block in a safe way, preserving object wrappers of references,

114− -- or in a more aggressive way, turning wrappers into local variables depending on the

115− -- agg(ressive) parameter.

116− convert agg (App s1 f [arg]) | isSTFunc C.newSTRef f =

117− Function s1 Nothing [] (Block s1 [Return s1 $ if agg then arg else ObjectLiteral s1 [(mkString C.stRefValue, arg)]])

118− convert agg (App _ (App s1 f [ref]) []) | isSTFunc C.readSTRef f =

119− if agg then ref else Indexer s1 (StringLiteral s1 C.stRefValue) ref

120− convert agg (App _ (App _ (App s1 f [arg]) [ref]) []) | isSTFunc C.writeSTRef f =

121− if agg then Assignment s1 ref arg else Assignment s1 (Indexer s1 (StringLiteral s1 C.stRefValue) ref) arg

122− convert agg (App _ (App _ (App s1 f [func]) [ref]) []) | isSTFunc C.modifySTRef f =

123− if agg then Assignment s1 ref (App s1 func [ref]) else Assignment s1 (Indexer s1 (StringLiteral s1 C.stRefValue) ref) (App s1 func [Indexer s1 (StringLiteral s1 C.stRefValue) ref])

124− convert _ other = other

125− -- Check if an expression represents a function in the ST module

126− isSTFunc name (Indexer _ (StringLiteral _ name') (Var _ st)) = st == C.st && name == name'

127− isSTFunc _ _ = False

128− -- Find all ST Refs initialized in this block

129− findSTRefsIn = everything (++) isSTRef

130− where

131− isSTRef (VariableIntroduction _ ident (Just (App _ (App _ f [_]) []))) | isSTFunc C.newSTRef f = [ident]

132− isSTRef _ = []

133− -- Find all STRefs used as arguments to readSTRef, writeSTRef, modifySTRef

134− findAllSTUsagesIn = everything (++) isSTUsage

135− where

136− isSTUsage (App _ (App _ f [ref]) []) | isSTFunc C.readSTRef f = [ref]

137− isSTUsage (App _ (App _ (App _ f [_]) [ref]) []) | isSTFunc C.writeSTRef f || isSTFunc C.modifySTRef f = [ref]

138− isSTUsage _ = []

139− -- Find all uses of a variable

140− appearingIn ref = everything (++) isVar

141− where

142− isVar e@(Var _ v) | v == ref = [e]

143− isVar _ = []

144− -- Convert a AST value to a String if it is a Var

145− toVar (Var _ v) = Just v

146− toVar _ = Nothing

src/CodeGen/IL/Optimizer/TCO.hsdeleted−141

@@ -1,141 +0,0 @@

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

2−

3−import Prelude.Compat

4−

5−import Data.Text (Text)

6−import Data.Monoid ((<>))

7−import Language.PureScript.CoreImp.AST

8−import Language.PureScript.AST.SourcePos (SourceSpan)

9−import Safe (headDef, tailSafe)

10−import CodeGen.IL.Common

11−

12−import qualified Language.PureScript.Constants as C

13−

14−tcoLoop :: Text

15−tcoLoop = "ṩtco_loop"

16−

17−tco :: AST -> AST -> AST

18−tco mn = everywhere convert where

19− tcoVar :: Text -> Text

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

21−

22− copyVar :: Text -> Text

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

24−

25− tcoDone :: Text

26− tcoDone = "ṩtco_done"

27−

28− tcoResult :: Text

29− tcoResult = "ṩtco_result"

30−

31− convert :: AST -> AST

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

33− | isTailRecursive name body'

34− = replace (toLoop name outerArgs innerArgs body')

35− where

36− innerArgs = headDef [] argss

37− outerArgs = concat . reverse $ tailSafe argss

38− (argss, body', replace) = collectAllFunctionArgs [] id fn

39− convert (Assignment ss (Var _ name) fn@(Function _ Nothing _ _))

40− | isTailRecursive name body'

41− = Assignment ss (Var ss name) (replace (toLoop name outerArgs innerArgs body'))

42− where

43− innerArgs = headDef [] argss

44− outerArgs = concat . reverse $ tailSafe argss

45− (argss, body', replace) = collectAllFunctionArgs [] id fn

46− convert js = js

47−

48− collectAllFunctionArgs :: [[Text]] -> (AST -> AST) -> AST -> ([[Text]], AST, AST -> AST)

49− collectAllFunctionArgs allArgs f (Function s1 ident args (Block s2 (body@(Return _ _):_))) =

50− collectAllFunctionArgs (args : allArgs) (\b -> f (Function s1 ident (map copyVar args) (Block s2 [b]))) body

51− collectAllFunctionArgs allArgs f (Function ss ident args body@(Block _ _)) =

52− (args : allArgs, body, f . Function ss ident (map copyVar args))

53− collectAllFunctionArgs allArgs f (Return s1 (Function s2 ident args (Block s3 [body]))) =

54− collectAllFunctionArgs (args : allArgs) (\b -> f (Return s1 (Function s2 ident (map copyVar args) (Block s3 [b])))) body

55− collectAllFunctionArgs allArgs f (Return s1 (Function s2 ident args body@(Block _ _))) =

56− (args : allArgs, body, f . Return s1 . Function s2 ident (map copyVar args))

57− collectAllFunctionArgs allArgs f body = (allArgs, body, f)

58−

59− isTailRecursive :: Text -> AST -> Bool

60− isTailRecursive ident js = countSelfReferences js > 0 && allInTailPosition js where

61− countSelfReferences = everything (+) match where

62− match :: AST -> Int

63− match (Var _ ident') | ident == ident' = 1

64− match _ = 0

65−

66− allInTailPosition (Return _ expr)

67− | isSelfCall ident expr = countSelfReferences expr == 1

68− | otherwise = countSelfReferences expr == 0

69− allInTailPosition (While _ js1 body)

70− = countSelfReferences js1 == 0 && allInTailPosition body

71− allInTailPosition (For _ _ js1 js2 body)

72− = countSelfReferences js1 == 0 && countSelfReferences js2 == 0 && allInTailPosition body

73− allInTailPosition (ForIn _ _ js1 body)

74− = countSelfReferences js1 == 0 && allInTailPosition body

75− allInTailPosition (IfElse _ js1 body el)

76− = countSelfReferences js1 == 0 && allInTailPosition body && all allInTailPosition el

77− allInTailPosition (Block _ body)

78− = all allInTailPosition body

79− allInTailPosition (Throw _ js1)

80− = countSelfReferences js1 == 0

81− allInTailPosition (ReturnNoResult _)

82− = True

83− allInTailPosition (VariableIntroduction _ _ js1)

84− = all ((== 0) . countSelfReferences) js1

85− allInTailPosition (Assignment _ _ js1)

86− = countSelfReferences js1 == 0

87− allInTailPosition (Comment _ _ js1)

88− = allInTailPosition js1

89− allInTailPosition _

90− = False

91−

92− toLoop :: Text -> [Text] -> [Text] -> AST -> AST

93− toLoop ident outerArgs innerArgs js =

94− Block rootSS $

95− concatMap (\arg -> [ VariableIntroduction rootSS (tcoVar arg) . Just $

96− Var rootSS (copyVar arg) ]) (outerArgs ++ innerArgs) ++

97− [ Assignment rootSS (Var rootSS $ "var " <> tcoDone) $ BooleanLiteral Nothing False

98− , VariableIntroduction rootSS tcoResult Nothing

99− , Assignment rootSS (Var rootSS $ "var " <> tcoLoop) (Function rootSS (Just tcoLoop) (outerArgs ++ innerArgs) (Block rootSS [loopify js]))

100− , While rootSS (Unary Nothing Not (Var rootSS tcoDone))

101− (Block rootSS

102− [(Assignment rootSS (Var rootSS tcoResult) (App rootSS (Var rootSS tcoLoop) ((map (Var rootSS . tcoVar) outerArgs) ++ (map (Var rootSS . copyVar) innerArgs))))])

103− , Return rootSS (Var rootSS tcoResult)

104− ]

105− where

106− rootSS = Nothing

107−

108− loopify :: AST -> AST

109− loopify (Return ss ret)

110− | isSelfCall ident ret =

111− let

112− allArgumentValues = concat $ collectArgs [] ret

113− in

114− Block ss $

115− zipWith (\val arg ->

116− Assignment ss (Var ss (tcoVar arg)) val) allArgumentValues outerArgs

117− ++ zipWith (\val arg ->

118− Assignment ss (Var ss (copyVar arg)) val) (drop (length outerArgs) allArgumentValues) innerArgs

119− ++ [ ReturnNoResult ss ]

120− | otherwise = Block ss [ markDone ss, Return ss ret ]

121− loopify (ReturnNoResult ss) = Block ss [ markDone ss, ReturnNoResult ss ]

122− loopify (While ss cond body) = While ss cond (loopify body)

123− loopify (For ss i js1 js2 body) = For ss i js1 js2 (loopify body)

124− loopify (ForIn ss i js1 body) = ForIn ss i js1 (loopify body)

125− loopify (IfElse ss cond body el) = IfElse ss cond (loopify body) (fmap loopify el)

126− loopify (Block ss body) = Block ss (map loopify body)

127− loopify other = other

128−

129− markDone :: Maybe SourceSpan -> AST

130− markDone ss = Assignment ss (Var ss tcoDone) (BooleanLiteral ss True)

131−

132− collectArgs :: [[AST]] -> AST -> [[AST]]

133− collectArgs acc (App _ fn args') = collectArgs (args' : acc) fn

134− collectArgs acc _ = acc

135−

136− isSelfCall :: Text -> AST -> Bool

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

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

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

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

141− isSelfCall _ _ = False

src/CodeGen/IL/Printer.hsdeleted−527

@@ -1,527 +0,0 @@

1−-- | Pretty printer for the AST

2−module CodeGen.IL.Printer

3− ( prettyPrintIL

4− , prettyPrintIL1

5− , prettyPrintILWithSourceMaps

6− , interfaceSource

7− , implHeaderSource

8− , implFooterSource

9− , isLiteral

10− , modLabel

11− , modPrefix

12− , ffiLoader

13− ) where

14−

15−import Prelude.Compat

16−

17−import Control.Arrow ((<+>))

18−import Control.Monad (forM, mzero)

19−import Control.Monad.State (StateT, evalStateT)

20−import Control.PatternArrows

21−import Data.List (filter, (\\))

22−import qualified Control.Arrow as A

23−

24−import Data.Maybe (fromMaybe)

25−import Data.Monoid ((<>))

26−import Data.Text (Text)

27−import qualified Data.Text as T

28−

29−import Language.PureScript.AST (SourceSpan(..))

30−import Language.PureScript.CoreImp.AST

31−import Language.PureScript.Comments

32−import Language.PureScript.Crash

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

34−import Language.PureScript.Pretty.Common

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

36−

37−import CodeGen.IL.Common

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

39−

40−import qualified Language.PureScript.Constants as C

41−

42−-- TODO (Christoph): Get rid of T.unpack / pack

43−

44−literals :: (Emit gen) => Pattern PrinterState AST gen

45−literals = mkPattern' match'

46− where

47− match' :: (Emit gen) => AST -> StateT PrinterState Maybe gen

48− match' il = (addMapping' (getSourceSpan il) <>) <$> match il

49−

50− match :: (Emit gen) => AST -> StateT PrinterState Maybe gen

51− match (NumericLiteral _ n) = return $ emit $ T.pack $ either show show n

52− match (StringLiteral _ s) = return $ emit $ stringLiteral s

53− match (BooleanLiteral _ True) = return $ emit "true"

54− match (BooleanLiteral _ False) = return $ emit "false"

55− match (ArrayLiteral _ xs) = mconcat <$> sequence

56− [ return . emit $ arrayType <> "{"

57− , intercalate (emit ", ") <$> forM xs prettyPrintIL'

58− , return $ emit "}"

59− ]

60− -- match (ObjectLiteral _ []) = return $ emit "std::initializer_list<std::pair<const string, boxed>>{}"

61− match (ObjectLiteral _ ps) = mconcat <$> sequence

62− [ return . emit $ dictType <> "{"

63− , withIndent $ do

64− ils <- forM ps $ \(key, value) -> do

65− value' <- prettyPrintIL' value

66− return $ objectPropertyToString key <> value'

67− return $ intercalate (emit " ") $ map (<> emit ",") ils

68− , return $ emit "}"

69− ]

70− where

71− objectPropertyToString :: (Emit gen) => PSString -> gen

72− objectPropertyToString s = emit $ stringLiteral s <> ": "

73− match (Block _ sts) = mconcat <$> sequence

74− [ return $ emit "{\n"

75− , withIndent $ prettyStatements sts

76− , return $ emit "\n"

77− , currentIndent

78− , return $ emit "}"

79− ]

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

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

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

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

84− , maybe (return mempty) (fmap (emit " = " <>) . prettyPrintIL') value

85− ]

86− match (Assignment _ target value) = mconcat <$> sequence

87− [ prettyPrintIL' target

88− , return $ emit " = "

89− , prettyPrintIL' value

90− ]

91− match (App _ val []) = mconcat <$> sequence

92− [ return $ emit "Run("

93− , prettyPrintIL' val

94− , return $ emit ")"

95− ]

96− match (App _ (StringLiteral _ u) [arg])

97− | Just ty <- decodeString u = mconcat <$> sequence

98− [ prettyPrintIL' arg

99− , return $ emit ".("

100− , return $ emit ty

101− , return $ emit ")"

102− ]

103− match (App _ (Var _ fn) [arg]) | fn == arrayLengthFn = mconcat <$> sequence

104− [ return $ emit fn

105− , return $ emit "("

106− , prettyPrintIL' arg

107− , return $ emit ")"

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− ]

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

116− [ return $ emit fn

117− , return $ emit "("

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

119− , return $ emit ")"

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− ]

139− match app@(App{})

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

141− , length args > 1

142− = mconcat <$> sequence

143− [ return $ emit "Apply("

144− , prettyPrintIL' val

145− , return $ emit ", "

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

147− , return $ emit ")"

148− ]

149− match (App _ val args) = mconcat <$> sequence

150− [ return $ emit "Apply("

151− , prettyPrintIL' val

152− , return $ emit ", "

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

154− , return $ emit ")"

155− ]

156− match (Function _ (Just name) [] (Block _ [Return _ ret]))

157− | isComplexLiteral ret = mconcat <$> sequence

158− [ return $ emit "\n"

159− , return . emit $ varDecl <> " " <> initName name <> " Once\n"

160− , prettyPrintIL' $ VariableIntroduction Nothing (valueName name) Nothing

161− , return $ emit "\n\n"

162− , return $ emit "func "

163− , return . emit $ withPrefix name

164− , return . emit $ "() " <> anyType <> " "

165− , return $ emit "{\n"

166− , withIndent $ do

167− indentString <- currentIndent

168− return $ indentString <> (emit $ initName name <> ".Do(func() {\n") <>

169− indentString <> indentString <> (emit $ valueName name <> " = ")

170− , withIndent $ do

171− case ret of

172− Function _ Nothing args body -> mconcat <$> sequence

173− [ return $ emit "func("

174− , return . emit $ intercalate ", " (renderArg anyType <$> args)

175− , return . emit $ ") " <> anyType <> " "

176− , prettyPrintIL' body

177− ]

178− _ -> do

179− prettyPrintIL' ret

180− , return $ emit "\n"

181− , withIndent $ do

182− indentString <- currentIndent

183− return $ indentString <> (emit $ "})\n" <> "return " <> valueName name <>"\n")

184− , return $ emit "}\n\n"

185− ]

186− match (Function _ (Just name) [] ret) = mconcat <$> sequence

187− [ return $ emit "func "

188− , return . emit $ withPrefix name

189− , return . emit $ "() " <> anyType <> " "

190− , prettyPrintIL' ret

191− ]

192− match (Function _ _ args ret) = mconcat <$> sequence

193− [ return $ emit "func("

194− , return . emit $ intercalate ", " (renderArg anyType <$> args)

195− , return . emit $ ") " <> anyType <> " "

196− , prettyPrintIL' ret

197− ]

198− match (Indexer _ (Var _ name) (Var _ "")) = mconcat <$> sequence

199− [ prettyPrintIL' (Var Nothing $ withPrefix name)

200− , return $ emit "()"

201− ]

202− match (Indexer _ (Var _ name) val) = mconcat <$> sequence

203− [ prettyPrintIL' val

204− , return $ emit "."

205− , prettyPrintIL' (Var Nothing $ withPrefix name)

206− , return $ emit "()"

207− ]

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

209− [ prettyPrintIL' val

210− , return $ emit "["

211− , prettyPrintIL' prop

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 "]"

235− ]

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

237− [ return $ emit "Is("

238− , prettyPrintIL' val

239− , return $ emit ", "

240− , prettyPrintIL' ty

241− , return $ emit ")"

242− ]

243− match (While _ cond sts) = mconcat <$> sequence

244− [ return $ emit "for "

245− , prettyPrintIL' cond

246− , return $ emit " "

247− , prettyPrintIL' sts

248− ]

249− match (For _ ident start end sts) = mconcat <$> sequence

250− [ return $ emit $ "for var " <> ident <> " = "

251− , prettyPrintIL' start

252− , return $ emit $ "; " <> ident <> " < "

253− , prettyPrintIL' end

254− , return $ emit $ "; " <> ident <> "++ "

255− , prettyPrintIL' sts

256− ]

257− match (ForIn _ ident obj sts) = mconcat <$> sequence

258− [ return $ emit $ "for var " <> ident <> " in "

259− , prettyPrintIL' obj

260− , return $ emit " "

261− , prettyPrintIL' sts

262− ]

263− match (IfElse _ (Binary _ EqualTo cond@Binary{} (BooleanLiteral Nothing True)) thens elses) = mconcat <$> sequence

264− [ return $ emit "if "

265− , prettyPrintIL' cond

266− , return $ emit " "

267− , prettyPrintIL' thens

268− , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintIL') elses

269− ]

270− match (IfElse _ (Binary _ EqualTo cond@Binary{} (BooleanLiteral Nothing False)) thens elses) = mconcat <$> sequence

271− [ return $ emit "if !("

272− , prettyPrintIL' cond

273− , return $ emit ") "

274− , prettyPrintIL' thens

275− , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintIL') elses

276− ]

277− match (IfElse _ cond thens elses) = mconcat <$> sequence

278− [ return $ emit "if "

279− , prettyPrintIL' cond

280− , return $ emit " "

281− , prettyPrintIL' thens

282− , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintIL') elses

283− ]

284− match (Return _ value) = mconcat <$> sequence

285− [ return $ emit "return "

286− , prettyPrintIL' value

287− ]

288− match (ReturnNoResult _) = return . emit $ "return " <> undefinedName

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

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

291− [ return $ emit "panic("

292− , prettyPrintIL' value

293− , return $ emit ")"

294− ]

295− match (Comment _ com il) = mconcat <$> sequence

296− [ return $ emit "\n"

297− , mconcat <$> forM com comment

298− , prettyPrintIL' il

299− ]

300− match _ = mzero

301−

302− comment :: (Emit gen) => Comment -> StateT PrinterState Maybe gen

303− comment (LineComment com) = fmap mconcat $ sequence $

304− [ currentIndent

305− , return $ emit "//" <> emit com <> emit "\n"

306− ]

307− comment (BlockComment com) = fmap mconcat $ sequence $

308− [ currentIndent

309− , return $ emit "/**\n"

310− ] ++

311− map asLine (T.lines com) ++

312− [ currentIndent

313− , return $ emit " */\n"

314− , currentIndent

315− ]

316− where

317− asLine :: (Emit gen) => Text -> StateT PrinterState Maybe gen

318− asLine s = do

319− i <- currentIndent

320− return $ i <> emit " * " <> (emit . removeComments) s <> emit "\n"

321−

322− removeComments :: Text -> Text

323− removeComments t =

324− case T.stripPrefix "*/" t of

325− Just rest -> removeComments rest

326− Nothing -> case T.uncons t of

327− Just (x, xs) -> x `T.cons` removeComments xs

328− Nothing -> ""

329−

330−unary' :: (Emit gen) => UnaryOperator -> (AST -> Text) -> Operator PrinterState AST gen

331−unary' op mkStr = Wrap match (<>)

332− where

333− match :: (Emit gen) => Pattern PrinterState AST (gen, AST)

334− match = mkPattern match'

335− where

336− match' (Unary _ op' val) | op' == op = Just (emit $ mkStr val, val)

337− match' _ = Nothing

338−

339−unary :: (Emit gen) => UnaryOperator -> Text -> Operator PrinterState AST gen

340−unary op str = unary' op (const str)

341−

342−negateOperator :: (Emit gen) => Operator PrinterState AST gen

343−negateOperator = unary' Negate (\v -> if isNegate v then "- " else "-")

344− where

345− isNegate (Unary _ Negate _) = True

346− isNegate _ = False

347−

348−binary :: (Emit gen) => BinaryOperator -> Text -> Operator PrinterState AST gen

349−binary op str = AssocL match (\v1 v2 -> v1 <> emit (" " <> str <> " ") <> v2)

350− where

351− match :: Pattern PrinterState AST (AST, AST)

352− match = mkPattern match'

353− where

354− match' (Binary _ op' v1 v2) | op' == op = Just (v1, v2)

355− match' _ = Nothing

356−

357−isLiteral :: AST -> Bool

358−isLiteral Function{} = True

359−isLiteral NumericLiteral{} = True

360−isLiteral StringLiteral{} = True

361−isLiteral BooleanLiteral{} = True

362−isLiteral ObjectLiteral{} = True

363−isLiteral ArrayLiteral{} = True

364−isLiteral _ = False

365−

366−isComplexLiteral :: AST -> Bool

367−-- isComplexLiteral Function{} = True

368−isComplexLiteral ObjectLiteral{} = True

369−isComplexLiteral ArrayLiteral{} = True

370−isComplexLiteral _ = False

371−

372−unApp :: AST -> [AST] -> (AST, [AST])

373−unApp (App _ val [arg]) args = unApp val (arg : args)

374−unApp other args = (other, args)

375−

376−prettyStatements :: (Emit gen) => [AST] -> StateT PrinterState Maybe gen

377−prettyStatements sts = do

378− ils <- forM sts prettyPrintIL'

379− indentString <- currentIndent

380− return $ intercalate (emit "\n") $ map (indentString <>) ils

381−

382−-- | Generate a pretty-printed string representing a collection of C++ expressions at the same indentation level

383−prettyPrintILWithSourceMaps :: [AST] -> (Text, [SMap])

384−prettyPrintILWithSourceMaps il =

385− let StrPos (_, s, mp) = (fromMaybe (internalError "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyStatements) il

386− in (s, mp)

387−

388−prettyPrintIL :: [AST] -> Text

389−prettyPrintIL = maybe (internalError "Incomplete pattern") runPlainString . flip evalStateT (PrinterState 0) . prettyStatements

390−

391−-- | Generate an indented, pretty-printed string representing a C++ expression

392−prettyPrintIL' :: (Emit gen) => AST -> StateT PrinterState Maybe gen

393−prettyPrintIL' = A.runKleisli $ runPattern matchValue

394− where

395− matchValue :: (Emit gen) => Pattern PrinterState AST gen

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

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

398− operators =

399− OperatorTable [ [ unary New "?" ]

400− , [ unary Not "!"

401− , unary BitwiseNot "~"

402− , unary Positive "+"

403− , negateOperator ]

404− , [ binary Multiply "*"

405− , binary Divide "/"

406− , binary Modulus "%" ]

407− , [ binary Add "+"

408− , binary Subtract "-" ]

409− , [ binary ShiftLeft "<<"

410− , binary ShiftRight ">>" ]

411− , [ binary LessThan "<"

412− , binary LessThanOrEqualTo "<="

413− , binary GreaterThan ">"

414− , binary GreaterThanOrEqualTo ">=" ]

415− , [ binary EqualTo "=="

416− , binary NotEqualTo "!=" ]

417− , [ binary BitwiseAnd "&" ]

418− , [ binary BitwiseXor "^" ]

419− , [ binary BitwiseOr "|" ]

420− , [ binary And "&&" ]

421− , [ binary Or "||" ]

422− ]

423−

424−prettyPrintIL1 :: AST -> Text

425−prettyPrintIL1 = maybe (internalError "Incomplete pattern") runPlainString . flip evalStateT (PrinterState 0) . prettyPrintIL'

426−

427−stringLiteral :: PSString -> Text

428−stringLiteral pss | Just s <- decodeString pss = stringLiteral' s

429− where

430− stringLiteral' :: Text -> Text

431− stringLiteral' s = "\"" <> T.concatMap encodeChar s <> "\""

432− encodeChar :: Char -> Text

433− encodeChar '\0' = "\\x00"

434− encodeChar '\b' = "\\b"

435− encodeChar '\t' = "\\t"

436− encodeChar '\n' = "\\n"

437− encodeChar '\v' = "\\v"

438− encodeChar '\f' = "\\f"

439− encodeChar '\r' = "\\r"

440− encodeChar '"' = "\\\""

441− encodeChar '\\' = "\\\\"

442− encodeChar c = T.singleton $ c

443−stringLiteral _ = "\"\\uFFFD\""

444−

445−interfaceSource :: Text -> [(Text,Bool)] -> [Ident] -> Text

446−interfaceSource _ _ _ = ""

447−

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

449−implHeaderSource mn imports otherPrefix =

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

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

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

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

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

455− else "\n") <>

456− "import (\n" <>

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

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

459− where

460− formatImport :: Text -> Text

461− formatImport s =

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

468−

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

470−implFooterSource mn foreigns =

471− "\n\n\n" <>

472− (if null foreigns

473− then ""

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

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

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

477− let name = moduleIdentToIL foreign' in

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

479− varDecl <> " " <> valueName name <> " " <> anyType <> "\n\n" <>

480− "func " <>

481− withPrefix name <>

482− "() Any { \n" <>

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

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

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

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

487− " })\n" <>

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

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

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

491− where

492− mainSource :: Text

493− mainSource = "\

494− \func main() {\n\

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

496− \}\n\n\

497− \"

498−

499−varDecl :: Text

500−varDecl = "var"

501−

502−renderArg :: Text -> Text -> Text

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

504−

505−foreignMod :: Text

506−foreignMod = "Foreign"

507−

508−foreignDict :: Text

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"

522−

523−initName :: Text -> Text

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

525−

526−valueName :: Text -> Text

527−valueName s = "ᛧ" <> s

src/Main.hsnew file+73

@@ -0,0 +1,73 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Main

4+-- Copyright : (c) Phil Freeman 2013

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+--

13+-----------------------------------------------------------------------------

14+

15+module Main where

16+

17+import PureScript

18+import Data.Maybe (mapMaybe)

19+import Data.List (intercalate)

20+import System.Console.CmdTheLine

21+import Control.Applicative

22+import System.Exit (exitSuccess, exitFailure)

23+import qualified Text.Parsec as P

24+import qualified System.IO.UTF8 as U

25+import qualified Data.Map as M

26+

27+compile :: [FilePath] -> Maybe FilePath -> Maybe FilePath -> IO ()

28+compile inputFiles outputFile externsFile = do

29+ asts <- fmap (fmap concat . sequence) $ flip mapM inputFiles $ \inputFile -> do

30+ text <- U.readFile inputFile

31+ return $ runIndentParser parseDeclarations text

32+ case asts of

33+ Left err -> do

34+ U.print err

35+ exitFailure

36+ Right decls -> do

37+ case check (typeCheckAll decls) of

38+ Left typeError -> do

39+ U.putStrLn typeError

40+ exitFailure

41+ Right (_, env) -> do

42+ let js = intercalate "\n" $ mapMaybe declToJs decls

43+ case outputFile of

44+ Just path -> U.writeFile path js

45+ Nothing -> U.putStrLn js

46+ case externsFile of

47+ Nothing -> return ()

48+ Just filePath -> U.writeFile filePath $ intercalate "\n" $ mapMaybe (externToPs env) decls

49+ exitSuccess

50+

51+inputFiles :: Term [FilePath]

52+inputFiles = nonEmpty $ posAny [] $ posInfo

53+ { posDoc = "The input .ps files" }

54+

55+outputFile :: Term (Maybe FilePath)

56+outputFile = value $ opt Nothing $ (optInfo [ "o", "output" ])

57+ { optDoc = "The output .js file" }

58+

59+externsFile :: Term (Maybe FilePath)

60+externsFile = value $ opt Nothing $ (optInfo [ "e", "externs" ])

61+ { optDoc = "The output .e.ps file" }

62+

63+term :: Term (IO ())

64+term = compile <$> inputFiles <*> outputFile <*> externsFile

65+

66+termInfo :: TermInfo

67+termInfo = defTI

68+ { termName = "psc"

69+ , version = "1.0"

70+ , termDoc = "Compiles PureScript to Javascript"

71+ }

72+

73+main = run (term, termInfo)

src/PureScript.hsnew file+33

@@ -0,0 +1,33 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : PureScript

4+-- Copyright : (c) Phil Freeman 2013

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+--

13+-----------------------------------------------------------------------------

14+

15+module PureScript (

16+ module PureScript.Values,

17+ module PureScript.Types,

18+ module PureScript.Kinds,

19+ module PureScript.Declarations,

20+ module PureScript.Names,

21+ module PureScript.Parser,

22+ module PureScript.CodeGen,

23+ module PureScript.TypeChecker

24+) where

25+

26+import PureScript.Values

27+import PureScript.Types

28+import PureScript.Kinds

29+import PureScript.Declarations

30+import PureScript.Names

31+import PureScript.Parser

32+import PureScript.CodeGen

33+import PureScript.TypeChecker

src/PureScript/CodeGen.hsnew file+21

@@ -0,0 +1,21 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : PureScript.CodeGen

4+-- Copyright : (c) Phil Freeman 2013

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+--

13+-----------------------------------------------------------------------------

14+

15+module PureScript.CodeGen (

16+ module PureScript.CodeGen.JS,

17+ module PureScript.CodeGen.Externs

18+) where

19+

20+import PureScript.CodeGen.JS

21+import PureScript.CodeGen.Externs

src/PureScript/CodeGen/Common.hsnew file+80

@@ -0,0 +1,80 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : PureScript.CodeGen.Common

4+-- Copyright : (c) Phil Freeman 2013

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+--

13+-----------------------------------------------------------------------------

14+

15+{-# LANGUAGE GeneralizedNewtypeDeriving, GADTs #-}

16+

17+module PureScript.CodeGen.Common where

18+

19+import Data.Char

20+import Data.Maybe (fromMaybe)

21+import Data.List (nub, intersperse, intercalate)

22+import Data.Function (fix)

23+import Control.Monad.State

24+import Control.Applicative (Applicative(..), Alternative(..))

25+import qualified Control.Category as C

26+import Control.Category ((>>>))

27+import qualified Control.Arrow as A

28+import Control.Arrow ((***), (<+>))

29+

30+import PureScript.Names

31+import PureScript.Values

32+import PureScript.Types

33+import PureScript.Declarations

34+

35+identToJs :: Ident -> String

36+identToJs (Ident name) = name

37+identToJs (Op op) = concatMap opCharToString op

38+ where

39+ opCharToString :: Char -> String

40+ opCharToString = (:) '$'. show . ord

41+

42+newtype Pattern a b = Pattern { runPattern :: A.Kleisli Maybe a b } deriving (C.Category, A.Arrow, A.ArrowZero, A.ArrowPlus)

43+

44+instance Functor (Pattern a) where

45+ fmap f (Pattern p) = Pattern $ A.Kleisli $ fmap f . A.runKleisli p

46+

47+pattern :: Pattern a b -> a -> Maybe b

48+pattern = A.runKleisli . runPattern

49+

50+parens :: String -> String

51+parens s = ('(':s) ++ ")"

52+

53+chainl :: Pattern a (a, a) -> (r -> r -> r) -> Pattern a r -> Pattern a r

54+chainl split f p = fix $ \c -> (split >>> ((c <+> p) *** p) >>> A.arr (uncurry f))

55+

56+chainr :: Pattern a (a, a) -> (r -> r -> r) -> Pattern a r -> Pattern a r

57+chainr split f p = fix $ \c -> (split >>> (p *** (c <+> p)) >>> A.arr (uncurry f))

58+

59+wrap :: Pattern a (s, a) -> (s -> r -> r) -> Pattern a r -> Pattern a r

60+wrap split f p = fix $ \c -> (split >>> (C.id *** (c <+> p)) >>> A.arr (uncurry f))

61+

62+split :: Pattern a (s, t) -> (s -> t -> r) -> Pattern a r -> Pattern a r

63+split s f p = (s >>> A.arr (uncurry f))

64+

65+data OperatorTable a r = OperatorTable { runOperatorTable :: [ [Operator a r] ] }

66+

67+data Operator a r where

68+ AssocL :: Pattern a (a, a) -> (r -> r -> r) -> Operator a r

69+ AssocR :: Pattern a (a, a) -> (r -> r -> r) -> Operator a r

70+ Wrap :: Pattern a (s, a) -> (s -> r -> r) -> Operator a r

71+ Split :: Pattern a (s, t) -> (s -> t -> r) -> Operator a r

72+

73+buildPrettyPrinter :: OperatorTable a r -> Pattern a r -> Pattern a r

74+buildPrettyPrinter table p = foldl (\p' ops -> foldl1 (<+>) (flip map ops $ \op ->

75+ case op of

76+ AssocL pat g -> chainl pat g p'

77+ AssocR pat g -> chainr pat g p'

78+ Wrap pat g -> wrap pat g p'

79+ Split pat g -> split pat g p'

80+ ) <+> p') p $ runOperatorTable table

src/PureScript/CodeGen/Common/Gen.hsnew file+31

@@ -0,0 +1,31 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : PureScript.CodeGen.Common.Gen

4+-- Copyright : (c) Phil Freeman 2013

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+--

13+-----------------------------------------------------------------------------

14+

15+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

16+

17+module PureScript.CodeGen.Common.Gen where

18+

19+import Control.Monad.State

20+import Control.Applicative

21+

22+newtype Gen a = Gen { unGen :: State Int a } deriving (Functor, Applicative, Monad, MonadState Int)

23+

24+runGen :: Gen a -> a

25+runGen = flip evalState 0 . unGen

26+

27+fresh :: Gen String

28+fresh = do

29+ n <- get

30+ modify (+ 1)

31+ return $ "_" ++ show n

src/PureScript/CodeGen/Externs.hsnew file+36

@@ -0,0 +1,36 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : PureScript.CodeGen.Externs

4+-- Copyright : (c) Phil Freeman 2013

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+--

13+-----------------------------------------------------------------------------

14+

15+module PureScript.CodeGen.Externs (

16+ externToPs

17+) where

18+

19+import Data.List (intercalate)

20+import qualified Data.Map as M

21+import PureScript.Declarations

22+import PureScript.TypeChecker.Monad

23+import PureScript.CodeGen.Pretty.Types

24+import PureScript.CodeGen.Pretty.Kinds

25+

26+externToPs :: Environment -> Declaration -> Maybe String

27+externToPs env (ValueDeclaration name _) = do

28+ (ty, _) <- M.lookup name $ names env

29+ return $ "extern " ++ show name ++ " :: " ++ prettyPrintPolyType ty

30+externToPs env (ExternDeclaration name ty) =

31+ return $ "extern " ++ show name ++ " :: " ++ prettyPrintPolyType ty

32+externToPs env (ExternDataDeclaration name kind) =

33+ return $ "extern data " ++ name ++ " :: " ++ prettyPrintKind kind

34+externToPs env (TypeSynonymDeclaration name args ty) =

35+ return $ "type " ++ name ++ " " ++ intercalate " " args ++ " = " ++ prettyPrintType ty

36+externToPs _ _ = Nothing

src/PureScript/CodeGen/JS.hsnew file+260

@@ -0,0 +1,260 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : PureScript.CodeGen.JS

4+-- Copyright : (c) Phil Freeman 2013

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+--

13+-----------------------------------------------------------------------------

14+

15+module PureScript.CodeGen.JS (

16+ declToJs

17+) where

18+

19+import Data.Char

20+import Data.Maybe (fromMaybe)

21+import Data.List (intercalate)

22+import qualified Control.Arrow as A

23+import Control.Arrow ((<+>))

24+import Control.Applicative

25+

26+import PureScript.Types

27+import PureScript.Values

28+import PureScript.Names

29+import PureScript.Declarations

30+import PureScript.CodeGen.Common

31+import PureScript.CodeGen.Common.Gen

32+

33+declToJs :: Declaration -> Maybe String

34+declToJs (ValueDeclaration ident (Abs args ret)) = Just $ "function " ++ identToJs ident ++ "(" ++ intercalate "," (map identToJs args) ++ ") { return " ++ valueToJs ret ++ "; }"

35+declToJs (ValueDeclaration ident val) = Just $ "var " ++ identToJs ident ++ " = " ++ valueToJs val ++ ";"

36+declToJs (DataDeclaration _ _ ctors) =

37+ Just $ flip concatMap ctors $ \(ctor, maybeTy) ->

38+ case maybeTy of

39+ Nothing -> "var " ++ ctor ++ " = { ctor: '" ++ ctor ++ "' };"

40+ Just _ -> "var " ++ ctor ++ " = function (value) { return { ctor: '" ++ ctor ++ "', value: value }; };"

41+declToJs _ = Nothing

42+

43+literals :: Pattern Value String

44+literals = Pattern $ A.Kleisli match

45+ where

46+ match (NumericLiteral n) = Just $ either show show n

47+ match (StringLiteral s) = Just $ show s

48+ match (BooleanLiteral True) = Just "true"

49+ match (BooleanLiteral False) = Just "false"

50+ match (ArrayLiteral xs) = Just $ "[" ++ intercalate "," (map valueToJs xs) ++ "]"

51+ match (ObjectLiteral ps) = Just $ "{" ++ intercalate "," (map objectPropertyToJs ps) ++ "}"

52+ match (Constructor name) = Just name

53+ match (Block sts) = Just $ "(function () {" ++ intercalate ";" (map statementToJs sts) ++ "})()"

54+ match (Case value binders) = Just $ "(" ++ runGen (bindersToJs binders) ++ ")(" ++ valueToJs value ++ ")"

55+ where

56+ bindersToJs :: [(Binder, Value)] -> Gen String

57+ bindersToJs binders = do

58+ valName <- fresh

59+ jss <- flip mapM binders $ \(binder, result) -> do

60+ let js = valueToJs result

61+ binderToJs valName ("return " ++ js ++ ";") binder

62+ return $ "function (" ++ valName ++ ") {" ++ concat jss ++ "throw \"Failed pattern match\"; }"

63+ match (Var ident) = Just (identToJs ident)

64+ match _ = Nothing

65+

66+ifThenElse :: Pattern Value ((Value, Value), Value)

67+ifThenElse = Pattern $ A.Kleisli match

68+ where

69+ match (IfThenElse cond th el) = Just ((th, el), cond)

70+ match _ = Nothing

71+

72+accessor :: Pattern Value (String, Value)

73+accessor = Pattern $ A.Kleisli match

74+ where

75+ match (Accessor prop val) = Just (prop, val)

76+ match _ = Nothing

77+

78+indexer :: Pattern Value (String, Value)

79+indexer = Pattern $ A.Kleisli match

80+ where

81+ match (Indexer index val) = Just (valueToJs index, val)

82+ match _ = Nothing

83+

84+app :: Pattern Value (String, Value)

85+app = Pattern $ A.Kleisli match

86+ where

87+ match (App val args) = Just (intercalate "," (map valueToJs args), val)

88+ match _ = Nothing

89+

90+lam :: Pattern Value ([String], Value)

91+lam = Pattern $ A.Kleisli match

92+ where

93+ match (Abs args val) = Just (map identToJs args, val)

94+ match _ = Nothing

95+

96+unary :: UnaryOperator -> String -> Operator Value String

97+unary op str = Wrap pattern (++)

98+ where

99+ pattern :: Pattern Value (String, Value)

100+ pattern = Pattern $ A.Kleisli match

101+ where

102+ match (Unary op' val) | op' == op = Just (str, val)

103+ match _ = Nothing

104+

105+binary :: BinaryOperator -> String -> Operator Value String

106+binary op str = AssocR pattern (\v1 v2 -> v1 ++ " " ++ str ++ " " ++ v2)

107+ where

108+ pattern :: Pattern Value (Value, Value)

109+ pattern = Pattern $ A.Kleisli match

110+ where

111+ match (Binary op' v1 v2) | op' == op = Just (v1, v2)

112+ match _ = Nothing

113+

114+valueToJs :: Value -> String

115+valueToJs = fromMaybe (error "Incomplete pattern") . pattern matchValue

116+ where

117+ matchValue :: Pattern Value String

118+ matchValue = buildPrettyPrinter operators (literals <+> fmap parens matchValue)

119+ operators :: OperatorTable Value String

120+ operators =

121+ OperatorTable $ [ [ Wrap accessor $ \prop val -> val ++ "." ++ prop ]

122+ , [ Wrap indexer $ \index val -> val ++ "[" ++ index ++ "]" ]

123+ , [ Wrap app $ \args val -> val ++ "(" ++ args ++ ")" ]

124+ , [ Split lam $ \args val -> "function (" ++ intercalate "," args ++ ") { return " ++ valueToJs val ++ "; }" ]

125+ , [ Wrap ifThenElse $ \(th, el) cond -> cond ++ " ? " ++ valueToJs th ++ " : " ++ valueToJs el ]

126+ , [ binary LessThan "<" ]

127+ , [ binary LessThanOrEqualTo "<=" ]

128+ , [ binary GreaterThan ">" ]

129+ , [ binary GreaterThanOrEqualTo ">=" ]

130+ , [ unary Not "!" ]

131+ , [ unary BitwiseNot "~" ]

132+ , [ unary Negate "-" ]

133+ , [ binary Multiply "*" ]

134+ , [ binary Divide "/" ]

135+ , [ binary Modulus "%" ]

136+ , [ binary Concat "+" ]

137+ , [ binary Add "+" ]

138+ , [ binary Subtract "-" ]

139+ , [ binary ShiftLeft "<<" ]

140+ , [ binary ShiftRight ">>" ]

141+ , [ binary ZeroFillShiftRight ">>>" ]

142+ , [ binary EqualTo "===" ]

143+ , [ binary NotEqualTo "!==" ]

144+ , [ binary BitwiseAnd "&" ]

145+ , [ binary BitwiseXor "^" ]

146+ , [ binary BitwiseOr "|" ]

147+ , [ binary And "&&" ]

148+ , [ binary Or "||" ]

149+ ]

150+

151+unaryOperatorString :: UnaryOperator -> String

152+unaryOperatorString Negate = "-"

153+unaryOperatorString Not = "!"

154+unaryOperatorString BitwiseNot = "~"

155+

156+binaryOperatorString :: BinaryOperator -> String

157+binaryOperatorString Add = "+"

158+binaryOperatorString Subtract = "-"

159+binaryOperatorString Multiply = "*"

160+binaryOperatorString Divide = "/"

161+binaryOperatorString Modulus = "%"

162+binaryOperatorString LessThan = "<"

163+binaryOperatorString LessThanOrEqualTo = "<="

164+binaryOperatorString GreaterThan = ">"

165+binaryOperatorString GreaterThanOrEqualTo = ">="

166+binaryOperatorString BitwiseAnd = "&"

167+binaryOperatorString BitwiseOr = "|"

168+binaryOperatorString BitwiseXor = "^"

169+binaryOperatorString ShiftLeft = "<<"

170+binaryOperatorString ShiftRight = ">>"

171+binaryOperatorString ZeroFillShiftRight = ">>>"

172+binaryOperatorString EqualTo = "==="

173+binaryOperatorString NotEqualTo = "!=="

174+binaryOperatorString And = "&&"

175+binaryOperatorString Or = "||"

176+binaryOperatorString Concat = "+"

177+

178+binderToJs :: String -> String -> Binder -> Gen String

179+binderToJs varName done NullBinder = return done

180+binderToJs varName done (StringBinder str) =

181+ return $ "if (" ++ varName ++ " === \"" ++ str ++ "\") {" ++ done ++ " }"

182+binderToJs varName done (NumberBinder num) =

183+ return $ "if (" ++ varName ++ " === " ++ either show show num ++ ") {" ++ done ++ " }"

184+binderToJs varName done (BooleanBinder True) =

185+ return $ "if (" ++ varName ++ ") {" ++ done ++ " }"

186+binderToJs varName done (BooleanBinder False) =

187+ return $ "if (!" ++ varName ++ ") {" ++ done ++ " }"

188+binderToJs varName done (VarBinder ident) =

189+ return $ "var " ++ identToJs ident ++ " = " ++ varName ++ "; " ++ done

190+binderToJs varName done (NullaryBinder ctor) =

191+ return $ "if (" ++ varName ++ ".ctor === \"" ++ ctor ++ "\") { " ++ done ++ " }"

192+binderToJs varName done (UnaryBinder ctor b) = do

193+ value <- fresh

194+ js <- binderToJs value done b

195+ return $ "if (" ++ varName ++ ".ctor === \"" ++ ctor ++ "\") { " ++ "var " ++ value ++ " = " ++ varName ++ ".value; " ++ js ++ " }"

196+binderToJs varName done (ObjectBinder bs) = go done bs

197+ where

198+ go done [] = return done

199+ go done ((prop, binder):bs) = do

200+ propVar <- fresh

201+ done' <- go done bs

202+ js <- binderToJs propVar done' binder

203+ return $ "var " ++ propVar ++ " = " ++ varName ++ "." ++ prop ++ ";" ++ js

204+binderToJs varName done (ArrayBinder bs rest) = do

205+ js <- go done rest 0 bs

206+ return $ "if (" ++ varName ++ ".length " ++ cmp ++ " " ++ show (length bs) ++ ") { " ++ js ++ " }"

207+ where

208+ cmp = maybe "===" (const ">=") rest

209+ go done Nothing _ [] = return done

210+ go done (Just binder) index [] = do

211+ restVar <- fresh

212+ js <- binderToJs restVar done binder

213+ return $ "var " ++ restVar ++ " = " ++ varName ++ ".slice(" ++ show index ++ "); " ++ js

214+ go done rest index (binder:bs) = do

215+ elVar <- fresh

216+ done' <- go done rest (index + 1) bs

217+ js <- binderToJs elVar done' binder

218+ return $ "var " ++ elVar ++ " = " ++ varName ++ "[" ++ show index ++ "]; " ++ js

219+binderToJs varName done (NamedBinder ident binder) = do

220+ js <- binderToJs varName done binder

221+ return $ "var " ++ identToJs ident ++ " = " ++ varName ++ "; " ++ js

222+binderToJs varName done (GuardedBinder cond binder) = binderToJs varName done' binder

223+ where

224+ done' = "if (" ++ valueToJs cond ++ ") { " ++ done ++ "}"

225+

226+objectPropertyToJs :: (String, Value) -> String

227+objectPropertyToJs (key, value) = key ++ ":" ++ valueToJs value

228+

229+statementToJs :: Statement -> String

230+statementToJs (VariableIntroduction ident value) = "var " ++ identToJs ident ++ " = " ++ valueToJs value

231+statementToJs (Assignment target value) = assignmentTargetToJs target ++ " = " ++ valueToJs value

232+statementToJs (While cond sts) = "while ("

233+ ++ valueToJs cond ++ ") {"

234+ ++ intercalate ";" (map statementToJs sts) ++ "}"

235+statementToJs (For ident start end sts) = "for (" ++

236+ identToJs ident ++ " = " ++ valueToJs start ++ ";"

237+ ++ identToJs ident ++ " < " ++ valueToJs end ++ ";"

238+ ++ identToJs ident ++ "++) {"

239+ ++ intercalate ";" (map statementToJs sts) ++ "}"

240+statementToJs (ForEach ident arr sts) = valueToJs arr

241+ ++ ".forEach(function(" ++ identToJs ident ++ ") {"

242+ ++ intercalate ";" (map statementToJs sts) ++ "})"

243+statementToJs (If ifst) = ifStatementToJs ifst

244+statementToJs (Return value) = "return " ++ valueToJs value

245+

246+ifStatementToJs :: IfStatement -> String

247+ifStatementToJs (IfStatement cond thens elst) =

248+ "if ("

249+ ++ valueToJs cond ++ ") {"

250+ ++ intercalate ";" (map statementToJs thens) ++ "}"

251+ ++ maybe "" elseStatementToJs elst

252+

253+elseStatementToJs :: ElseStatement -> String

254+elseStatementToJs (Else sts) = " else {" ++ intercalate ";" (map statementToJs sts) ++ "}"

255+elseStatementToJs (ElseIf ifst) = " else " ++ ifStatementToJs ifst

256+

257+assignmentTargetToJs :: AssignmentTarget -> String

258+assignmentTargetToJs (AssignVariable ident) = identToJs ident

259+assignmentTargetToJs (AssignArrayIndex index tgt) = assignmentTargetToJs tgt ++ "[" ++ valueToJs index ++ "]"

260+assignmentTargetToJs (AssignObjectProperty prop tgt) = assignmentTargetToJs tgt ++ "." ++ prop

src/PureScript/CodeGen/Pretty/Kinds.hsnew file+50

@@ -0,0 +1,50 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : PureScript.CodeGen.Pretty.Kinds

4+-- Copyright : (c) Phil Freeman 2013

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+--

13+-----------------------------------------------------------------------------

14+

15+module PureScript.CodeGen.Pretty.Kinds (

16+ prettyPrintKind

17+) where

18+

19+import Data.Maybe (fromMaybe)

20+import Data.List (intersperse, intercalate)

21+import qualified Control.Arrow as A

22+import Control.Arrow ((<+>))

23+import qualified Data.Map as M

24+import Control.Applicative

25+

26+import PureScript.Kinds

27+import PureScript.CodeGen.Common

28+

29+typeLiterals :: Pattern Kind String

30+typeLiterals = Pattern $ A.Kleisli match

31+ where

32+ match Star = Just "*"

33+ match Row = Just "ρ"

34+ match (KUnknown u) = Just $ "u" ++ show u

35+ match _ = Nothing

36+

37+funKind :: Pattern Kind (Kind, Kind)

38+funKind = Pattern $ A.Kleisli match

39+ where

40+ match (FunKind arg ret) = Just (arg, ret)

41+ match _ = Nothing

42+

43+prettyPrintKind :: Kind -> String

44+prettyPrintKind = fromMaybe (error "Incomplete pattern") . pattern matchKind

45+ where

46+ matchKind :: Pattern Kind String

47+ matchKind = buildPrettyPrinter operators (typeLiterals <+> fmap parens matchKind)

48+ operators :: OperatorTable Kind String

49+ operators =

50+ OperatorTable $ [ [ AssocR funKind $ \arg ret -> arg ++ " -> " ++ ret ] ]

src/PureScript/CodeGen/Pretty/Types.hsnew file+96

@@ -0,0 +1,96 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : PureScript.CodeGen.Pretty.Types

4+-- Copyright : (c) Phil Freeman 2013

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+--

13+-----------------------------------------------------------------------------

14+

15+module PureScript.CodeGen.Pretty.Types (

16+ prettyPrintType,

17+ prettyPrintRow,

18+ prettyPrintPolyType

19+) where

20+

21+import Data.Maybe (fromMaybe)

22+import Data.List (intersperse, intercalate)

23+import qualified Control.Arrow as A

24+import Control.Arrow ((<+>))

25+import qualified Data.Map as M

26+import Control.Applicative

27+

28+import PureScript.Values

29+import PureScript.Types

30+import PureScript.Names

31+import PureScript.Declarations

32+import PureScript.TypeChecker.Monad

33+import PureScript.CodeGen.Common

34+

35+typeLiterals :: Pattern Type String

36+typeLiterals = Pattern $ A.Kleisli match

37+ where

38+ match Number = Just "Number"

39+ match String = Just "String"

40+ match Boolean = Just "Boolean"

41+ match (Array ty) = Just $ "[" ++ prettyPrintType ty ++ "]"

42+ match (Object row) = Just $ "{ " ++ prettyPrintRow row ++ " }"

43+ match (TypeVar var) = Just var

44+ match (TypeConstructor ctor) = Just ctor

45+ match (TUnknown u) = Just $ "u" ++ show u

46+ match (SaturatedTypeSynonym name args) = Just $ name ++ "<" ++ intercalate "," (map prettyPrintType args) ++ ">"

47+ match _ = Nothing

48+

49+prettyPrintRow :: Row -> String

50+prettyPrintRow = (\(tys, tail) -> intercalate "; " (map (uncurry nameAndTypeToPs) tys) ++ tailToPs tail) . toList

51+ where

52+ nameAndTypeToPs :: String -> Type -> String

53+ nameAndTypeToPs name ty = name ++ " :: " ++ prettyPrintType ty

54+ tailToPs :: Row -> String

55+ tailToPs REmpty = ""

56+ tailToPs (RUnknown u) = show u

57+ tailToPs (RowVar var) = " | " ++ var

58+ toList :: Row -> ([(String, Type)], Row)

59+ toList (RCons name ty row) = let (tys, rest) = toList row

60+ in ((name, ty):tys, rest)

61+ toList r = ([], r)

62+

63+typeApp :: Pattern Type (Type, Type)

64+typeApp = Pattern $ A.Kleisli match

65+ where

66+ match (TypeApp f x) = Just (f, x)

67+ match _ = Nothing

68+

69+singleArgumentFunction :: Pattern Type (Type, Type)

70+singleArgumentFunction = Pattern $ A.Kleisli match

71+ where

72+ match (Function [arg] ret) = Just (arg, ret)

73+ match _ = Nothing

74+

75+function :: Pattern Type ([Type], Type)

76+function = Pattern $ A.Kleisli match

77+ where

78+ match (Function args ret) = Just (args, ret)

79+ match _ = Nothing

80+

81+prettyPrintType :: Type -> String

82+prettyPrintType = fromMaybe (error "Incomplete pattern") . pattern matchType

83+ where

84+ matchType :: Pattern Type String

85+ matchType = buildPrettyPrinter operators (typeLiterals <+> fmap parens matchType)

86+ operators :: OperatorTable Type String

87+ operators =

88+ OperatorTable $ [ [ AssocL typeApp $ \f x -> f ++ " " ++ x ]

89+ , [ AssocR singleArgumentFunction $ \arg ret -> arg ++ " -> " ++ ret

90+ , Wrap function $ \args ret -> "(" ++ intercalate ", " (map prettyPrintType args) ++ ") -> " ++ ret

91+ ]

92+ ]

93+

94+prettyPrintPolyType :: PolyType -> String

95+prettyPrintPolyType (PolyType [] ty) = prettyPrintType ty

96+prettyPrintPolyType (PolyType idents ty) = "forall " ++ intercalate " " idents ++ ". " ++ prettyPrintType ty

src/PureScript/Declarations.hsnew file+39

@@ -0,0 +1,39 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : PureScript.Declarations

4+-- Copyright : (c) Phil Freeman 2013

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+--

13+-----------------------------------------------------------------------------

14+

15+{-# LANGUAGE DeriveDataTypeable #-}

16+

17+module PureScript.Declarations where

18+

19+import PureScript.Values

20+import PureScript.Types

21+import PureScript.Names

22+import PureScript.Kinds

23+

24+import qualified Data.Data as D

25+

26+type Precedence = Integer

27+

28+data Associativity = Infixl | Infixr deriving (Show, D.Data, D.Typeable)

29+

30+data Fixity = Fixity Associativity Precedence deriving (Show, D.Data, D.Typeable)

31+

32+data Declaration

33+ = DataDeclaration String [String] [(String, Maybe Type)]

34+ | TypeSynonymDeclaration String [String] Type

35+ | TypeDeclaration Ident PolyType

36+ | ValueDeclaration Ident Value

37+ | ExternDeclaration Ident PolyType

38+ | ExternDataDeclaration String Kind

39+ | FixityDeclaration Fixity String deriving (Show, D.Data, D.Typeable)

src/PureScript/Kinds.hsnew file+25

@@ -0,0 +1,25 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : PureScript.Kinds

4+-- Copyright : (c) Phil Freeman 2013

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+--

13+-----------------------------------------------------------------------------

14+

15+{-# LANGUAGE DeriveDataTypeable #-}

16+

17+module PureScript.Kinds where

18+

19+import Data.Data

20+

21+data Kind

22+ = KUnknown Int

23+ | Star

24+ | Row

25+ | FunKind Kind Kind deriving (Show, Eq, Data, Typeable)

src/PureScript/Names.hsnew file+26

@@ -0,0 +1,26 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : PureScript.Names

4+-- Copyright : (c) Phil Freeman 2013

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+--

13+-----------------------------------------------------------------------------

14+

15+{-# LANGUAGE DeriveDataTypeable #-}

16+

17+module PureScript.Names where

18+

19+import Data.Data

20+

21+data Ident = Ident String | Op String deriving (Eq, Ord, Data, Typeable)

22+

23+instance Show Ident where

24+ show (Ident s) = s

25+ show (Op op) = '(':op ++ ")"

26+

src/PureScript/Parser.hsnew file+26

@@ -0,0 +1,26 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : PureScript.Parser

4+-- Copyright : (c) Phil Freeman 2013

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+--

13+-----------------------------------------------------------------------------

14+

15+module PureScript.Parser (

16+ module PureScript.Parser.Common,

17+ module PureScript.Parser.Types,

18+ module PureScript.Parser.Values,

19+ module PureScript.Parser.Declarations

20+) where

21+

22+import PureScript.Parser.Common

23+import PureScript.Parser.Types

24+import PureScript.Parser.Values

25+import PureScript.Parser.Declarations

26+

src/PureScript/Parser/Common.hsnew file+181

@@ -0,0 +1,181 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : PureScript.Parser.Common

4+-- Copyright : (c) Phil Freeman 2013

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+--

13+-----------------------------------------------------------------------------

14+

15+{-# LANGUAGE FlexibleContexts #-}

16+

17+module PureScript.Parser.Common where

18+

19+import Data.Char (isSpace)

20+import Control.Applicative

21+import Control.Monad

22+import Control.Monad.State

23+import PureScript.Parser.State

24+import qualified Data.Map as M

25+import qualified Text.Parsec as P

26+import qualified Text.Parsec.Pos as P

27+import qualified Text.Parsec.Token as PT

28+

29+import PureScript.Names

30+

31+reservedNames :: [String]

32+reservedNames = [ "case"

33+ , "of"

34+ , "data"

35+ , "type"

36+ , "var"

37+ , "val"

38+ , "while"

39+ , "for"

40+ , "foreach"

41+ , "if"

42+ , "then"

43+ , "else"

44+ , "return"

45+ , "true"

46+ , "false"

47+ , "extern"

48+ , "forall"

49+ , "do"

50+ , "until"

51+ , "in"

52+ , "break"

53+ , "catch"

54+ , "continue"

55+ , "debugger"

56+ , "default"

57+ , "delete"

58+ , "finally"

59+ , "function"

60+ , "instanceof"

61+ , "new"

62+ , "switch"

63+ , "this"

64+ , "throw"

65+ , "try"

66+ , "typeof"

67+ , "void"

68+ , "with"

69+ , "Number"

70+ , "String"

71+ , "Boolean"

72+ , "infixl"

73+ , "infixr" ]

74+

75+reservedOpNames :: [String]

76+reservedOpNames = [ "!", "~", "-", "<=", ">=", "<", ">", "*", "/", "%", "++", "+", "<<", ">>>", ">>"

77+ , "==", "!=", "&", "^", "|", "&&", "||", "->" ]

78+

79+identStart :: P.Parsec String u Char

80+identStart = P.lower <|> P.oneOf "_$"

81+

82+properNameStart :: P.Parsec String u Char

83+properNameStart = P.upper

84+

85+identLetter :: P.Parsec String u Char

86+identLetter = P.alphaNum <|> P.oneOf "_'"

87+

88+opStart :: P.Parsec String u Char

89+opStart = P.oneOf "!#$%&*+/<=>?@^|-~"

90+

91+opLetter :: P.Parsec String u Char

92+opLetter = P.oneOf ":#$%&*+./<=>?@^|"

93+

94+langDef = PT.LanguageDef

95+ { PT.reservedNames = reservedNames

96+ , PT.reservedOpNames = reservedOpNames

97+ , PT.commentStart = "{-"

98+ , PT.commentEnd = "-}"

99+ , PT.commentLine = "--"

100+ , PT.nestedComments = True

101+ , PT.identStart = identStart

102+ , PT.identLetter = identLetter

103+ , PT.opStart = opStart

104+ , PT.opLetter = opLetter

105+ , PT.caseSensitive = True

106+ }

107+

108+tokenParser = PT.makeTokenParser langDef

109+

110+lexeme = PT.lexeme tokenParser

111+identifier = PT.identifier tokenParser

112+reserved = PT.reserved tokenParser

113+reservedOp = PT.reservedOp tokenParser

114+operator = PT.operator tokenParser

115+stringLiteral = PT.stringLiteral tokenParser

116+whiteSpace = PT.whiteSpace tokenParser

117+parens = PT.parens tokenParser

118+braces = PT.braces tokenParser

119+angles = PT.angles tokenParser

120+squares = PT.squares tokenParser

121+semi = PT.semi tokenParser

122+comma = PT.comma tokenParser

123+colon = PT.colon tokenParser

124+dot = PT.dot tokenParser

125+semiSep = PT.semiSep tokenParser

126+semiSep1 = PT.semiSep1 tokenParser

127+commaSep = PT.commaSep tokenParser

128+commaSep1 = PT.commaSep1 tokenParser

129+natural = PT.natural tokenParser

130+

131+tick :: P.Parsec String u Char

132+tick = lexeme $ P.char '`'

133+

134+properName :: P.Parsec String u String

135+properName = lexeme $ P.try ((:) <$> P.upper <*> many (PT.identLetter langDef) P.<?> "name")

136+

137+integerOrFloat :: P.Parsec String u (Either Integer Double)

138+integerOrFloat = (Left <$> P.try (PT.natural tokenParser) <|>

139+ Right <$> P.try (PT.float tokenParser)) P.<?> "number"

140+

141+augment :: P.Stream s m t => P.ParsecT s u m a -> P.ParsecT s u m b -> (a -> b -> a) -> P.ParsecT s u m a

142+augment p q f = (flip $ maybe id $ flip f) <$> p <*> P.optionMaybe q

143+

144+fold :: P.Stream s m t => P.ParsecT s u m a -> P.ParsecT s u m b -> (a -> b -> a) -> P.ParsecT s u m a

145+fold first more combine = do

146+ a <- first

147+ bs <- P.many more

148+ return $ foldl combine a bs

149+

150+buildPostfixParser :: P.Stream s m t => [P.ParsecT s u m (a -> a)] -> P.ParsecT s u m a -> P.ParsecT s u m a

151+buildPostfixParser f x = fold x (P.choice (map P.try f)) (flip ($))

152+

153+parseIdent :: P.Parsec String u Ident

154+parseIdent = (Ident <$> identifier) <|> (Op <$> parens operator)

155+

156+parseIdentInfix :: P.Parsec String u Ident

157+parseIdentInfix = (Ident <$> P.between tick tick identifier) <|> (Op <$> operator)

158+

159+mark :: P.Parsec String ParseState a -> P.Parsec String ParseState a

160+mark p = do

161+ current <- indentationLevel <$> P.getState

162+ pos <- P.sourceColumn <$> P.getPosition

163+ P.modifyState $ \st -> st { indentationLevel = pos }

164+ a <- p

165+ P.modifyState $ \st -> st { indentationLevel = current }

166+ return a

167+

168+checkIndentation :: (P.Column -> P.Column -> Bool) -> P.Parsec String ParseState ()

169+checkIndentation rel = do

170+ col <- P.sourceColumn <$> P.getPosition

171+ current <- indentationLevel <$> P.getState

172+ guard (col `rel` current)

173+

174+indented :: P.Parsec String ParseState ()

175+indented = checkIndentation (>) P.<?> "indentation"

176+

177+same :: P.Parsec String ParseState ()

178+same = checkIndentation (==) P.<?> "no indentation"

179+

180+runIndentParser :: P.Parsec String ParseState a -> String -> Either P.ParseError a

181+runIndentParser p = P.runParser p (ParseState 0 M.empty) ""

src/PureScript/Parser/Declarations.hsnew file+100

@@ -0,0 +1,100 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : PureScript.Parser.Declarations

4+-- Copyright : (c) Phil Freeman 2013

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+--

13+-----------------------------------------------------------------------------

14+

15+module PureScript.Parser.Declarations (

16+ parseDeclaration,

17+ parseDeclarations

18+) where

19+

20+import Data.Char

21+import Data.List

22+import Data.Maybe

23+import Data.Function

24+import Control.Applicative

25+import Control.Arrow (Arrow(..))

26+import Control.Monad.State

27+import qualified Data.Map as M

28+import qualified Text.Parsec as P

29+import qualified Text.Parsec.Pos as P

30+

31+import PureScript.Values

32+import PureScript.Types

33+import PureScript.Parser.State

34+import PureScript.Parser.Common

35+import PureScript.Declarations

36+import PureScript.Parser.Values

37+import PureScript.Parser.Types

38+import PureScript.Parser.Kinds

39+

40+parseDataDeclaration :: P.Parsec String ParseState Declaration

41+parseDataDeclaration = do

42+ reserved "data"

43+ name <- indented *> properName

44+ tyArgs <- many (indented *> identifier)

45+ lexeme $ indented *> P.char '='

46+ ctors <- P.sepBy1 ((,) <$> (indented *> properName) <*> P.optionMaybe parseType) (lexeme $ indented *> P.char '|')

47+ return $ DataDeclaration name tyArgs ctors

48+

49+parseTypeDeclaration :: P.Parsec String ParseState Declaration

50+parseTypeDeclaration =

51+ TypeDeclaration <$> parseIdent

52+ <*> (lexeme (indented *> P.string "::") *> parsePolyType)

53+

54+parseTypeSynonymDeclaration :: P.Parsec String ParseState Declaration

55+parseTypeSynonymDeclaration =

56+ TypeSynonymDeclaration <$> (reserved "type" *> indented *> properName)

57+ <*> many (indented *> identifier)

58+ <*> (lexeme (indented *> P.char '=') *> parseType)

59+

60+parseValueDeclaration :: P.Parsec String ParseState Declaration

61+parseValueDeclaration =

62+ ValueDeclaration <$> parseIdent

63+ <*> (lexeme (indented *> P.char '=') *> parseValue)

64+

65+parseExternDeclaration :: P.Parsec String ParseState Declaration

66+parseExternDeclaration = reserved "extern" *> indented *>

67+ (ExternDataDeclaration <$> (reserved "data" *> indented *> properName)

68+ <*> (lexeme (indented *> P.string "::") *> parseKind)

69+ <|> ExternDeclaration <$> parseIdent

70+ <*> (lexeme (indented *> P.string "::") *> parsePolyType))

71+

72+parseAssociativity :: P.Parsec String ParseState Associativity

73+parseAssociativity =

74+ (reserved "infixl" >> return Infixl) <|>

75+ (reserved "infixr" >> return Infixr)

76+

77+parseFixity :: P.Parsec String ParseState Fixity

78+parseFixity = Fixity <$> parseAssociativity <*> (indented *> natural)

79+

80+parseFixityDeclaration :: P.Parsec String ParseState Declaration

81+parseFixityDeclaration = do

82+ fixity <- parseFixity

83+ indented

84+ name <- operator

85+ current <- fixities <$> P.getState

86+ when (name `M.member` current) (P.unexpected $ "redefined fixity for " ++ show name)

87+ P.modifyState $ \st -> st { fixities = M.insert name fixity current }

88+ return $ FixityDeclaration fixity name

89+

90+parseDeclaration :: P.Parsec String ParseState Declaration

91+parseDeclaration = P.choice (map P.try

92+ [ parseDataDeclaration

93+ , parseTypeDeclaration

94+ , parseTypeSynonymDeclaration

95+ , parseValueDeclaration

96+ , parseExternDeclaration

97+ , parseFixityDeclaration ]) P.<?> "declaration"

98+

99+parseDeclarations :: P.Parsec String ParseState [Declaration]

100+parseDeclarations = whiteSpace *> mark (same *> P.many parseDeclaration) <* P.eof

src/PureScript/Parser/Kinds.hsnew file+41

@@ -0,0 +1,41 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : PureScript.Parser.Kinds

4+-- Copyright : (c) Phil Freeman 2013

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+--

13+-----------------------------------------------------------------------------

14+

15+module PureScript.Parser.Kinds (

16+ parseKind

17+) where

18+

19+import PureScript.Kinds

20+import PureScript.Parser.State

21+import PureScript.Parser.Common

22+import Control.Applicative

23+import qualified Text.Parsec as P

24+import qualified Text.Parsec.Expr as P

25+

26+parseStar :: P.Parsec String ParseState Kind

27+parseStar = const Star <$> lexeme (P.char '*')

28+

29+parseRow :: P.Parsec String ParseState Kind

30+parseRow = const Row <$> lexeme (P.char 'ρ')

31+

32+parseTypeAtom :: P.Parsec String ParseState Kind

33+parseTypeAtom = indented *> P.choice (map P.try

34+ [ parseStar

35+ , parseRow

36+ , parens parseKind ])

37+

38+parseKind :: P.Parsec String ParseState Kind

39+parseKind = P.buildExpressionParser operators parseTypeAtom P.<?> "kind"

40+ where

41+ operators = [ [ P.Infix (lexeme (P.try (P.string "->")) >> return FunKind) P.AssocRight ] ]

src/PureScript/Parser/State.hsnew file+27

@@ -0,0 +1,27 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : PureScript.Parser.State

4+-- Copyright : (c) Phil Freeman 2013

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+--

13+-----------------------------------------------------------------------------

14+

15+module PureScript.Parser.State where

16+

17+import PureScript.Names

18+import PureScript.Declarations

19+

20+import qualified Text.Parsec as P

21+import qualified Data.Map as M

22+

23+data ParseState = ParseState

24+ { indentationLevel :: P.Column

25+ , fixities :: M.Map String Fixity } deriving Show

26+

27+

src/PureScript/Parser/Types.hsnew file+91

@@ -0,0 +1,91 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : PureScript.Parser.Types

4+-- Copyright : (c) Phil Freeman 2013

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+--

13+-----------------------------------------------------------------------------

14+

15+module PureScript.Parser.Types (

16+ parseType,

17+ parsePolyType,

18+ parseRow

19+) where

20+

21+import PureScript.Types

22+import PureScript.Parser.State

23+import PureScript.Parser.Common

24+import Control.Applicative

25+import qualified Text.Parsec as P

26+import qualified Text.Parsec.Expr as P

27+import Control.Arrow (Arrow(..))

28+

29+parseNumber :: P.Parsec String ParseState Type

30+parseNumber = const Number <$> reserved "Number"

31+

32+parseString :: P.Parsec String ParseState Type

33+parseString = const String <$> reserved "String"

34+

35+parseBoolean :: P.Parsec String ParseState Type

36+parseBoolean = const Boolean <$> reserved "Boolean"

37+

38+parseArray :: P.Parsec String ParseState Type

39+parseArray = squares $ Array <$> parseType

40+

41+parseObject :: P.Parsec String ParseState Type

42+parseObject = braces $ Object <$> parseRow

43+

44+parseFunction :: P.Parsec String ParseState Type

45+parseFunction = do

46+ args <- lexeme $ parens $ commaSep parseType

47+ lexeme $ P.string "->"

48+ resultType <- parseType

49+ return $ Function args resultType

50+

51+parseTypeVariable :: P.Parsec String ParseState Type

52+parseTypeVariable = TypeVar <$> identifier

53+

54+parseTypeConstructor :: P.Parsec String ParseState Type

55+parseTypeConstructor = TypeConstructor <$> properName

56+

57+parseTypeAtom :: P.Parsec String ParseState Type

58+parseTypeAtom = indented *> P.choice (map P.try

59+ [ parseNumber

60+ , parseString

61+ , parseBoolean

62+ , parseArray

63+ , parseObject

64+ , parseFunction

65+ , parseTypeVariable

66+ , parseTypeConstructor

67+ , parens parseType ])

68+

69+parsePolyType :: P.Parsec String ParseState PolyType

70+parsePolyType = (PolyType <$> (P.option [] (indented *> reserved "forall" *> many (indented *> identifier) <* indented <* dot))

71+ <*> parseType) P.<?> "polymorphic type"

72+

73+parseType :: P.Parsec String ParseState Type

74+parseType = (P.buildExpressionParser operators . buildPostfixParser postfixTable $ parseTypeAtom) P.<?> "type"

75+ where

76+ postfixTable :: [P.Parsec String ParseState (Type -> Type)]

77+ postfixTable = [ flip TypeApp <$> (indented *> parseTypeAtom) ]

78+ operators = [ [ P.Infix (lexeme (P.try (P.string "->")) >> return (\t1 t2 -> Function [t1] t2)) P.AssocRight ] ]

79+

80+parseNameAndType :: P.Parsec String ParseState (String, Type)

81+parseNameAndType = (,) <$> (indented *> identifier <* indented <* lexeme (P.string "::")) <*> parseType

82+

83+parseRowEnding :: P.Parsec String ParseState Row

84+parseRowEnding = P.option REmpty (RowVar <$> (lexeme (indented *> P.char '|') *> indented *> identifier))

85+

86+parseRow :: P.Parsec String ParseState Row

87+parseRow = (fromList <$> (parseNameAndType `P.sepBy` (indented *> semi)) <*> parseRowEnding) P.<?> "row"

88+ where

89+ fromList :: [(String, Type)] -> Row -> Row

90+ fromList [] r = r

91+ fromList ((name, t):ts) r = RCons name t (fromList ts r)

src/PureScript/Parser/Values.hsnew file+287

@@ -0,0 +1,287 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : PureScript.Parser.Values

4+-- Copyright : (c) Phil Freeman 2013

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+--

13+-----------------------------------------------------------------------------

14+

15+module PureScript.Parser.Values (

16+ parseValue,

17+ parseBinder

18+) where

19+

20+import PureScript.Values

21+import PureScript.Names

22+import PureScript.Declarations

23+import PureScript.Parser.State

24+import Data.Function (on)

25+import Data.List

26+import Data.Functor.Identity

27+import qualified Data.Map as M

28+import qualified PureScript.Parser.Common as C

29+import Control.Applicative

30+import qualified Text.Parsec as P

31+import Text.Parsec.Expr

32+import Control.Monad

33+import Control.Arrow (Arrow(..))

34+import PureScript.Parser.Types

35+import PureScript.Types

36+

37+booleanLiteral :: P.Parsec String ParseState Bool

38+booleanLiteral = (C.reserved "true" >> return True) P.<|> (C.reserved "false" >> return False)

39+

40+parseNumericLiteral :: P.Parsec String ParseState Value

41+parseNumericLiteral = NumericLiteral <$> C.integerOrFloat

42+

43+parseStringLiteral :: P.Parsec String ParseState Value

44+parseStringLiteral = StringLiteral <$> C.stringLiteral

45+

46+parseBooleanLiteral :: P.Parsec String ParseState Value

47+parseBooleanLiteral = BooleanLiteral <$> booleanLiteral

48+

49+parseArrayLiteral :: P.Parsec String ParseState Value

50+parseArrayLiteral = ArrayLiteral <$> (C.squares $ parseValue `P.sepBy` (C.indented *> C.comma))

51+

52+parseObjectLiteral :: P.Parsec String ParseState Value

53+parseObjectLiteral = ObjectLiteral <$> (C.braces $ parseIdentifierAndValue `P.sepBy` (C.indented *> C.comma))

54+

55+parseIdentifierAndValue :: P.Parsec String ParseState (String, Value)

56+parseIdentifierAndValue = (,) <$> (C.indented *> C.identifier <* C.indented <* C.colon)

57+ <*> (C.indented *> parseValue)

58+

59+parseAbs :: P.Parsec String ParseState Value

60+parseAbs = do

61+ C.lexeme $ P.char '\\'

62+ args <- (C.indented *> C.parseIdent) `P.sepBy` (C.indented *> C.comma)

63+ C.lexeme $ C.indented *> P.string "->"

64+ value <- parseValue

65+ return $ Abs args value

66+

67+parseApp :: P.Parsec String ParseState Value

68+parseApp = App <$> parseValue

69+ <*> (C.indented *> C.parens (parseValue `P.sepBy` (C.indented *> C.comma)))

70+

71+parseVar :: P.Parsec String ParseState Value

72+parseVar = Var <$> C.parseIdent

73+

74+parseConstructor :: P.Parsec String ParseState Value

75+parseConstructor = Constructor <$> C.properName

76+

77+parseCase :: P.Parsec String ParseState Value

78+parseCase = Case <$> (P.between (C.reserved "case") (C.indented *> C.reserved "of") parseValue)

79+ <*> (C.indented *> C.mark (P.many (C.same *> C.mark parseCaseAlternative)))

80+

81+parseCaseAlternative :: P.Parsec String ParseState (Binder, Value)

82+parseCaseAlternative = (,) <$> (parseGuardedBinder <* C.lexeme (P.string "->"))

83+ <*> parseValue

84+ P.<?> "case alternative"

85+

86+parseIfThenElse :: P.Parsec String ParseState Value

87+parseIfThenElse = IfThenElse <$> (C.reserved "if" *> C.indented *> parseValue)

88+ <*> (C.indented *> C.reserved "then" *> C.indented *> parseValue)

89+ <*> (C.indented *> C.reserved "else" *> C.indented *> parseValue)

90+

91+parseBlock :: P.Parsec String ParseState Value

92+parseBlock = Block <$> (C.reserved "do" *> parseManyStatements)

93+

94+parseManyStatements :: P.Parsec String ParseState [Statement]

95+parseManyStatements = C.indented *> (C.mark $ P.many $ C.same *> C.mark parseStatement) P.<?> "block"

96+

97+parseValueAtom :: P.Parsec String ParseState Value

98+parseValueAtom = C.indented *> P.choice (map P.try

99+ [ parseNumericLiteral

100+ , parseStringLiteral

101+ , parseBooleanLiteral

102+ , parseArrayLiteral

103+ , parseObjectLiteral

104+ , parseAbs

105+ , parseVar

106+ , parseConstructor

107+ , parseBlock

108+ , parseCase

109+ , parseIfThenElse

110+ , C.parens parseValue ])

111+

112+parseValue :: P.Parsec String ParseState Value

113+parseValue = do

114+ customOps <- fixities <$> P.getState

115+ (buildExpressionParser (operators customOps)

116+ . C.buildPostfixParser postfixTable2

117+ $ indexersAndAccessors) P.<?> "expression"

118+ where

119+ indexersAndAccessors = C.buildPostfixParser postfixTable1 $ parseValueAtom

120+ postfixTable1 = [ Accessor <$> (C.indented *> C.dot *> C.indented *> C.identifier)

121+ , Indexer <$> (C.indented *> C.squares parseValue) ]

122+ postfixTable2 = [ C.indented *> indexersAndAccessors >>= \t2 -> return (\t1 -> App t1 [t2])

123+ , flip App <$> (C.indented *> C.parens (parseValue `P.sepBy` (C.indented *> C.comma)))

124+ , flip TypedValue <$> (P.try $ C.lexeme (C.indented *> P.string "::") *> parsePolyType) ]

125+ operators user =

126+ [ [ Prefix $ C.lexeme (P.try $ C.indented *> C.reservedOp "!") >> return (Unary Not)

127+ , Prefix $ C.lexeme (P.try $ C.indented *> C.reservedOp "~") >> return (Unary BitwiseNot)

128+ , Prefix $ C.lexeme (P.try $ C.indented *> C.reservedOp "-") >> return (Unary Negate)

129+ , Prefix $ C.lexeme (P.try $ C.indented *> C.reservedOp "+") >> return id ]

130+ ] ++ customOperatorTable user ++

131+ [ [ Infix (C.lexeme (P.try (C.indented *> C.parseIdentInfix P.<?> "operator") >>= \ident -> return $ \t1 t2 -> App (App (Var ident) [t1]) [t2])) AssocRight ]

132+ , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "<=") >> return (Binary LessThanOrEqualTo)) AssocRight

133+ , Infix (C.lexeme (P.try $ C.indented *> C.reservedOp ">=") >> return (Binary GreaterThanOrEqualTo)) AssocRight ]

134+ , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "<") >> return (Binary LessThan)) AssocRight

135+ , Infix (C.lexeme (P.try $ C.indented *> C.reservedOp ">") >> return (Binary GreaterThan)) AssocRight ]

136+ , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "*") >> return (Binary Multiply)) AssocRight

137+ , Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "/") >> return (Binary Divide)) AssocRight

138+ , Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "%") >> return (Binary Modulus)) AssocRight ]

139+ , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "++") >> return (Binary Concat)) AssocRight

140+ , Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "+") >> return (Binary Add)) AssocRight

141+ , Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "-") >> return (Binary Subtract)) AssocRight ]

142+ , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "<<") >> return (Binary ShiftLeft)) AssocRight

143+ , Infix (C.lexeme (P.try $ C.indented *> C.reservedOp ">>>") >> return (Binary ZeroFillShiftRight)) AssocRight

144+ , Infix (C.lexeme (P.try $ C.indented *> C.reservedOp ">>") >> return (Binary ShiftRight)) AssocRight ]

145+ , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "==") >> return (Binary EqualTo)) AssocRight

146+ , Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "!=") >> return (Binary NotEqualTo)) AssocRight ]

147+ , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "&") >> return (Binary BitwiseAnd)) AssocRight ]

148+ , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "^") >> return (Binary BitwiseXor)) AssocRight ]

149+ , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "|") >> return (Binary BitwiseOr)) AssocRight ]

150+ , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "&&") >> return (Binary And)) AssocRight ]

151+ , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "||") >> return (Binary Or)) AssocRight ]

152+ ]

153+

154+customOperatorTable :: M.Map String Fixity -> OperatorTable String ParseState Identity Value

155+customOperatorTable fixities =

156+ let

157+ ops = map (\(name, Fixity a p) -> (name, (a, p))) . M.toList $ fixities

158+ sorted = sortBy (compare `on` (snd . snd)) ops

159+ levels = groupBy ((==) `on` (snd . snd)) sorted

160+ in

161+ flip map levels (map (\(name, (a, _)) -> flip Infix (toAssoc a) $ do

162+ C.lexeme $ P.try $ do

163+ C.indented

164+ C.reservedOp name P.<?> "operator"

165+ return $ \t1 t2 -> App (App (Var (Op name)) [t1]) [t2]))

166+

167+toAssoc :: Associativity -> Assoc

168+toAssoc Infixl = AssocLeft

169+toAssoc Infixr = AssocRight

170+

171+parseVariableIntroduction :: P.Parsec String ParseState Statement

172+parseVariableIntroduction = do

173+ C.reserved "var"

174+ name <- C.indented *> C.parseIdent

175+ C.lexeme $ C.indented *> P.char '='

176+ value <- parseValue

177+ return $ VariableIntroduction name value

178+

179+parseAssignment :: P.Parsec String ParseState Statement

180+parseAssignment = do

181+ tgt <- parseAssignmentTarget

182+ C.lexeme $ C.indented *> P.char '='

183+ value <- parseValue

184+ return $ Assignment tgt value

185+

186+parseWhile :: P.Parsec String ParseState Statement

187+parseWhile = While <$> (C.reserved "while" *> C.indented *> parseValue <* C.indented <* C.colon)

188+ <*> parseManyStatements

189+

190+parseFor :: P.Parsec String ParseState Statement

191+parseFor = For <$> (C.reserved "for" *> C.indented *> C.parseIdent)

192+ <*> (C.indented *> C.lexeme (P.string "<-") *> parseValue)

193+ <*> (C.indented *> C.reserved "until" *> parseValue <* C.colon)

194+ <*> parseManyStatements

195+

196+parseForEach :: P.Parsec String ParseState Statement

197+parseForEach = ForEach <$> (C.reserved "foreach" *> C.indented *> C.parseIdent)

198+ <*> (C.indented *> C.reserved "in" *> parseValue <* C.colon)

199+ <*> parseManyStatements

200+

201+parseIf :: P.Parsec String ParseState Statement

202+parseIf = If <$> parseIfStatement

203+

204+parseIfStatement :: P.Parsec String ParseState IfStatement

205+parseIfStatement =

206+ IfStatement <$> (C.reserved "if" *> C.indented *> parseValue <* C.indented <* C.colon)

207+ <*> parseManyStatements

208+ <*> P.optionMaybe (C.same *> parseElseStatement)

209+

210+parseElseStatement :: P.Parsec String ParseState ElseStatement

211+parseElseStatement = C.reserved "else" >> (ElseIf <$> (C.indented *> parseIfStatement)

212+ <|> Else <$> (C.indented *> C.colon *> parseManyStatements))

213+

214+parseReturn :: P.Parsec String ParseState Statement

215+parseReturn = Return <$> (C.reserved "return" *> parseValue)

216+

217+parseStatement :: P.Parsec String ParseState Statement

218+parseStatement = P.choice (map P.try

219+ [ parseVariableIntroduction

220+ , parseAssignment

221+ , parseWhile

222+ , parseFor

223+ , parseForEach

224+ , parseIf

225+ , parseReturn ]) P.<?> "statement"

226+

227+parseStringBinder :: P.Parsec String ParseState Binder

228+parseStringBinder = StringBinder <$> C.stringLiteral

229+

230+parseBooleanBinder :: P.Parsec String ParseState Binder

231+parseBooleanBinder = BooleanBinder <$> booleanLiteral

232+

233+parseNumberBinder :: P.Parsec String ParseState Binder

234+parseNumberBinder = NumberBinder <$> C.integerOrFloat

235+

236+parseVarBinder :: P.Parsec String ParseState Binder

237+parseVarBinder = VarBinder <$> C.parseIdent

238+

239+parseNullaryBinder :: P.Parsec String ParseState Binder

240+parseNullaryBinder = NullaryBinder <$> C.lexeme C.properName

241+

242+parseUnaryBinder :: P.Parsec String ParseState Binder

243+parseUnaryBinder = UnaryBinder <$> C.lexeme C.properName <*> (C.indented *> parseBinder)

244+

245+parseObjectBinder :: P.Parsec String ParseState Binder

246+parseObjectBinder = ObjectBinder <$> C.braces ((C.indented *> parseIdentifierAndBinder) `P.sepBy` (C.indented *> C.comma))

247+

248+parseArrayBinder :: P.Parsec String ParseState Binder

249+parseArrayBinder = C.squares $ ArrayBinder <$> ((C.indented *> parseBinder) `P.sepBy` (C.indented *> C.comma))

250+ <*> P.optionMaybe (C.indented *> C.colon *> C.indented *> parseBinder)

251+

252+parseNamedBinder :: P.Parsec String ParseState Binder

253+parseNamedBinder = NamedBinder <$> (C.parseIdent <* C.indented <* C.lexeme (P.char '@'))

254+ <*> (C.indented *> parseBinder)

255+

256+parseNullBinder :: P.Parsec String ParseState Binder

257+parseNullBinder = C.lexeme (P.char '_') *> P.notFollowedBy C.identLetter *> return NullBinder

258+

259+parseIdentifierAndBinder :: P.Parsec String ParseState (String, Binder)

260+parseIdentifierAndBinder = do

261+ name <- C.lexeme C.identifier

262+ C.lexeme $ C.indented *> P.char '='

263+ binder <- C.indented *> parseBinder

264+ return (name, binder)

265+

266+parseBinder :: P.Parsec String ParseState Binder

267+parseBinder = P.choice (map P.try

268+ [ parseNullBinder

269+ , parseStringBinder

270+ , parseBooleanBinder

271+ , parseNumberBinder

272+ , parseNamedBinder

273+ , parseVarBinder

274+ , parseUnaryBinder

275+ , parseNullaryBinder

276+ , parseObjectBinder

277+ , parseArrayBinder

278+ , C.parens parseBinder ]) P.<?> "binder"

279+

280+parseGuardedBinder :: P.Parsec String ParseState Binder

281+parseGuardedBinder = flip ($) <$> parseBinder <*> P.option id (GuardedBinder <$> (C.indented *> C.lexeme (P.char '|') *> C.indented *> parseValue))

282+

283+parseAssignmentTarget :: P.Parsec String ParseState AssignmentTarget

284+parseAssignmentTarget = buildExpressionParser operators (AssignVariable <$> C.parseIdent)

285+ where

286+ operators = [ [ Postfix $ AssignArrayIndex <$> (C.indented *> C.squares parseValue)

287+ , Postfix $ AssignObjectProperty <$> (C.indented *> C.dot *> C.indented *> C.identifier) ] ]

src/PureScript/TypeChecker.hsnew file+99

@@ -0,0 +1,99 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : PureScript.TypeChecker

4+-- Copyright : (c) Phil Freeman 2013

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+--

13+-----------------------------------------------------------------------------

14+

15+{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances #-}

16+

17+module PureScript.TypeChecker (

18+ module PureScript.TypeChecker.Monad,

19+ module PureScript.TypeChecker.Kinds,

20+ module PureScript.TypeChecker.Types,

21+ typeCheckAll,

22+) where

23+

24+import PureScript.TypeChecker.Monad

25+import PureScript.TypeChecker.Kinds

26+import PureScript.TypeChecker.Types

27+import PureScript.TypeChecker.Synonyms

28+

29+import Data.List

30+import Data.Maybe

31+import Data.Function

32+import qualified Data.Map as M

33+

34+import PureScript.Values

35+import PureScript.Types

36+import PureScript.Names

37+import PureScript.Kinds

38+import PureScript.Declarations

39+

40+import Control.Monad.State

41+import Control.Monad.Error

42+

43+import qualified Data.Map as M

44+

45+typeCheckAll :: [Declaration] -> Check ()

46+typeCheckAll [] = return ()

47+typeCheckAll (DataDeclaration name args dctors : rest) = do

48+ rethrow (("Error in type constructor " ++ name ++ ": ") ++) $ do

49+ env <- getEnv

50+ guardWith (name ++ " is already defined") $ not $ M.member name (types env)

51+ ctorKind <- kindsOf (Just name) args (catMaybes $ map snd dctors)

52+ putEnv $ env { types = M.insert name (ctorKind, Data) (types env) }

53+ flip mapM_ dctors $ \(dctor, maybeTy) ->

54+ rethrow (("Error in data constructor " ++ name ++ ": ") ++) $ do

55+ env' <- getEnv

56+ guardWith (dctor ++ " is already defined") $ not $ flip M.member (dataConstructors env') dctor

57+ let retTy = foldl TypeApp (TypeConstructor name) (map TypeVar args)

58+ let dctorTy = maybe retTy (\ty -> Function [ty] retTy) maybeTy

59+ let polyType = PolyType args dctorTy

60+ putEnv $ env' { dataConstructors = M.insert dctor polyType (dataConstructors env') }

61+ typeCheckAll rest

62+typeCheckAll (TypeSynonymDeclaration name args ty : rest) = do

63+ rethrow (("Error in type synonym " ++ name ++ ": ") ++) $ do

64+ env <- getEnv

65+ guardWith (name ++ " is already defined") $ not $ M.member name (types env)

66+ kind <- kindsOf (Just name) args [ty]

67+ putEnv $ env { types = M.insert name (kind, TypeSynonym) (types env)

68+ , typeSynonyms = M.insert name (args, ty) (typeSynonyms env) }

69+ typeCheckAll rest

70+typeCheckAll (TypeDeclaration name ty : ValueDeclaration name' val : rest) | name == name' =

71+ typeCheckAll (ValueDeclaration name (TypedValue val ty) : rest)

72+typeCheckAll (TypeDeclaration name _ : _) = throwError $ "Orphan type declaration for " ++ show name

73+typeCheckAll (ValueDeclaration name val : rest) = do

74+ rethrow (("Error in declaration " ++ show name ++ ": ") ++) $ do

75+ env <- getEnv

76+ case M.lookup name (names env) of

77+ Just ty -> throwError $ show name ++ " is already defined"

78+ Nothing -> do

79+ ty <- typeOf name val

80+ putEnv (env { names = M.insert name (ty, Value) (names env) })

81+ typeCheckAll rest

82+typeCheckAll (ExternDataDeclaration name kind : rest) = do

83+ env <- getEnv

84+ guardWith (name ++ " is already defined") $ not $ M.member name (types env)

85+ putEnv $ env { types = M.insert name (kind, TypeSynonym) (types env) }

86+ typeCheckAll rest

87+typeCheckAll (ExternDeclaration name ty : rest) = do

88+ rethrow (("Error in extern declaration " ++ show name ++ ": ") ++) $ do

89+ env <- getEnv

90+ kind <- kindOf ty

91+ guardWith "Expected kind *" $ kind == Star

92+ case M.lookup name (names env) of

93+ Just _ -> throwError $ show name ++ " is already defined"

94+ Nothing -> putEnv (env { names = M.insert name (ty, Extern) (names env) })

95+ typeCheckAll rest

96+typeCheckAll (FixityDeclaration _ name : rest) = do

97+ typeCheckAll rest

98+ env <- getEnv

99+ guardWith ("Fixity declaration with no binding: " ++ name) $ M.member (Op name) $ names env

src/PureScript/TypeChecker/Kinds.hsnew file+169

@@ -0,0 +1,169 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : PureScript.TypeChecker.Kinds

4+-- Copyright : (c) Phil Freeman 2013

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+--

13+-----------------------------------------------------------------------------

14+

15+module PureScript.TypeChecker.Kinds (

16+ KindConstraint(..),

17+ KindSolution(..),

18+ kindsOf,

19+ kindOf

20+) where

21+

22+import Data.List

23+import Data.Maybe (fromMaybe)

24+import Data.Function

25+

26+import PureScript.Types

27+import PureScript.Kinds

28+import PureScript.Declarations

29+import PureScript.TypeChecker.Monad

30+import PureScript.CodeGen.Pretty.Kinds

31+

32+import Control.Monad.State

33+import Control.Monad.Error

34+

35+import Control.Applicative

36+import Control.Arrow (Kleisli(..), (***))

37+import qualified Control.Category as C

38+

39+import qualified Data.Map as M

40+

41+data KindConstraint = KindConstraint Int Kind

42+

43+instance Show KindConstraint where

44+ show (KindConstraint n k) = show n ++ " = " ++ show k

45+

46+newtype KindSolution = KindSolution { runKindSolution :: Int -> Kind }

47+

48+emptyKindSolution :: KindSolution

49+emptyKindSolution = KindSolution KUnknown

50+

51+kindOf :: PolyType -> Check Kind

52+kindOf (PolyType idents ty) = do

53+ ns <- replicateM (length idents) fresh

54+ (cs, n, m) <- kindConstraints (M.fromList (zip idents ns)) ty

55+ solution <- solveKindConstraints cs emptyKindSolution

56+ return $ starIfUnknown $ runKindSolution solution n

57+

58+kindsOf :: Maybe String -> [String] -> [Type] -> Check Kind

59+kindsOf name args ts = do

60+ tyCon <- fresh

61+ nargs <- replicateM (length args) fresh

62+ (cs, ns, m) <- kindConstraintsAll (maybe id (flip M.insert tyCon) name $ M.fromList (zipWith (,) args nargs)) ts

63+ let extraConstraints = KindConstraint tyCon (foldr FunKind Star (map KUnknown nargs)) : map (flip KindConstraint Star) ns

64+ solution <- solveKindConstraints (extraConstraints ++ cs) emptyKindSolution

65+ return $ starIfUnknown $ runKindSolution solution tyCon

66+

67+starIfUnknown :: Kind -> Kind

68+starIfUnknown (KUnknown _) = Star

69+starIfUnknown (FunKind k1 k2) = FunKind (starIfUnknown k1) (starIfUnknown k2)

70+starIfUnknown k = k

71+

72+kindConstraintsAll :: M.Map String Int -> [Type] -> Check ([KindConstraint], [Int], M.Map String Int)

73+kindConstraintsAll m [] = return ([], [], m)

74+kindConstraintsAll m (t:ts) = do

75+ (cs, n1, m') <- kindConstraints m t

76+ (cs', ns, m'') <- kindConstraintsAll m' ts

77+ return ((KindConstraint n1 Star) : cs ++ cs', n1:ns, m'')

78+

79+kindConstraints :: M.Map String Int -> Type -> Check ([KindConstraint], Int, M.Map String Int)

80+kindConstraints m (Array t) = do

81+ me <- fresh

82+ (cs, n1, m') <- kindConstraints m t

83+ return ((KindConstraint n1 Star) : (KindConstraint me Star) : cs, me, m')

84+kindConstraints m (Object row) = do

85+ me <- fresh

86+ (cs, row, m') <- kindConstraintsForRow m row

87+ return ((KindConstraint me Star) : (KindConstraint row Row) : cs, me, m')

88+kindConstraints m (Function args ret) = do

89+ me <- fresh

90+ (cs, ns, m') <- kindConstraintsAll m args

91+ (cs', retN, m'') <- kindConstraints m' ret

92+ return ((KindConstraint retN Star) : (KindConstraint me Star) : (map (flip KindConstraint Star) ns) ++ cs ++ cs', me, m'')

93+kindConstraints m (TypeVar v) = do

94+ case M.lookup v m of

95+ Just u -> return ([], u, m)

96+ Nothing -> throwError $ "Unbound type variable " ++ v

97+kindConstraints m (TypeConstructor v) = do

98+ env <- getEnv

99+ me <- fresh

100+ case M.lookup v m of

101+ Nothing -> case M.lookup v (types env) of

102+ Nothing -> throwError $ "Unknown type constructor '" ++ v ++ "'"

103+ Just (kind, _) -> return ([KindConstraint me kind], me, m)

104+ Just u -> do

105+ return ([KindConstraint me (KUnknown u)], me, m)

106+kindConstraints m (TypeApp t1 t2) = do

107+ me <- fresh

108+ (cs1, n1, m1) <- kindConstraints m t1

109+ (cs2, n2, m2) <- kindConstraints m1 t2

110+ return ((KindConstraint n1 (FunKind (KUnknown n2) (KUnknown me))) : cs1 ++ cs2, me, m2)

111+kindConstraints m _ = do

112+ me <- fresh

113+ return ([KindConstraint me Star], me, m)

114+

115+kindConstraintsForRow :: M.Map String Int -> Row -> Check ([KindConstraint], Int, M.Map String Int)

116+kindConstraintsForRow m (RowVar v) = do

117+ me <- case M.lookup v m of

118+ Just u -> return u

119+ Nothing -> fresh

120+ return ([KindConstraint me Row], me, M.insert v me m)

121+kindConstraintsForRow m REmpty = do

122+ me <- fresh

123+ return ([KindConstraint me Row], me, m)

124+kindConstraintsForRow m (RCons _ ty row) = do

125+ me <- fresh

126+ (cs1, n1, m1) <- kindConstraints m ty

127+ (cs2, n2, m2) <- kindConstraintsForRow m1 row

128+ return ((KindConstraint me Row) : (KindConstraint n1 Star) : (KindConstraint n2 Row) : cs1 ++ cs2, me, m2)

129+

130+solveKindConstraints :: [KindConstraint] -> KindSolution -> Check KindSolution

131+solveKindConstraints [] s = return s

132+solveKindConstraints all@(KindConstraint n k:cs) s = do

133+ guardWith "Occurs check failed" $ not $ kindOccursCheck False n k

134+ let s' = KindSolution $ replaceUnknownKind n k . runKindSolution s

135+ cs' <- fmap concat $ mapM (substituteKindConstraint n k) cs

136+ solveKindConstraints cs' s'

137+

138+substituteKindConstraint :: Int -> Kind -> KindConstraint -> Check [KindConstraint]

139+substituteKindConstraint n k (KindConstraint m l)

140+ | n == m = unifyKinds k l

141+ | otherwise = return [KindConstraint m (replaceUnknownKind n k l)]

142+

143+replaceUnknownKind :: Int -> Kind -> Kind -> Kind

144+replaceUnknownKind n k = f

145+ where

146+ f (KUnknown m) | m == n = k

147+ f (FunKind k1 k2) = FunKind (f k2) (f k2)

148+ f other = other

149+

150+unifyKinds :: Kind -> Kind -> Check [KindConstraint]

151+unifyKinds (KUnknown u1) (KUnknown u2) | u1 == u2 = return []

152+unifyKinds (KUnknown u) k = do

153+ guardWith "Occurs check failed" $ not $ kindOccursCheck False u k

154+ return [KindConstraint u k]

155+unifyKinds k (KUnknown u) = do

156+ guardWith "Occurs check failed" $ not $ kindOccursCheck False u k

157+ return [KindConstraint u k]

158+unifyKinds Star Star = return []

159+unifyKinds Row Row = return []

160+unifyKinds (FunKind k1 k2) (FunKind k3 k4) = do

161+ cs1 <- unifyKinds k1 k3

162+ cs2 <- unifyKinds k2 k4

163+ return $ cs1 ++ cs2

164+unifyKinds k1 k2 = throwError $ "Cannot unify " ++ prettyPrintKind k1 ++ " with " ++ prettyPrintKind k2 ++ "."

165+

166+kindOccursCheck :: Bool -> Int -> Kind -> Bool

167+kindOccursCheck b u (KUnknown u') | u == u' = b

168+kindOccursCheck _ u (FunKind k1 k2) = kindOccursCheck True u k1 || kindOccursCheck True u k2

169+kindOccursCheck _ _ _ = False

src/PureScript/TypeChecker/Monad.hsnew file+67

@@ -0,0 +1,67 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : PureScript.TypeChecker.Monad

4+-- Copyright : (c) Phil Freeman 2013

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+--

13+-----------------------------------------------------------------------------

14+

15+{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances #-}

16+

17+module PureScript.TypeChecker.Monad where

18+

19+import PureScript.Types

20+import PureScript.Kinds

21+import PureScript.Names

22+

23+import Control.Applicative

24+import Control.Monad.State

25+import Control.Monad.Error

26+

27+import Control.Arrow ((***))

28+

29+import qualified Data.Map as M

30+

31+data NameKind = Value | Extern deriving Show

32+

33+data TypeDeclarationKind = Data | ExternData | TypeSynonym deriving Show

34+

35+data Environment = Environment

36+ { names :: M.Map Ident (PolyType, NameKind)

37+ , types :: M.Map String (Kind, TypeDeclarationKind)

38+ , dataConstructors :: M.Map String PolyType

39+ , typeSynonyms :: M.Map String ([String], Type)

40+ }

41+

42+emptyEnvironment :: Environment

43+emptyEnvironment = Environment M.empty M.empty M.empty M.empty

44+

45+newtype Check a = Check { unCheck :: StateT (Environment, Int) (Either String) a } deriving (Functor, Monad, Applicative, MonadPlus, MonadState (Environment, Int), MonadError String)

46+

47+getEnv :: Check Environment

48+getEnv = fmap fst get

49+

50+putEnv :: Environment -> Check ()

51+putEnv env = fmap (const env *** id) get >>= put

52+

53+fresh :: Check Int

54+fresh = do

55+ (env, n) <- get

56+ put (env, n + 1)

57+ return n

58+

59+check :: Check a -> Either String (a, Environment)

60+check = fmap (id *** fst) . flip runStateT (emptyEnvironment, 0) . unCheck

61+

62+guardWith :: (MonadError e m) => e -> Bool -> m ()

63+guardWith _ True = return ()

64+guardWith e False = throwError e

65+

66+rethrow :: (MonadError e m) => (e -> e) -> m a -> m a

67+rethrow f = flip catchError $ \e -> throwError (f e)

src/PureScript/TypeChecker/Synonyms.hsnew file+56

@@ -0,0 +1,56 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : PureScript.TypeChecker.Synonyms

4+-- Copyright : (c) Phil Freeman 2013

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+--

13+-----------------------------------------------------------------------------

14+

15+{-# LANGUAGE Rank2Types #-}

16+

17+module PureScript.TypeChecker.Synonyms (

18+ saturateTypeSynonym,

19+ saturateAllTypeSynonyms

20+) where

21+

22+import PureScript.Types

23+import PureScript.Declarations

24+

25+import Data.Maybe (fromMaybe)

26+import Data.Data

27+import Data.Generics

28+import Control.Arrow

29+import Control.Monad.Writer

30+import Control.Monad.Error

31+import qualified Data.Map as M

32+

33+buildTypeSubstitution :: String -> Int -> Type -> Either String (Maybe Type)

34+buildTypeSubstitution name n = go n []

35+ where

36+ go :: Int -> [Type] -> Type -> Either String (Maybe Type)

37+ go 0 args (TypeConstructor ctor) | name == ctor = return (Just $ SaturatedTypeSynonym ctor args)

38+ go n _ (TypeConstructor ctor) | n > 0 && name == ctor = throwError $ "Partially applied type synonym " ++ name

39+ go n args (TypeApp f arg) = go (n - 1) (arg:args) f

40+ go _ _ _ = return Nothing

41+

42+everywhereM' :: (Monad m, Data d) => (forall d. (Data d) => d -> m d) -> d -> m d

43+everywhereM' f x = do

44+ y <- f x

45+ gmapM (everywhereM' f) y

46+

47+saturateTypeSynonym :: (Data d) => String -> Int -> d -> Either String d

48+saturateTypeSynonym name n = everywhereM' (mkM replace)

49+ where

50+ replace t = fmap (fromMaybe t) $ buildTypeSubstitution name n t

51+

52+saturateAllTypeSynonyms :: (Data d) => [(String, Int)] -> d -> Either String d

53+saturateAllTypeSynonyms syns d = foldM (\d (name, n) -> saturateTypeSynonym name n d) d syns

54+

55+

56+

src/PureScript/TypeChecker/Types.hsnew file+596

@@ -0,0 +1,596 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : PureScript.TypeChecker.Types

4+-- Copyright : (c) Phil Freeman 2013

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+--

13+-----------------------------------------------------------------------------

14+

15+{-# LANGUAGE DeriveDataTypeable #-}

16+

17+module PureScript.TypeChecker.Types (

18+ TypeConstraint(..),

19+ TypeSolution(..),

20+ typeOf

21+) where

22+

23+import Data.List

24+import Data.Function

25+import qualified Data.Data as D

26+import Data.Generics (everywhere, everywhereM, everything, mkT, mkM, mkQ, extM, extQ)

27+

28+import PureScript.Values

29+import PureScript.Types

30+import PureScript.Kinds

31+import PureScript.Names

32+import PureScript.TypeChecker.Monad

33+import PureScript.TypeChecker.Kinds

34+import PureScript.TypeChecker.Synonyms

35+import PureScript.CodeGen.Pretty.Types

36+import PureScript.CodeGen.Pretty.Kinds

37+

38+import Control.Monad.State

39+import Control.Monad.Error

40+

41+import Control.Applicative

42+import Control.Arrow (Kleisli(..), (***), (&&&))

43+import qualified Control.Category as C

44+

45+import qualified Data.Map as M

46+

47+data TypeConstraint

48+ = TypeConstraint Int Type

49+ | RowConstraint Int Row deriving (Show, D.Data, D.Typeable)

50+

51+newtype TypeSolution = TypeSolution { runTypeSolution :: (Int -> Type, Int -> Row) }

52+

53+emptyTypeSolution :: TypeSolution

54+emptyTypeSolution = TypeSolution (TUnknown, RUnknown)

55+

56+typeOf :: Ident -> Value -> Check PolyType

57+typeOf name val = do

58+ (cs, n) <- case val of

59+ Abs _ _ -> do

60+ me <- fresh

61+ (cs, n) <- typeConstraints (M.singleton name me) val

62+ return (TypeConstraint me (TUnknown n) : cs, n)

63+ _ -> typeConstraints M.empty val

64+ desugared <- replaceAllTypeSynonyms cs

65+ solution <- solveTypeConstraints desugared emptyTypeSolution

66+ let ty = fst (runTypeSolution solution) n

67+ allUnknownsBecameQuantified desugared solution ty

68+ return $ varIfUnknown $ desaturateAllTypeSynonyms ty

69+

70+allUnknownsBecameQuantified :: [TypeConstraint] -> TypeSolution -> Type -> Check ()

71+allUnknownsBecameQuantified cs solution ty = do

72+ let

73+ typesMentioned = findUnknownTypes ty

74+ unknownTypes = nub $ flip concatMap cs $ \c -> case c of

75+ TypeConstraint u t -> u : findUnknownTypes t

76+ RowConstraint _ r -> findUnknownTypes r

77+ unsolvedTypes = filter (\n -> TUnknown n == fst (runTypeSolution solution) n) unknownTypes

78+ guardWith "Unsolved type variable" $ null $ unsolvedTypes \\ typesMentioned

79+ let

80+ rowsMentioned = findUnknownRows ty

81+ unknownRows = nub $ flip concatMap cs $ \c -> case c of

82+ TypeConstraint _ t -> findUnknownRows t

83+ RowConstraint u r -> u : findUnknownRows r

84+ unsolvedRows = filter (\n -> RUnknown n == snd (runTypeSolution solution) n) unknownRows

85+ guardWith "Unsolved row variable" $ null $ unsolvedRows \\ rowsMentioned

86+

87+findUnknownTypes :: (D.Data d) => d -> [Int]

88+findUnknownTypes = everything (++) (mkQ [] f)

89+ where

90+ f :: Type -> [Int]

91+ f (TUnknown n) = [n]

92+ f _ = []

93+

94+findTypeVars :: (D.Data d) => d -> [String]

95+findTypeVars = everything (++) (mkQ [] f)

96+ where

97+ f :: Type -> [String]

98+ f (TypeVar v) = [v]

99+ f _ = []

100+

101+findUnknownRows :: (D.Data d) => d -> [Int]

102+findUnknownRows = everything (++) (mkQ [] f)

103+ where

104+ f :: Row -> [Int]

105+ f (RUnknown n) = [n]

106+ f _ = []

107+

108+varIfUnknown :: Type -> PolyType

109+varIfUnknown ty =

110+ let

111+ (ty', m) = flip runState M.empty $ everywhereM (flip extM g $ mkM f) ty

112+ in

113+ PolyType (sort $ nub $ M.elems m ++ findTypeVars ty) ty'

114+ where

115+ f :: Type -> State (M.Map Int String) Type

116+ f (TUnknown n) = do

117+ m <- get

118+ case M.lookup n m of

119+ Nothing -> do

120+ let name = "t" ++ show (M.size m)

121+ put $ M.insert n name m

122+ return $ TypeVar name

123+ Just name -> return $ TypeVar name

124+ f t = return t

125+ g :: Row -> State (M.Map Int String) Row

126+ g (RUnknown n) = do

127+ m <- get

128+ case M.lookup n m of

129+ Nothing -> do

130+ let name = "r" ++ show (M.size m)

131+ put $ M.insert n name m

132+ return $ RowVar name

133+ Just name -> return $ RowVar name

134+ g r = return r

135+

136+replaceTypeVars :: M.Map String Type -> Type -> Type

137+replaceTypeVars m = everywhere (mkT replace)

138+ where

139+ replace (TypeVar v) = case M.lookup v m of

140+ Just ty -> ty

141+ _ -> TypeVar v

142+ replace t = t

143+

144+replaceVarsWithUnknowns :: [String] -> Type -> Check Type

145+replaceVarsWithUnknowns idents = flip evalStateT M.empty . everywhereM (flip extM f $ mkM g)

146+ where

147+ f :: Type -> StateT (M.Map String Int) Check Type

148+ f (TypeVar var) | var `elem` idents = do

149+ m <- get

150+ n <- lift fresh

151+ case M.lookup var m of

152+ Nothing -> do

153+ put (M.insert var n m)

154+ return $ TUnknown n

155+ Just u -> return $ TUnknown u

156+ f t = return t

157+ g :: Row -> StateT (M.Map String Int) Check Row

158+ g (RowVar var) | var `elem` idents = do

159+ m <- get

160+ n <- lift fresh

161+ case M.lookup var m of

162+ Nothing -> do

163+ put (M.insert var n m)

164+ return $ RUnknown n

165+ Just u -> return $ RUnknown u

166+ g r = return r

167+

168+replaceAllTypeSynonyms :: (D.Data d) => d -> Check d

169+replaceAllTypeSynonyms d = do

170+ env <- getEnv

171+ let syns = map (\(name, (args, _)) -> (name, length args)) . M.toList $ typeSynonyms env

172+ either throwError return $ saturateAllTypeSynonyms syns d

173+

174+desaturateAllTypeSynonyms :: (D.Data d) => d -> d

175+desaturateAllTypeSynonyms = everywhere (mkT $ replace)

176+ where

177+ replace (SaturatedTypeSynonym name args) = foldl (\t arg -> TypeApp t arg) (TypeConstructor name) args

178+ replace t = t

179+

180+replaceType :: (D.Data d) => Int -> Type -> d -> d

181+replaceType n t = everywhere (mkT go)

182+ where

183+ go (TUnknown m) | m == n = t

184+ go t = t

185+

186+replaceRow :: (D.Data d) => Int -> Row -> d -> d

187+replaceRow n r = everywhere (mkT go)

188+ where

189+ go (RUnknown m) | m == n = r

190+ go r = r

191+

192+typeOccursCheck :: Int -> Type -> Check ()

193+typeOccursCheck u (TUnknown _) = return ()

194+typeOccursCheck u t = when (occursCheck u t) $ throwError $ "Occurs check failed: " ++ show u ++ " = " ++ prettyPrintType t

195+

196+rowOccursCheck :: Int -> Row -> Check ()

197+rowOccursCheck u (RUnknown _) = return ()

198+rowOccursCheck u r = when (occursCheck u r) $ throwError $ "Occurs check failed: " ++ show u ++ " = " ++ prettyPrintRow r

199+

200+occursCheck :: (D.Data d) => Int -> d -> Bool

201+occursCheck u = everything (||) $ flip extQ g $ mkQ False f

202+ where

203+ f (TUnknown u') | u' == u = True

204+ f _ = False

205+ g (RUnknown u') | u' == u = True

206+ g _ = False

207+

208+typeConstraints :: M.Map Ident Int -> Value -> Check ([TypeConstraint], Int)

209+typeConstraints _ (NumericLiteral _) = do

210+ me <- fresh

211+ return ([TypeConstraint me Number], me)

212+typeConstraints _ (StringLiteral _) = do

213+ me <- fresh

214+ return ([TypeConstraint me String], me)

215+typeConstraints _ (BooleanLiteral _) = do

216+ me <- fresh

217+ return ([TypeConstraint me Boolean], me)

218+typeConstraints m (ArrayLiteral vals) = do

219+ all <- mapM (typeConstraints m) vals

220+ let (cs, ns) = (concat . map fst &&& map snd) all

221+ me <- fresh

222+ return (cs ++ map (TypeConstraint me . Array . TUnknown) ns, me)

223+typeConstraints m (Unary op val) = do

224+ (cs, n1) <- typeConstraints m val

225+ me <- fresh

226+ return (cs ++ unaryOperatorConstraints op n1 me, me)

227+typeConstraints m (Binary op left right) = do

228+ (cs1, n1) <- typeConstraints m left

229+ (cs2, n2) <- typeConstraints m right

230+ me <- fresh

231+ return (cs1 ++ cs2 ++ binaryOperatorConstraints op n1 n2 me, me)

232+typeConstraints m (ObjectLiteral ps) = do

233+ all <- mapM (typeConstraints m . snd) ps

234+ let (cs, ns) = (concat . map fst &&& map snd) all

235+ me <- fresh

236+ let tys = zipWith (\(name, _) u -> (name, TUnknown u)) ps ns

237+ return ((TypeConstraint me (Object (typesToRow tys))) : cs, me)

238+ where

239+ typesToRow [] = REmpty

240+ typesToRow ((name, ty):tys) = RCons name ty (typesToRow tys)

241+typeConstraints m (Indexer index val) = do

242+ (cs1, n1) <- typeConstraints m index

243+ (cs2, n2) <- typeConstraints m val

244+ me <- fresh

245+ return ((TypeConstraint n1 Number) : (TypeConstraint n2 (Array (TUnknown me))) : cs1 ++ cs2, me)

246+typeConstraints m (Accessor prop val) = do

247+ (cs, n1) <- typeConstraints m val

248+ me <- fresh

249+ rest <- fresh

250+ return ((TypeConstraint n1 (Object (RCons prop (TUnknown me) (RUnknown rest)))) : cs, me)

251+typeConstraints m (Abs args ret) = do

252+ ns <- replicateM (length args) fresh

253+ let m' = m `M.union` M.fromList (zipWith (,) args ns)

254+ (cs, n') <- typeConstraints m' ret

255+ me <- fresh

256+ return ((TypeConstraint me (Function (map TUnknown ns) (TUnknown n'))) : cs, me)

257+typeConstraints m (App f xs) = do

258+ (cs1, n1) <- typeConstraints m f

259+ all <- mapM (typeConstraints m) xs

260+ let (cs2, ns) = (concat . map fst &&& map snd) all

261+ me <- fresh

262+ return ((TypeConstraint n1 (Function (map TUnknown ns) (TUnknown me))) : cs1 ++ cs2, me)

263+typeConstraints m (Var var) =

264+ case M.lookup var m of

265+ Nothing -> do

266+ env <- getEnv

267+ case M.lookup var (names env) of

268+ Nothing -> throwError $ show var ++ " is undefined"

269+ Just (PolyType idents ty, _) -> do

270+ me <- fresh

271+ replaced <- replaceVarsWithUnknowns idents ty

272+ return ([TypeConstraint me replaced], me)

273+ Just u -> do

274+ me <- fresh

275+ return ([TypeConstraint u (TUnknown me)], me)

276+typeConstraints m (Block ss) = do

277+ ret <- fresh

278+ (cs, allCodePathsReturn, _) <- typeConstraintsForBlock m M.empty ret ss

279+ guardWith "Block is missing a return statement" allCodePathsReturn

280+ return (cs, ret)

281+typeConstraints m (Constructor c) = do

282+ env <- getEnv

283+ case M.lookup c (dataConstructors env) of

284+ Nothing -> throwError $ "Constructor " ++ c ++ " is undefined"

285+ Just (PolyType idents ty) -> do

286+ me <- fresh

287+ replaced <- replaceVarsWithUnknowns idents ty

288+ return ([TypeConstraint me replaced], me)

289+typeConstraints m (Case val binders) = do

290+ (cs1, n1) <- typeConstraints m val

291+ ret <- fresh

292+ cs2 <- typeConstraintsForBinders m n1 ret binders

293+ return (cs1 ++ cs2, ret)

294+typeConstraints m (IfThenElse cond th el) = do

295+ (cs1, n1) <- typeConstraints m cond

296+ (cs2, n2) <- typeConstraints m th

297+ (cs3, n3) <- typeConstraints m el

298+ return (TypeConstraint n1 Boolean : TypeConstraint n2 (TUnknown n3) : cs1 ++ cs2 ++ cs3, n2)

299+typeConstraints m (TypedValue val poly@(PolyType idents ty)) = do

300+ kind <- kindOf poly

301+ guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star

302+ (cs, n1) <- typeConstraints m val

303+ return (TypeConstraint n1 ty : cs, n1)

304+

305+unaryOperatorConstraints :: UnaryOperator -> Int -> Int -> [TypeConstraint]

306+unaryOperatorConstraints Negate val result = [TypeConstraint val Number, TypeConstraint result Number]

307+unaryOperatorConstraints Not val result = [TypeConstraint val Boolean, TypeConstraint result Boolean]

308+unaryOperatorConstraints BitwiseNot val result = [TypeConstraint val Number, TypeConstraint result Number]

309+

310+binaryOperatorConstraints :: BinaryOperator -> Int -> Int -> Int -> [TypeConstraint]

311+binaryOperatorConstraints Add = symBinOpConstraints Number

312+binaryOperatorConstraints Subtract = symBinOpConstraints Number

313+binaryOperatorConstraints Multiply = symBinOpConstraints Number

314+binaryOperatorConstraints Divide = symBinOpConstraints Number

315+binaryOperatorConstraints Modulus = symBinOpConstraints Number

316+binaryOperatorConstraints LessThan = asymBinOpConstraints Number Boolean

317+binaryOperatorConstraints LessThanOrEqualTo = asymBinOpConstraints Number Boolean

318+binaryOperatorConstraints GreaterThan = asymBinOpConstraints Number Boolean

319+binaryOperatorConstraints GreaterThanOrEqualTo = asymBinOpConstraints Number Boolean

320+binaryOperatorConstraints BitwiseAnd = symBinOpConstraints Number

321+binaryOperatorConstraints BitwiseOr = symBinOpConstraints Number

322+binaryOperatorConstraints BitwiseXor = symBinOpConstraints Number

323+binaryOperatorConstraints ShiftLeft = symBinOpConstraints Number

324+binaryOperatorConstraints ShiftRight = symBinOpConstraints Number

325+binaryOperatorConstraints ZeroFillShiftRight = symBinOpConstraints Number

326+binaryOperatorConstraints EqualTo = equalityBinOpConstraints

327+binaryOperatorConstraints NotEqualTo = equalityBinOpConstraints

328+binaryOperatorConstraints And = symBinOpConstraints Boolean

329+binaryOperatorConstraints Or = symBinOpConstraints Boolean

330+binaryOperatorConstraints Concat = symBinOpConstraints String

331+

332+equalityBinOpConstraints :: Int -> Int -> Int -> [TypeConstraint]

333+equalityBinOpConstraints left right result = [TypeConstraint left (TUnknown right), TypeConstraint result Boolean]

334+

335+symBinOpConstraints :: Type -> Int -> Int -> Int -> [TypeConstraint]

336+symBinOpConstraints ty left right result = asymBinOpConstraints ty ty left right result

337+

338+asymBinOpConstraints :: Type -> Type -> Int -> Int -> Int -> [TypeConstraint]

339+asymBinOpConstraints ty res left right result = [TypeConstraint left ty, TypeConstraint right ty, TypeConstraint result res]

340+

341+typeConstraintsForBinder :: Int -> Binder -> Check ([TypeConstraint], M.Map Ident Int)

342+typeConstraintsForBinder _ NullBinder = return ([], M.empty)

343+typeConstraintsForBinder val (StringBinder _) = constantBinder val String

344+typeConstraintsForBinder val (NumberBinder _) = constantBinder val Number

345+typeConstraintsForBinder val (BooleanBinder _) = constantBinder val Boolean

346+typeConstraintsForBinder val (VarBinder name) = do

347+ me <- fresh

348+ return ([TypeConstraint me (TUnknown val)], M.singleton name me)

349+typeConstraintsForBinder val (NullaryBinder ctor) = do

350+ env <- getEnv

351+ case M.lookup ctor (dataConstructors env) of

352+ Just (PolyType args ret) -> do

353+ ret' <- replaceVarsWithUnknowns args ret

354+ return ([TypeConstraint val ret'], M.empty)

355+ _ -> throwError $ "Constructor " ++ ctor ++ " is not defined"

356+typeConstraintsForBinder val (UnaryBinder ctor binder) = do

357+ env <- getEnv

358+ case M.lookup ctor (dataConstructors env) of

359+ Just (PolyType idents f@(Function [_] _)) -> do

360+ obj <- fresh

361+ (Function [ty] ret) <- replaceVarsWithUnknowns idents f

362+ (cs, m1) <- typeConstraintsForBinder obj binder

363+ return ((TypeConstraint val ret) : (TypeConstraint obj ty) : cs, m1)

364+ Just _ -> throwError $ ctor ++ " is not a unary constructor"

365+ _ -> throwError $ "Constructor " ++ ctor ++ " is not defined"

366+typeConstraintsForBinder val (ObjectBinder props) = do

367+ row <- fresh

368+ rest <- fresh

369+ (cs, m1) <- typeConstraintsForProperties row (RUnknown rest) props

370+ return ((TypeConstraint val (Object (RUnknown row))) : cs, m1)

371+ where

372+ typeConstraintsForProperties :: Int -> Row -> [(String, Binder)] -> Check ([TypeConstraint], M.Map Ident Int)

373+ typeConstraintsForProperties nrow row [] = return ([RowConstraint nrow row], M.empty)

374+ typeConstraintsForProperties nrow row ((name, binder):binders) = do

375+ propTy <- fresh

376+ (cs1, m1) <- typeConstraintsForBinder propTy binder

377+ (cs2, m2) <- typeConstraintsForProperties nrow (RCons name (TUnknown propTy) row) binders

378+ return (cs1 ++ cs2, M.union m1 m2)

379+typeConstraintsForBinder val (ArrayBinder binders rest) = do

380+ el <- fresh

381+ all <- mapM (typeConstraintsForBinder el) binders

382+ let (cs1, m1) = (concat . map fst &&& M.unions . map snd) all

383+ let arrayConstraint = TypeConstraint val (Array (TUnknown el))

384+ case rest of

385+ Nothing -> return (arrayConstraint : cs1, m1)

386+ Just binder -> do

387+ (cs2, m2) <- typeConstraintsForBinder val binder

388+ return (arrayConstraint : cs1 ++ cs2, M.union m1 m2)

389+typeConstraintsForBinder val (NamedBinder name binder) = do

390+ me <- fresh

391+ (cs, m) <- typeConstraintsForBinder val binder

392+ return (TypeConstraint me (TUnknown val) : cs, M.insert name me m)

393+typeConstraintsForBinder val (GuardedBinder cond binder) = do

394+ (cs1, m) <- typeConstraintsForBinder val binder

395+ (cs2, n) <- typeConstraints m cond

396+ return (TypeConstraint n Boolean : cs1 ++ cs2, m)

397+

398+constantBinder :: Int -> Type -> Check ([TypeConstraint], M.Map Ident Int)

399+constantBinder val ty = return ([TypeConstraint val ty], M.empty)

400+

401+typeConstraintsForBinders :: M.Map Ident Int -> Int -> Int -> [(Binder, Value)] -> Check [TypeConstraint]

402+typeConstraintsForBinders _ _ _ [] = return []

403+typeConstraintsForBinders m nval ret ((binder, val):bs) = do

404+ (cs1, m1) <- typeConstraintsForBinder nval binder

405+ (cs2, n2) <- typeConstraints (M.union m m1) val

406+ cs3 <- typeConstraintsForBinders m nval ret bs

407+ return ((TypeConstraint n2 (TUnknown ret)) : cs1 ++ cs2 ++ cs3)

408+

409+assignVariable :: Ident -> M.Map Ident Int -> Check ()

410+assignVariable name m =

411+ case M.lookup name m of

412+ Nothing -> return ()

413+ Just _ -> throwError $ "Variable with name " ++ show name ++ " already exists."

414+

415+typeConstraintsForStatement :: M.Map Ident Int -> M.Map Ident Int -> Int -> Statement -> Check ([TypeConstraint], Bool, M.Map Ident Int)

416+typeConstraintsForStatement m mass ret (VariableIntroduction name val) = do

417+ assignVariable name (m `M.union` mass)

418+ (cs1, n1) <- typeConstraints m val

419+ return $ (cs1, False, M.insert name n1 mass)

420+typeConstraintsForStatement m mass ret (Assignment tgt val) = do

421+ (cs1, n1) <- typeConstraints m val

422+ cs2 <- typeConstraintsForAssignmentTarget m mass n1 tgt

423+ return (cs1 ++ cs2, False, mass)

424+typeConstraintsForStatement m mass ret (While val inner) = do

425+ (cs1, n1) <- typeConstraints m val

426+ (cs2, allCodePathsReturn, _) <- typeConstraintsForBlock m mass ret inner

427+ return $ ((TypeConstraint n1 Boolean) : cs1 ++ cs2, allCodePathsReturn, mass)

428+typeConstraintsForStatement m mass ret (If ifst) = do

429+ (cs, allCodePathsReturn) <- typeConstraintsForIfStatement m mass ret ifst

430+ return $ (cs, allCodePathsReturn, mass)

431+typeConstraintsForStatement m mass ret (For ident start end inner) = do

432+ assignVariable ident (m `M.union` mass)

433+ (cs1, n1) <- typeConstraints (m `M.union` mass) start

434+ (cs2, n2) <- typeConstraints (m `M.union` mass) end

435+ let mass1 = M.insert ident n1 mass

436+ (cs3, allCodePathsReturn, _) <- typeConstraintsForBlock (m `M.union` mass1) mass1 ret inner

437+ return $ ((TypeConstraint n1 Number) : (TypeConstraint n2 Number) : cs1 ++ cs2 ++ cs3, allCodePathsReturn, mass)

438+typeConstraintsForStatement m mass ret (ForEach ident vals inner) = do

439+ assignVariable ident (m `M.union` mass)

440+ val <- fresh

441+ (cs1, n1) <- typeConstraints (m `M.union` mass) vals

442+ let mass1 = M.insert ident val mass

443+ (cs2, allCodePathsReturn, _) <- typeConstraintsForBlock (m `M.union` mass1) mass1 ret inner

444+ guardWith "Cannot return from within a foreach block" $ not allCodePathsReturn

445+ return $ ((TypeConstraint n1 (Array (TUnknown val))) : cs1 ++ cs2, False, mass)

446+typeConstraintsForStatement m mass ret (Return val) = do

447+ (cs1, n1) <- typeConstraints (m `M.union` mass) val

448+ return ((TypeConstraint n1 (TUnknown ret)) : cs1, True, mass)

449+

450+typeConstraintsForIfStatement :: M.Map Ident Int -> M.Map Ident Int -> Int -> IfStatement -> Check ([TypeConstraint], Bool)

451+typeConstraintsForIfStatement m mass ret (IfStatement val thens Nothing) = do

452+ (cs1, n1) <- typeConstraints m val

453+ (cs2, allCodePathsReturn, _) <- typeConstraintsForBlock m mass ret thens

454+ return ((TypeConstraint n1 Boolean) : cs1 ++ cs2, allCodePathsReturn)

455+typeConstraintsForIfStatement m mass ret (IfStatement val thens (Just elses)) = do

456+ (cs1, n1) <- typeConstraints m val

457+ (cs2, allCodePathsReturn1, _) <- typeConstraintsForBlock m mass ret thens

458+ (cs3, allCodePathsReturn2) <- typeConstraintsForElseStatement m mass ret elses

459+ return ((TypeConstraint n1 Boolean) : cs1 ++ cs2 ++ cs3, allCodePathsReturn1 && allCodePathsReturn2)

460+

461+typeConstraintsForElseStatement :: M.Map Ident Int -> M.Map Ident Int -> Int -> ElseStatement -> Check ([TypeConstraint], Bool)

462+typeConstraintsForElseStatement m mass ret (Else elses) = do

463+ (cs, allCodePathsReturn, _) <- typeConstraintsForBlock m mass ret elses

464+ return (cs, allCodePathsReturn)

465+typeConstraintsForElseStatement m mass ret (ElseIf ifst) = do

466+ (cs, allCodePathsReturn) <- typeConstraintsForIfStatement m mass ret ifst

467+ return (cs, allCodePathsReturn)

468+

469+typeConstraintsForAssignmentTarget :: M.Map Ident Int -> M.Map Ident Int -> Int -> AssignmentTarget -> Check [TypeConstraint]

470+typeConstraintsForAssignmentTarget m mass nval (AssignVariable var) =

471+ case M.lookup var mass of

472+ Nothing -> throwError $ "No local variable with name " ++ show var

473+ Just ty -> do

474+ return [TypeConstraint nval (TUnknown ty)]

475+typeConstraintsForAssignmentTarget m mass nval (AssignArrayIndex index tgt) = do

476+ arr <- fresh

477+ (cs1, n1) <- typeConstraints (m `M.union` mass) index

478+ cs2 <- typeConstraintsForAssignmentTarget m mass arr tgt

479+ return $ (TypeConstraint arr (Array (TUnknown nval))) : (TypeConstraint n1 Number) : cs1 ++ cs2

480+typeConstraintsForAssignmentTarget m mass nval (AssignObjectProperty prop tgt) = do

481+ obj <- fresh

482+ row <- fresh

483+ cs <- typeConstraintsForAssignmentTarget m mass obj tgt

484+ return $ (TypeConstraint obj (Object (RCons prop (TUnknown nval) $ RUnknown row))) : cs

485+

486+typeConstraintsForBlock :: M.Map Ident Int -> M.Map Ident Int -> Int -> [Statement] -> Check ([TypeConstraint], Bool, M.Map Ident Int)

487+typeConstraintsForBlock _ mass _ [] = return ([], False, mass)

488+typeConstraintsForBlock m mass ret (s:ss) = do

489+ (cs1, b1, mass1) <- typeConstraintsForStatement (m `M.union` mass) mass ret s

490+ case (b1, ss) of

491+ (True, []) -> return (cs1, True, mass1)

492+ (True, _) -> throwError "Unreachable code"

493+ (False, ss) -> do

494+ (cs2, b2, mass2) <- typeConstraintsForBlock m mass1 ret ss

495+ return (cs1 ++ cs2, b2, mass2)

496+

497+solveTypeConstraints :: [TypeConstraint] -> TypeSolution -> Check TypeSolution

498+solveTypeConstraints [] s = return s

499+solveTypeConstraints all@(TypeConstraint n t:cs) s = do

500+ typeOccursCheck n t

501+ let s' = let (f, g) = runTypeSolution s

502+ in TypeSolution (replaceType n t . f, replaceType n t . g)

503+ cs' <- fmap concat $ mapM (substituteTypeInConstraint n t) cs

504+ solveTypeConstraints cs' s'

505+solveTypeConstraints (RowConstraint n r:cs) s = do

506+ rowOccursCheck n r

507+ let s' = let (f, g) = runTypeSolution s

508+ in TypeSolution $ (replaceRow n r . f, replaceRow n r . g)

509+ cs' <- fmap concat $ mapM (substituteRowInConstraint n r) cs

510+ solveTypeConstraints cs' s'

511+

512+substituteTypeInConstraint :: Int -> Type -> TypeConstraint -> Check [TypeConstraint]

513+substituteTypeInConstraint n s (TypeConstraint m t)

514+ | n == m = unifyTypes s t

515+ | otherwise = return [TypeConstraint m (replaceType n s t)]

516+substituteTypeInConstraint n s (RowConstraint m r)

517+ = return [RowConstraint m (replaceType n s r)]

518+

519+substituteRowInConstraint :: Int -> Row -> TypeConstraint -> Check [TypeConstraint]

520+substituteRowInConstraint n r (TypeConstraint m t)

521+ = return [TypeConstraint m (replaceRow n r t)]

522+substituteRowInConstraint n r (RowConstraint m r1)

523+ | m == n = unifyRows r r1

524+ | otherwise = return [RowConstraint m (replaceRow n r r1)]

525+

526+unifyTypes :: Type -> Type -> Check [TypeConstraint]

527+unifyTypes (TUnknown u1) (TUnknown u2) | u1 == u2 = return []

528+unifyTypes (TUnknown u) t = do

529+ typeOccursCheck u t

530+ return [TypeConstraint u t]

531+unifyTypes t (TUnknown u) = do

532+ typeOccursCheck u t

533+ return [TypeConstraint u t]

534+unifyTypes (SaturatedTypeSynonym name1 args1) (SaturatedTypeSynonym name2 args2) | name1 == name2 =

535+ fmap concat $ zipWithM unifyTypes args1 args2

536+unifyTypes (SaturatedTypeSynonym name args) ty = do

537+ env <- getEnv

538+ case M.lookup name (typeSynonyms env) of

539+ Just (synArgs, body) -> do

540+ let m = M.fromList $ zip synArgs args

541+ let replaced = replaceTypeVars m body

542+ unifyTypes replaced ty

543+ Nothing -> error "Type synonym was not defined"

544+unifyTypes ty s@(SaturatedTypeSynonym _ _) = unifyTypes s ty

545+unifyTypes Number Number = return []

546+unifyTypes String String = return []

547+unifyTypes Boolean Boolean = return []

548+unifyTypes (Array s) (Array t) = unifyTypes s t

549+unifyTypes (Object row1) (Object row2) = unifyRows row1 row2

550+unifyTypes (Function args1 ret1) (Function args2 ret2) = do

551+ guardWith "Function applied to incorrect number of args" $ length args1 == length args2

552+ cs1 <- fmap concat $ zipWithM unifyTypes args1 args2

553+ cs2 <- unifyTypes ret1 ret2

554+ return $ cs1 ++ cs2

555+unifyTypes (TypeVar v1) (TypeVar v2) | v1 == v2 = return []

556+unifyTypes (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = return []

557+unifyTypes (TypeVar v1) (TypeVar v2) = return []

558+unifyTypes (TypeApp t1 t2) (TypeApp t3 t4) = do

559+ cs1 <- unifyTypes t1 t3

560+ cs2 <- unifyTypes t2 t4

561+ return $ cs1 ++ cs2

562+unifyTypes t1 t2 = throwError $ "Cannot unify " ++ prettyPrintType t1 ++ " with " ++ prettyPrintType t2 ++ "."

563+

564+unifyRows :: Row -> Row -> Check [TypeConstraint]

565+unifyRows r1 r2 =

566+ let

567+ (s1, r1') = toList r1

568+ (s2, r2') = toList r2

569+ int = [ (t1, t2) | (name, t1) <- s1, (name', t2) <- s2, name == name' ]

570+ sd1 = [ (name, t1) | (name, t1) <- s1, not (elem name (map fst s2)) ]

571+ sd2 = [ (name, t2) | (name, t2) <- s2, not (elem name (map fst s1)) ]

572+ in rethrow (\e -> "Cannot unify " ++ prettyPrintRow r1 ++ " with " ++ prettyPrintRow r2 ++ ": " ++ e) $ do

573+ cs1 <- fmap concat $ mapM (uncurry unifyTypes) int

574+ cs2 <- unifyRows' sd1 r1' sd2 r2'

575+ return $ cs1 ++ cs2

576+ where

577+ unifyRows' :: [(String, Type)] -> Row -> [(String, Type)] -> Row -> Check [TypeConstraint]

578+ unifyRows' [] (RUnknown u) sd r = do

579+ rowOccursCheck u r

580+ return [RowConstraint u (fromList (sd, r))]

581+ unifyRows' sd r [] (RUnknown u) = do

582+ rowOccursCheck u r

583+ return [RowConstraint u (fromList (sd, r))]

584+ unifyRows' ((name, ty):row) r others (RUnknown u) = do

585+ u' <- fresh

586+ cs <- unifyRows' row r others (RUnknown u')

587+ return (RowConstraint u (RCons name ty (RUnknown u')) : cs)

588+ unifyRows' [] REmpty [] REmpty = return []

589+ unifyRows' sd1 r1 sd2 r2 = throwError $ "Cannot unify " ++ prettyPrintRow (fromList (sd1, r1)) ++ " with " ++ prettyPrintRow (fromList (sd2, r2)) ++ "."

590+ toList :: Row -> ([(String, Type)], Row)

591+ toList (RCons name ty row) = let (tys, rest) = toList row

592+ in ((name, ty):tys, rest)

593+ toList r = ([], r)

594+ fromList :: ([(String, Type)], Row) -> Row

595+ fromList ([], r) = r

596+ fromList ((name, t):ts, r) = RCons name t (fromList (ts, r))

src/PureScript/Types.hsnew file+43

@@ -0,0 +1,43 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Purescript.Types

4+-- Copyright : (c) Phil Freeman 2013

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+--

13+-----------------------------------------------------------------------------

14+

15+{-# LANGUAGE DeriveDataTypeable #-}

16+

17+module PureScript.Types where

18+

19+import Data.Data

20+

21+data Type

22+ = TUnknown Int

23+ | Number

24+ | String

25+ | Boolean

26+ | Array Type

27+ | Object Row

28+ | Function [Type] Type

29+ | TypeVar String

30+ | TypeConstructor String

31+ | TypeApp Type Type

32+ | SaturatedTypeSynonym String [Type] deriving (Show, Eq, Data, Typeable)

33+

34+data PolyType = PolyType [String] Type deriving (Show, Data, Typeable)

35+

36+data Row

37+ = RUnknown Int

38+ | RowVar String

39+ | REmpty

40+ | RCons String Type Row deriving (Show, Eq, Data, Typeable)

41+

42+monoType :: Type -> PolyType

43+monoType = PolyType []

src/PureScript/Values.hsnew file+101

@@ -0,0 +1,101 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : PureScript.Values

4+-- Copyright : (c) Phil Freeman 2013

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+--

13+-----------------------------------------------------------------------------

14+

15+{-# LANGUAGE DeriveDataTypeable #-}

16+

17+module PureScript.Values where

18+

19+import PureScript.Types

20+import PureScript.Names

21+

22+import Data.Data

23+

24+data UnaryOperator

25+ = Negate

26+ | Not

27+ | BitwiseNot deriving (Show, Eq, Data, Typeable)

28+

29+data BinaryOperator

30+ = Add

31+ | Subtract

32+ | Multiply

33+ | Divide

34+ | Modulus

35+ | EqualTo

36+ | NotEqualTo

37+ | LessThan

38+ | LessThanOrEqualTo

39+ | GreaterThan

40+ | GreaterThanOrEqualTo

41+ | And

42+ | Or

43+ | BitwiseAnd

44+ | BitwiseOr

45+ | BitwiseXor

46+ | ShiftLeft

47+ | ShiftRight

48+ | ZeroFillShiftRight

49+ | Concat deriving (Show, Eq, Data, Typeable)

50+

51+data Value

52+ = NumericLiteral (Either Integer Double)

53+ | StringLiteral String

54+ | BooleanLiteral Bool

55+ | Unary UnaryOperator Value

56+ | Binary BinaryOperator Value Value

57+ | ArrayLiteral [Value]

58+ | Indexer Value Value

59+ | ObjectLiteral [(String, Value)]

60+ | Accessor String Value

61+ | Abs [Ident] Value

62+ | App Value [Value]

63+ | Var Ident

64+ | IfThenElse Value Value Value

65+ | Block [Statement]

66+ | Constructor String

67+ | Case Value [(Binder, Value)]

68+ | TypedValue Value PolyType deriving (Show, Data, Typeable)

69+

70+data Statement

71+ = VariableIntroduction Ident Value

72+ | Assignment AssignmentTarget Value

73+ | While Value [Statement]

74+ | For Ident Value Value [Statement]

75+ | ForEach Ident Value [Statement]

76+ | If IfStatement

77+ | Return Value deriving (Show, Data, Typeable)

78+

79+data IfStatement = IfStatement Value [Statement] (Maybe ElseStatement) deriving (Show, Data, Typeable)

80+

81+data ElseStatement

82+ = Else [Statement]

83+ | ElseIf IfStatement deriving (Show, Data, Typeable)

84+

85+data Binder

86+ = NullBinder

87+ | BooleanBinder Bool

88+ | StringBinder String

89+ | NumberBinder (Either Integer Double)

90+ | VarBinder Ident

91+ | NullaryBinder String

92+ | UnaryBinder String Binder

93+ | ObjectBinder [(String, Binder)]

94+ | ArrayBinder [Binder] (Maybe Binder)

95+ | NamedBinder Ident Binder

96+ | GuardedBinder Value Binder deriving (Show, Data, Typeable)

97+

98+data AssignmentTarget

99+ = AssignVariable Ident

100+ | AssignObjectProperty String AssignmentTarget

101+ | AssignArrayIndex Value AssignmentTarget deriving (Show, Data, Typeable)

src/Tests.hsdeleted−141

@@ -1,141 +0,0 @@

1−module Tests (runTests) where

2−

3−import Prelude.Compat

4−import Data.List

5−import Control.Applicative

6−import Control.Monad

7−

8−import System.Process

9−import System.FilePath

10−import System.IO

11−import System.Directory

12−

13−-------------------------------------------------------------------------------

14−testsDir :: IO (FilePath, FilePath)

15−-------------------------------------------------------------------------------

16−testsDir = do

17− baseDir <- getCurrentDirectory

18− return (baseDir </> "purescript-tests", baseDir)

19−

20−-------------------------------------------------------------------------------

21−runTests :: IO ()

22−-------------------------------------------------------------------------------

23−runTests = do

24−

25− (outputDir, baseDir) <- testsDir

26−

27− outputDirExists <- doesDirectoryExist outputDir

28− when outputDirExists $ removeDirectoryRecursive outputDir

29− createDirectory outputDir

30−

31− let srcDir = outputDir </> "src"

32− createDirectory srcDir

33−

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−

40− fetchPackages

41−

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

43−

44− tmp <- getTemporaryDirectory

45− createDirectoryIfMissing False (tmp </> logpath)

46− outputFile <- openFile (tmp </> logpath </> logfile) WriteMode

47− hClose outputFile

48−

49− -- Run the tests

50− --

51− forM_ tests $ \inputFile -> do

52− --

53− -- Compile/build

54− --

55− putStrLn $ "Compiling test " ++ inputFile ++ " ..."

56− setCurrentDirectory outputDir

57− copyFile (passingDir </> inputFile) (srcDir </> inputFile)

58−

59− let testCaseDir = passingDir </> (takeWhile (/='.') inputFile)

60− testCaseDirExists <- doesDirectoryExist testCaseDir

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

62−

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

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

65− callProcess "spago" ["build"]

66− --

67− -- Run executable file

68− --

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

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

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

72−

73− removeFile (srcDir </> inputFile)

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

75−

76− -- TODO: support failing test cases

77− --

78− -- let failing = baseDir </> "examples" </> "failing"

79− -- failingTestCases <- sort . filter (".purs" `isSuffixOf`) <$> getDirectoryContents failing

80− --

81−

82− setCurrentDirectory baseDir

83− putStrLn "PureScript tests finished"

84− putStrLn $ "Total tests available: " ++ show (length passingTestCases)

85− putStrLn $ "Tests run: " ++ show (length tests)

86− putStrLn $ "Tests skipped: " ++ show (length skipped)

87−

88−-------------------------------------------------------------------------------

89−packages :: [String]

90−-------------------------------------------------------------------------------

91−packages =

92− [ "arrays"

93− , "assert"

94− , "console"

95− , "control"

96− , "effect"

97− , "foldable-traversable"

98− , "functions"

99− , "generics-rep"

100− , "invariant"

101− , "newtype"

102− , "partial"

103− , "prelude"

104− , "proxy"

105− , "refs"

106− , "st"

107− , "type-equality"

108− , "typelevel-prelude"

109− ]

110−

111−-------------------------------------------------------------------------------

112−fetchPackages :: IO ()

113−-------------------------------------------------------------------------------

114−fetchPackages = do

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−

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

120− return ()

121−

122−-------------------------------------------------------------------------------

123−skipped :: [String]

124−-------------------------------------------------------------------------------

125−skipped =

126− [ "2172.purs" -- foreign in Main needed (test manually)

127− , "EffFn.purs" -- foreign in Main needed (test manually)

128− , "FunWithFunDeps.purs" -- foreign in Main needed (test manually)

129− , "NumberLiterals.purs" -- unreliable float string comparison (test manually)

130− , "PolyLabels.purs" -- foreign in Main needed (test manually)

131− , "RowUnion.purs" -- foreign in Main needed (test manually)

132− , "ShadowedModuleName.purs" -- ?

133− , "StringEdgeCases.purs" -- javascript char encoding specific

134− , "StringEscapes.purs" -- Partially javascript-char-encoding-specific (test manually)

135− ]

136−

137−logpath :: FilePath

138−logpath = "purescript-output"

139−

140−logfile :: FilePath

141−logfile = "purescript-tests.out"

stack.nixdeleted−23

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

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−}:

17−

18−pkgs.haskell.lib.buildStackProject {

19− name = "default-stack-shell";

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

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

22− LANG = "en_US.UTF-8";

23−}

stack.yamldeleted−24

@@ -1,24 +0,0 @@

1−resolver: lts-13.26

2−

3−packages:

4−- .

5−

6−extra-deps:

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

8− commit: 9cad73ed8ea7df3011032ddbd2f3de5a0c08629c

9−- happy-1.19.9

10−- language-javascript-0.7.0.0

11−- network-3.0.1.1

12−- these-1.0.1

13−- semialign-1

14−

15−nix:

16− enable: false

17− shell-file: stack.nix

18−

19−flags:

20− aeson-pretty:

21− lib-only: true

22− these:

23− assoc: false

24− quickcheck: false

support/ffi-loader.godeleted−30

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

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-loaderdeleted−2

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

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

2−

support/go.mod.outputdeleted−2

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

1−module $PROJECT/purescript-native/output

2−

support/go.mod.workingdeleted−1

@@ -1 +0,0 @@

1−module $PROJECT/example

test/Spec.hsdeleted−2

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

1−main :: IO ()

2−main = putStrLn "Test suite not yet implemented"