golang..6970c35 · rowtype-yoga/purescript-native

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

99 files changed+4079−2716

unifiedsplit

.gitignore−15

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

11dist

22cabal-dev

3−.cabal-sandbox

4−cabal.sandbox.config

53*.o

64*.hi

75*.chi

86*.chs.h

97*.lksh*

108.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

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

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,

10+subject to the following conditions:

711

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

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

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

13+copies or substantial portions of the Software.

1014

11− * Redistributions in binary form must reproduce the above

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

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

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

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

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

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

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

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

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

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

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

PureScript.cabalnew file+51

@@ -0,0 +1,51 @@

1+name: purescript

2+version: 0.0.1

3+cabal-version: >=1.8

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.Values

20+ PureScript.CodeGen.Pretty.Types PureScript PureScript.Declarations

21+ PureScript.Names PureScript.TypeChecker.Synonyms

22+ PureScript.CodeGen.Externs PureScript.CodeGen.JS

23+ PureScript.CodeGen.Common.Gen PureScript.CodeGen.Common Main

24+ PureScript.CodeGen PureScript.Kinds PureScript.Parser

25+ PureScript.TypeChecker PureScript.Types PureScript.Values

26+ PureScript.Parser.Common PureScript.Parser.Declarations

27+ PureScript.Parser.Types PureScript.Parser.Values

28+ PureScript.TypeChecker.Kinds PureScript.TypeChecker.Monad

29+ PureScript.TypeChecker.Types PureScript.Parser.State

30+ PureScript.Parser.Kinds PureScript.CodeGen.Pretty.Kinds

31+ exposed: True

32+ buildable: True

33+ hs-source-dirs: src

34+ other-modules:

35+

36+Test-Suite tests

37+ type: exitcode-stdio-1.0

38+ main-is: Main.hs

39+ hs-source-dirs: tests

40+ build-depends: base -any, syb -any, directory -any, filepath -any,

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

42+ utf8-string -any, purescript -any

43+

44+executable psc

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

46+ mtl -any, transformers -any, parsec -any, utf8-string -any, syb -any

47+ main-is: Main.hs

48+ buildable: True

49+ hs-source-dirs: src

50+ other-modules:

51+

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+505−28

@@ -1,41 +1,518 @@

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−* 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`

8+## Current Features

209

10+- Full Type Inference

11+- Higher Kinded Polymorphism

12+- Support for basic Javascript types

13+- Extensible records

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

15+- Functions with multiple arguments

16+- Pattern matching

17+- Simple FFI

2118

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

19+## License

2320

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

21+See the `LICENSE` file

2522

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

23+## Installation

2724

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

25+Install the Haskell Plaform, then `cabal install`

2926

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.

27+## Usage

3428

29+The `psc` executable takes a list of PureScript source files as arguments and by default writes out its errors or output to the console.

3530

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)

31+The following options are supported:

3932

33+ -o --output

34+ Write the generated Javascript to the specified file

35+

36+ -e --externs

37+ Write a list of externs declarations to the specified file in addition to generating Javascript output

4038

41−---

39+## Motivation

40+

41+I was looking for a simple functional language which would compile to JavaScript and have the following characteristics:

42+

43+- Generate simple readable Javascript

44+- Provide the ability to compile to tight loops if necessary

45+- Reasonable type system

46+- Ideally, written in a programming language I would enjoy working in

47+- Provides a simple interface to existing Javascript code

48+

49+I didn't find exactly what I was looking for, so I wrote PureScript. It doesn't have everything right now, but it should serve as a simple core on which to develop new ideas.

50+

51+PureScript is *not* designed to be a general-purpose programming language. The primary use case is as a generator for purely-functional core libraries, with the main application code written in another language.

52+

53+PureScript can also be seen as a trade-off between a theoretically ideal language and one which generates reasonably high performance code.

54+

55+## First Example

56+

57+The following code defines a `Person` data type and a function to generate a string representation for a `Person`:

58+

59+ data Person = Person

60+ { name :: String

61+ ; age :: Number

62+ }

63+

64+ extern itoa :: Number -> String

65+

66+ showPerson :: Person -> String

67+ showPerson = \p -> case p of

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

69+

70+Line by line, this reads as follows:

71+

72+- `Person` is a data type with one constructor, also called `Person`

73+ - The `Person` constructor takes an object with two properties, `name` which is a `String`, and `age` which is a `Number`

74+- The `itoa` function is written in Javascript, and takes a `Number` and returns a `String`

75+- The `showPerson` function takes a `Person` and returns a `String`

76+- `showPerson` works by case analysis on its argument `p`, first matching the constructor `Person` and then using string concatenation and object accessors to return its result.

77+

78+The generated Javascript looks like this:

79+

80+ var Person = function (value) {

81+ return { ctor: 'Person', value: value };

82+ };

83+

84+ var showPerson = function (p) {

85+ return (function (_0) {

86+ if (_0.ctor === "Person") {

87+ var _1 = _0.value;

88+ var o = _1;

89+ return o.name ++ ", aged " ++ itoa(o.age);

90+ }

91+ throw "Failed pattern match";

92+ })(p);

93+ };

94+

95+## Type System

96+

97+The type system defines the following types:

98+

99+- Primitive Types

100+ - Number

101+ - String

102+ - Boolean

103+- Arrays

104+ - E.g. `[String]`, `[[Number]]`

105+- Records

106+ - E.g. `{ foo :: String ; bar :: Number }`

107+- Tagged Unions

108+ - E.g. `data Foo a = Foo | Bar String`

109+- Functions

110+ - E.g. `Number -> String`

111+ - E.g. `(Number, Number) -> Number`

112+ - Functions can have zero or more arguments

113+- Polymorphic types (for top level declarations only)

114+ - E.g. `forall a. a -> a`

115+

116+## Primitive Types

117+

118+The three primitive types `String`, `Number` and `Boolean` correspond to their Javascript equivalents at runtime.

119+

120+PureScript supports the same binary and unary operations on primitive types as Javascript, with the following exceptions:

121+

122+- String concatenation is denoted `++` to differentiate it from numeric addition, `+`

123+- PureScript's `==` and `!=` correspond to Javascript's strong equality tests `===` and `!==`

124+

125+Examples:

126+

127+ num = 1 + 2 * 3

128+ str = "Hello, " ++ "World!"

129+ bool = 1 > 2 || true

130+

131+## Arrays

132+

133+PureScript arrays correspond to Javascript arrays at runtime, but all elements must have the same type.

134+

135+Array literals look like Javascript array literals: `[1, 2, 3]`

136+

137+Array elements can be read using array index notation `arr[0]`

138+

139+## Records

140+

141+PureScript records correspond to Javascript objects.

142+

143+Record literals look like Javascript object literals: `{ foo: "Foo" }`

144+

145+Properties can be read by using dot notation: `o.foo`

146+

147+## Tagged Unions

148+

149+Tagged unions consist of one or more constructors, each of which takes zero or one arguments.

150+

151+Tagged unions can only be created using their constructors, and deconstructed through pattern matching (see later).

152+

153+For example:

154+

155+ data Foo a = Foo | Bar String

156+

157+ runFoo = \foo -> case foo of

158+ Foo -> "It's a Foo"

159+ Bar s -> "It's a Bar. The string is " ++ s

160+

161+ runFoo Foo ++ runFoo (Bar "Test")

162+

163+In the example, Foo is a tagged union type which has two constructors. It's first constructor `Foo` takes no argument, and it's second `Bar` takes one, which must be a String.

164+

165+`runFoo` is an example of pattern matching on a tagged union type to discover its constructor, and the last line shows how `Foo`s are constructed.

166+

167+## Functions

168+

169+Functions in TypeScript can have zero or more arguments in general, just like in Javascript.

170+

171+Functions are introduced by using a backslash followed by a comma separated list of argument names:

172+

173+ test1 = \a, b, c -> a + b + c

174+

175+which would correspond to the Javascript `function test1(a, b, c) { return a + b + c; }`

176+

177+A function taking no arguments would look like this:

178+

179+ test2 = \ -> 100

180+

181+which would correspond to the Javascript `function test2() { return 100; }`

182+

183+Functions are applied by providing their arguments inside parentheses:

184+

185+ test1(1, 2, 3)

186+ test2()

187+

188+A special case is made in the case of functions with one argument. These functions can be applied without parentheses, and function application associates to the left:

189+

190+ -- has type Number -> Number -> Number -> Number

191+ addThree = \a -> \b -> \c -> a + b + c

192+

193+ -- has type Number -> Number -> Number

194+ addThree 1

195+

196+ -- has type Number -> Number

197+ addThree 1 2

198+

199+ -- has type Number

200+ addThree 1 2 3

201+

202+## Polymorphic Types

203+

204+Expressions defined at the top level may have polymorphic types.

205+

206+Here is an example:

207+

208+ identity = \x -> x

209+

210+`identity` is inferred to have (polymorphic) type `forall t0. t0 -> t0`. This means that for any type `t0`, `identity` can be given a value of type `t0` and will give back a value of the same type.

211+

212+A type annotation can also be provided:

213+

214+ identity :: forall a. a -> a

215+ identity = \x -> x

216+

217+Functions may also be polymorphic in row types or type variables with other kinds (see "Kind System"):

218+

219+ addProps = \o -> o.foo + o.bar

220+

221+Here, `addProps` is inferred to have type `forall r. { foo :: Number; bar :: Number | r } -> Number`. That is, it can take any type which has properties `Foo` and `Bar`, and *any other record properties*.

222+

223+So, the following compiles:

224+

225+ addProps { foo: 1, bar: 2, baz: 3 }

226+

227+but the following does not:

228+

229+ addProps { foo: 1 }

230+

231+since the `bar` property is missing.

232+

233+Again, a type annotation can be provided if necessary.

234+

235+## Type Inference

236+

237+All types can be inferred, but annotations can optionally be provided.

238+

239+## Kind System

240+

241+There are two primitive kinds, the kind `*` of types and the kind `#` of rows. Higher kinded types are also supported. That is, a type variable can refer to not only a type or a row, but a type constructor, or row constructor etc.

242+

243+## Whitespace

244+

245+Syntax is whitespace sensitive. The general rule of thumb is that declarations which span multiple lines should be indented past the column on which they were first defined on their subsequent lines.

246+

247+That is, the following is valid:

248+

249+ foo = bar(x) +

250+ baz(x)

251+

252+But this is not:

253+

254+ foo = bar(x) +

255+ baz(x)

256+

257+## Do Notation

258+

259+There is a keyword `do`, which does not have the same purpose as the `do` keyword in Haskell.

260+

261+`do` introduces a block. Blocks consist of statements, and must return a value of the same type on every branch of execution.

262+

263+The following types of statement are supported:

264+

265+- Variable introduction

266+- Variable assignment

267+- For loops

268+- For-each loops

269+- While loops

270+- If-Then-Else statements

271+

272+Here is an example of a power function defined using a block:

273+

274+ pow = \n, p -> do

275+ var m = n

276+ for i <- 0 until p:

277+ m = m * n

278+ return m

279+

280+Blocks enable local mutation of their variables, but mutation is not allowed in general. The type system prevents mutable variables from escaping their scope.

281+

282+That is, while the example above is valid, the following does not compile:

283+

284+ incr = \n -> do

285+ n = n + 1

286+ return n

287+

288+The variable `n` is not mutable, and so the assignment in the first line of the `do` block is not allowed.

289+

290+This function can be rewritten as follows:

291+

292+ incr = \n -> do

293+ var m = n

294+ m = m + 1

295+ return m

296+

297+## For Loops

298+

299+For loops look like this:

300+

301+ total = do

302+ var n = 0

303+ for i <- 0 until 10:

304+ n = n + i

305+ return n

306+

307+The bounds `0` and `10` are inclusive and exclusive respectively.

308+

309+## For-Each Loops

310+

311+For each loops loop over the elements in an array using the `Object.forEach` method. A polyfill may be required for some browsers:

312+

313+ total = \arr -> do

314+ var n = 0

315+ foreach i in arr:

316+ n = n + i

317+ return n

318+

319+## While Loops

320+

321+The syntax of a while loop is similar to a foreach loop:

322+

323+ log2 = \n -> do

324+ var count = 0

325+ var m = n

326+ while m > 1:

327+ m = m / 2

328+ count = count + 1

329+ return count

330+

331+## If-Then-Else Statements

332+

333+Else branches are optional, and may contain further `if` statements, just as in Javascript:

334+

335+ collatz = \n -> do

336+ var count = 0

337+ var m = n

338+ while m > 1:

339+ if m % 2 == 0:

340+ m = m / 2

341+ else:

342+ m = m * 3 + 1

343+ count = count + 1

344+ return count

345+

346+## If-Then-Else Expressions

347+

348+The `if`, `then` and `else` keywords can also be used to create conditional expressions. In this case, the `else` block is always required.

349+

350+For example,

351+

352+ conditional = if 2 > 1 then "ok" else "oops"

353+

354+## Pattern Matching

355+

356+Pattern matching deconstructs a value to bring zero or more expressions into scope. Pattern matches are introduced with the `case` keyword.

357+

358+Pattern matches have the following general form

359+

360+ case value of

361+ pattern -> result

362+ ...

363+ pattern -> result

364+

365+The following pattern types are supported:

366+

367+- Wildcard pattern

368+- Literal patterns

369+- Variable pattern

370+- Array patterns

371+- Record patterns

372+- Named patterns

373+- Guards

374+

375+Patterns need not be exhaustive. A pattern match failed exception will be thrown at runtime if no pattern matches the input.

376+

377+## Wildcard Patterns

378+

379+The wilcard `_` matches any input and brings nothing into scope:

380+

381+ case x of

382+ _ -> 0

383+

384+## Literal Patterns

385+

386+Literal patterns are provided to match on primitives:

387+

388+ case booleanValue of

389+ true -> 0

390+ false -> 1

391+

392+ case stringValue of

393+ "Foo" -> 0

394+ _ -> 1

395+

396+ case numericValue of

397+ 0 -> 0

398+ _ -> 1

399+

400+## Variable Pattern

401+

402+A variable pattern matches any input and binds that input to its name:

403+

404+ case foo(x) of

405+ result -> bar(result)

406+

407+## Array Patterns

408+

409+Array patterns match an input which is an array, and bring its elements into scope.

410+

411+For example:

412+

413+ f = \arr -> case arr of

414+ [x] -> x

415+ [x, y : xs] -> x * y + f(xs)

416+ _ -> 0

417+

418+Here, the first pattern only matches arrays of length one, and brings the first element of the array into scope.

419+

420+The second pattern matches arrays with two or more elements, and brings the first and second elements into scope, along with the remainder of the array as the variable `xs`.

421+

422+## Record Patterns

423+

424+Record patterns match an input which is a record, and bring its properties into scope.

425+

426+ f = \o -> case o of

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

428+ _ -> 0

429+

430+## Nested Patterns

431+

432+The patterns above can be combined to create larger patterns.

433+

434+For example:

435+

436+ f = \o -> case o of

437+ { arr = [x:_], take = "car" } -> x

438+ { arr = [_,x:_], take = "cadr" } -> x

439+ _ -> 0

440+

441+## Named Patterns

442+

443+Named patterns bring additional names into scope when using nested patterns. Any pattern can be named by using the `@` symbol:

444+

445+ f = \arr -> case arr of

446+ a@[_,_:_] -> a

447+ a -> a

448+

449+Here, in the first pattern, any array with two or more elements will be matched and bound to the variable `a`.

450+

451+## Guards

452+

453+Guards are used to impose additional constraints inside a pattern using boolean-valued expressions, and are introduced with a pipe after the pattern:

454+

455+ evens = \arr -> case arr of

456+ [] -> 0

457+ [x:xs] | x % 2 == 0 -> 1 + evens xs

458+ [_:xs] -> evens xs

459+

460+## Type Synonyms

461+

462+For convenience, it is possible to declare a synonym for a type using the `type` keyword. Type synonyms can include type arguments.

463+

464+For example:

465+

466+ type Foo = { foo :: Number, bar Number }

467+

468+ addFoo :: Foo -> Number

469+ addFoo = \o -> o.foo + o.bar

470+

471+## Record Updates

472+

473+Properties on records can be updated using the following syntax: `o { key = value, ..., key = value }`

474+

475+For example, the following function increments the `foo` property on its argument:

476+

477+ incr = \o -> o { foo = o.foo + 1 }

478+

479+The generated Javascript assumes the existence of a method called `Object.extend` such that `Object.extend(o, p)` takes an object `o` and generates a shallow copy of `o` including the properties of `p`. A simple JQuery implementation of this specification is

480+

481+ Object.prototype.extend = function(o, p) {

482+ return $.extend({}, o, p);

483+ };

484+

485+## Operators

486+

487+In addition to the standard operators, user-defined infix operators can be created by enclosing names in parentheses:

488+

489+E.g. to create a synonym for string concatenation:

490+

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

492+

493+ greeting = "Hello" <> "World!"

494+

495+Regular functions can be used as operators by enclosing their names in backticks:

496+

497+ foo = \x -> \y -> x * y + y

498+

499+ test = 10 `foo` 20

500+

501+Fixity declarations can associate a precedence level, which is a natural number, to a user-defined operator, and specify which way it associates:

502+

503+ infixl 5 <>

504+ infixr 7 %%

505+

506+## Foreign Function Interface

507+

508+The `extern` keyword declares a value which is defined in Javascript, and its type:

509+

510+ extern pow :: (Number, Number) -> Number

511+

512+To declare a new type with no constructors, use `extern data` and provide the kind:

513+

514+ extern data IO :: * -> *

515+

516+ extern console :: {

517+ log :: String -> IO {}

518+ }

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+shelltest/tests

examples/failing/KindError.psnew file+1

@@ -0,0 +1 @@

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

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+3

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

1+test = do

2+ var x = 0

3+ return x ++ "A"

examples/passing/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/passing/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/passing/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/passing/Console.psnew file+19

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

1+extern data 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/passing/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/passing/FFI.psnew file+5

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

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

3+bar :: (String) -> String

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

examples/passing/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/passing/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/passing/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/passing/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/passing/Match.psnew file+3

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

1+data Foo a = Foo

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

examples/passing/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/passing/NamedPatterns.psnew file+3

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

1+foo = \x -> case x of

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

3+ y -> y

examples/passing/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/passing/ObjectUpdate.psnew file+6

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

1+update = \o -> o { foo = "Foo" }

3+replace = \o -> case o of

4+ { foo = "Foo" } -> o { foo = "Bar" }

5+ { foo = "Bar" } -> o { bar = "Baz" }

6+ o -> o

examples/passing/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/passing/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/passing/Patterns.psnew file+23

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

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

10+g = \o -> case o of

11+ { arr = [x : xs], take = "car" } -> x

12+ { arr = [_, x : xs], take = "cadr" } -> x

13+ _ -> 0

14+

15+

16+h = \o -> case o of

17+ a@[_,_,_] -> a

18+ _ -> []

19+

20+isDesc = \o -> case o of

21+ [x, y] | x > y -> true

22+ _ -> false

23+

examples/passing/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/passing/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/passing/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/passing/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/passing/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/passing/s.psnew file+1

@@ -0,0 +1 @@

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

examples/shelltest/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/shelltest/Foreach.jsnew file+1

@@ -0,0 +1 @@

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

examples/shelltest/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/shelltest/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/shelltest/runAll.testnew file+23

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

1+# Maybe

2+mkdir -p tests && ../../dist/build/psc/psc ../passing/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 ../passing/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 ../passing/Foreach.ps -o tests/Foreach.js && cat tests/Foreach.js Foreach.js | node

19+<<<

20+>>>

21+15

22+>>>2

23+>>>= 0

examples/shelltest/runMain.jsnew file+1

@@ -0,0 +1 @@

1+main();

libraries/.gitignorenew file+1

@@ -0,0 +1 @@

1+*/all.js

libraries/jquery/Makefilenew file+4

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

1+all:

2+ ../../dist/build/psc/psc jquery.ps example.ps -o all.js

3+ cat jquery.js >> all.js

4+ echo "main()" >> all.js

libraries/jquery/example.psnew file+5

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

1+main = do

2+ var div = create "<div>"

3+ div = div `appendText` "Hello World!" `css` { color: "#FF0000" }

4+ div = div `appendTo` select "body"

5+ return { }

libraries/jquery/jquery.jsnew file+7

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

1+function select(s) { return $(s); }

2+function create(s) { return $(s); }

3+function attr(j, a) { return j.attr(o); }

4+function css(j, a) { return j.css(o); }

5+function append(j1, j2) { return j1.append(j2); }

6+function appendTo(j1, j2) { return j1.appendTo(j2); }

7+function appendText(j1, s) { return j1.append(s); }

libraries/jquery/jquery.psnew file+23

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

1+-- The jQuery wrapper type

2+extern data JQuery :: *

4+-- Wrapper function for jQuery selection $('..')

5+extern select :: String -> JQuery

7+-- Wrapper function for jQuery creation e.g. $('<div>')

8+extern create :: String -> JQuery

10+-- .attr({ ... })

11+extern attr :: forall attr. JQuery -> { | attr } -> JQuery

12+

13+-- .css({ ... })

14+extern css :: forall css. JQuery -> { | css } -> JQuery

15+

16+-- .append(...)

17+extern append :: JQuery -> JQuery -> JQuery

18+

19+-- .appendTo(...)

20+extern appendTo :: JQuery -> JQuery -> JQuery

21+

22+-- .append(...)

23+extern appendText :: JQuery -> String -> JQuery

libraries/prelude/Makefilenew file+3

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

1+all:

2+ cat prelude.js > all.js

3+ ../../dist/build/psc/psc prelude.ps -o all.js

libraries/prelude/prelude.jsnew file+50

@@ -0,0 +1,50 @@

1+// Arrays

3+function lengthi(l) { return l.length; }

4+function indexOf(l) { return function (e) { return l.indexOf(e); }; }

5+function lastIndexOf(l) { return function (e) { return l.lastIndexOf(e); }; }

6+function concat(l1) { return function (l2) { return l1.concat(l2); }; }

7+function join(l) { return l.join(); }

8+function joinWith(l) { return function (s) { return l.join(s); }; }

9+function push(l) { return function (e) { var l1 = l.slice(); l1.push(e); return l1; }; }

10+function reverse(l) { var l1 = l.slice(); l1.reverse(); return l1; }

11+function shift(l) { var l1 = l.slice(); l1.shift(); return l1; }

12+function slice(s) { return function(e) { return function (l) { return l.slice(s, e); }; }; }

13+function sort(l) { var l1 = l.slice(); l.sort(); return l1; }

14+function splice(s) { return function(e) { return function(l1) { return function(l2) { return l2.splice(s, e, l1); }; }; }; }

15+

16+// Strings

17+

18+function lengthS(s) { return s.length; }

19+function charAt(i) { return function(s) { return s.charAt(i); }; }

20+function indexOfS(s1) { return function(s2) { return s2.indexOf(s2); }; }

21+function lastIndexOfS(s1) { return function(s2) { return s2.lastIndexOf(s2); }; }

22+function localeCompare(s1) { return function(s2) { return s1.localeCompare(s2); }; }

23+function replace(s1) { return function(s2) { return function(s3) { return s3.replace(s1, s2) }; }; }

24+function sliceS(st) { return function(e) { return function(s) { return s.slice(st, e); }; }; }

25+function split(sep) { return function(s) { return s.split(s); }; }

26+function substr(n1) { return function(n2) { return function(s) { return s.substr(n1, n2); }; }; }

27+function substring(n1) { return function(n2) { return function(s) { return s.substring(n1, n2); }; }; }

28+function toLower(s) { return s.toLower(); }

29+function toUpper(s) { return s.toUpper(); }

30+function trim(s) { return s.trim(); }

31+

32+// Regex

33+

34+function regex(s1) { return function(s2) { return new Regex(s1, s2); }; };

35+function test(r) { return function (s) { return r.test(s); }; };

36+function match(r) { return function (s) { return s.match(r); }; };

37+function replaceR(r) { return function(s1) { return function(s2) { return s2.replace(r, s1) }; }; }

38+function search(r) { return function (s) { return s.search(r); }; };

39+

40+// Globals

41+

42+var nan = NaN;

43+var infinity = Infinity;

44+function toExponential(n) { return n.toExponential(); }

45+function toFixed(d) { return function(n) { return n.toFixed(d); }; }

46+function toPrecision(d) { return function(n) { return n.toPrecision(d); }; }

47+function numberToString(n) { return n.toString(); }

48+

49+// Math

50+var math = Math;

libraries/prelude/prelude.psnew file+166

@@ -0,0 +1,166 @@

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

2+id = \x -> x

4+flip :: forall a b c. (a -> b -> c) -> b -> a -> c

5+flip = \f -> \b -> \a -> f a b

7+const :: forall a b. a -> b -> a

8+const = \a -> \b -> a

10+(|>) :: forall a b c. (a -> b) -> (b -> c) -> a -> c

11+(|>) = \f -> \g -> \a -> g (f a)

12+

13+(<|) :: forall a b c. (b -> c) -> (a -> b) -> a -> c

14+(<|) = flip (|>)

15+

16+-- Maybe

17+

18+data Maybe a = Nothing | Just a

19+

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

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

22+ Nothing -> b

23+ Just a -> f a

24+

25+fromMaybe :: forall a. a -> Maybe a -> a

26+fromMaybe = \a -> maybe a id

27+

28+-- Arrays

29+

30+head :: forall a. [a] -> a

31+head = \xs -> case xs of

32+ [x:_] -> x

33+

34+headSafe :: forall a. [a] -> Maybe a

35+headSafe = \xs -> case xs of

36+ [x:_] -> Just x

37+ _ -> Nothing

38+

39+tail :: forall a. [a] -> [a]

40+tail = \xs -> case xs of

41+ [_:xs] -> xs

42+

43+tailSafe :: forall a. [a] -> Maybe [a]

44+tailSafe = \xs -> case xs of

45+ [_:xs] -> Just xs

46+ _ -> Nothing

47+

48+extern length :: forall a. [a] -> Number

49+

50+extern indexOf :: forall a. [a] -> a -> Number

51+

52+extern lastIndexOf :: forall a. [a] -> a -> Number

53+

54+extern concat :: forall a. [a] -> [a] -> [a]

55+

56+extern join :: [String] -> String

57+

58+extern joinWith :: [String] -> String -> String

59+

60+extern push :: forall a. [a] -> a -> [a]

61+

62+extern reverse :: forall a. [a] -> [a]

63+

64+extern shift :: forall a. [a] -> [a]

65+

66+extern slice :: forall a. Number -> Number -> [a] -> [a]

67+

68+extern sort :: forall a. [a] -> [a]

69+

70+extern splice :: forall a. Number -> Number -> [a] -> [a] -> [a]

71+

72+-- Strings

73+

74+extern lengthS :: String -> Number

75+

76+extern charAt :: Number -> String -> String

77+

78+extern indexOfS :: String -> String -> Number

79+

80+extern lastIndexOfS :: String -> String -> Number

81+

82+extern localeCompare :: String -> String -> Number

83+

84+extern replace :: String -> String -> String -> String

85+

86+extern sliceS :: Number -> Number -> String -> String

87+

88+extern split :: String -> String -> [String]

89+

90+extern substr :: Number -> Number -> String -> String

91+

92+extern substring :: Number -> Number -> String -> String

93+

94+extern toLower :: String -> String

95+

96+extern toUpper :: String -> String

97+

98+extern trim :: String -> String

99+

100+-- Regex

101+

102+extern data Regex :: *

103+

104+extern regex :: String -> String -> Regex

105+

106+extern test :: Regex -> String -> Boolean

107+

108+extern match :: Regex -> String -> [String]

109+

110+extern replaceR :: Regex -> String -> String -> String

111+

112+extern search :: Regex -> String -> Number

113+

114+-- Globals

115+

116+extern nan :: Number

117+

118+extern infinity :: Number

119+

120+extern toExponential :: Number -> String

121+

122+extern toFixed :: Number -> Number -> String

123+

124+extern toPrecision :: Number -> Number -> String

125+

126+extern numberToString :: Number -> String

127+

128+extern isNaN :: Number -> Boolean

129+

130+extern isFinite :: Number -> Boolean

131+

132+extern parseFloat :: String -> Number

133+

134+extern parseInt :: String -> Number

135+

136+extern encodeURIComponent :: String -> String

137+

138+extern decodeURIComponent :: String -> String

139+

140+extern encodeURI :: String -> String

141+

142+extern decodeURI :: String -> String

143+

144+-- Math

145+

146+type Math =

147+ { abs :: Number -> Number

148+ ; acos :: Number -> Number

149+ ; asin :: Number -> Number

150+ ; atan :: Number -> Number

151+ ; atan2 :: (Number, Number) -> Number

152+ ; aceil :: Number -> Number

153+ ; cos :: Number -> Number

154+ ; exp :: Number -> Number

155+ ; floor :: Number -> Number

156+ ; log :: Number -> Number

157+ ; max :: (Number, Number) -> Number

158+ ; pow :: (Number, Number) -> Number

159+ ; random :: () -> Number

160+ ; round :: Number -> Number

161+ ; sin :: Number -> Number

162+ ; sqrt :: Number -> Number

163+ ; tan :: Number -> Number

164+ }

165+

166+extern math :: Math

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+231

@@ -0,0 +1,231 @@

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 (ObjectUpdate o ps) = Just $ "Object.extend("

53+ ++ valueToJs o ++ ", { "

54+ ++ intercalate ", " (map objectPropertyToJs ps) ++ " }"

55+ match (Constructor name) = Just name

56+ match (Block sts) = Just $ "(function () {" ++ intercalate ";" (map statementToJs sts) ++ "})()"

57+ match (Case value binders) = Just $ "(" ++ runGen (bindersToJs binders) ++ ")(" ++ valueToJs value ++ ")"

58+ where

59+ bindersToJs :: [(Binder, Value)] -> Gen String

60+ bindersToJs binders = do

61+ valName <- fresh

62+ jss <- flip mapM binders $ \(binder, result) -> do

63+ let js = valueToJs result

64+ binderToJs valName ("return " ++ js ++ ";") binder

65+ return $ "function (" ++ valName ++ ") {" ++ concat jss ++ "throw \"Failed pattern match\"; }"

66+ match (Var ident) = Just (identToJs ident)

67+ match _ = Nothing

68+

69+ifThenElse :: Pattern Value ((Value, Value), Value)

70+ifThenElse = Pattern $ A.Kleisli match

71+ where

72+ match (IfThenElse cond th el) = Just ((th, el), cond)

73+ match _ = Nothing

74+

75+accessor :: Pattern Value (String, Value)

76+accessor = Pattern $ A.Kleisli match

77+ where

78+ match (Accessor prop val) = Just (prop, val)

79+ match _ = Nothing

80+

81+indexer :: Pattern Value (String, Value)

82+indexer = Pattern $ A.Kleisli match

83+ where

84+ match (Indexer index val) = Just (valueToJs index, val)

85+ match _ = Nothing

86+

87+app :: Pattern Value (String, Value)

88+app = Pattern $ A.Kleisli match

89+ where

90+ match (App val args) = Just (intercalate "," (map valueToJs args), val)

91+ match _ = Nothing

92+

93+lam :: Pattern Value ([String], Value)

94+lam = Pattern $ A.Kleisli match

95+ where

96+ match (Abs args val) = Just (map identToJs args, val)

97+ match _ = Nothing

98+

99+unary :: UnaryOperator -> String -> Operator Value String

100+unary op str = Wrap pattern (++)

101+ where

102+ pattern :: Pattern Value (String, Value)

103+ pattern = Pattern $ A.Kleisli match

104+ where

105+ match (Unary op' val) | op' == op = Just (str, val)

106+ match _ = Nothing

107+

108+binary :: BinaryOperator -> String -> Operator Value String

109+binary op str = AssocR pattern (\v1 v2 -> v1 ++ " " ++ str ++ " " ++ v2)

110+ where

111+ pattern :: Pattern Value (Value, Value)

112+ pattern = Pattern $ A.Kleisli match

113+ where

114+ match (Binary op' v1 v2) | op' == op = Just (v1, v2)

115+ match _ = Nothing

116+

117+valueToJs :: Value -> String

118+valueToJs = fromMaybe (error "Incomplete pattern") . pattern matchValue

119+ where

120+ matchValue :: Pattern Value String

121+ matchValue = buildPrettyPrinter operators (literals <+> fmap parens matchValue)

122+ operators :: OperatorTable Value String

123+ operators =

124+ OperatorTable $ [ [ Wrap accessor $ \prop val -> val ++ "." ++ prop ]

125+ , [ Wrap indexer $ \index val -> val ++ "[" ++ index ++ "]" ]

126+ , [ Wrap app $ \args val -> val ++ "(" ++ args ++ ")" ]

127+ , [ Split lam $ \args val -> "function (" ++ intercalate "," args ++ ") { return " ++ valueToJs val ++ "; }" ]

128+ , [ Wrap ifThenElse $ \(th, el) cond -> cond ++ " ? " ++ valueToJs th ++ " : " ++ valueToJs el ]

129+ , [ binary LessThan "<" ]

130+ , [ binary LessThanOrEqualTo "<=" ]

131+ , [ binary GreaterThan ">" ]

132+ , [ binary GreaterThanOrEqualTo ">=" ]

133+ , [ unary Not "!" ]

134+ , [ unary BitwiseNot "~" ]

135+ , [ unary Negate "-" ]

136+ , [ binary Multiply "*" ]

137+ , [ binary Divide "/" ]

138+ , [ binary Modulus "%" ]

139+ , [ binary Concat "+" ]

140+ , [ binary Add "+" ]

141+ , [ binary Subtract "-" ]

142+ , [ binary ShiftLeft "<<" ]

143+ , [ binary ShiftRight ">>" ]

144+ , [ binary ZeroFillShiftRight ">>>" ]

145+ , [ binary EqualTo "===" ]

146+ , [ binary NotEqualTo "!==" ]

147+ , [ binary BitwiseAnd "&" ]

148+ , [ binary BitwiseXor "^" ]

149+ , [ binary BitwiseOr "|" ]

150+ , [ binary And "&&" ]

151+ , [ binary Or "||" ]

152+ ]

153+

154+binderToJs :: String -> String -> Binder -> Gen String

155+binderToJs varName done NullBinder = return done

156+binderToJs varName done (StringBinder str) =

157+ return $ "if (" ++ varName ++ " === \"" ++ str ++ "\") {" ++ done ++ " }"

158+binderToJs varName done (NumberBinder num) =

159+ return $ "if (" ++ varName ++ " === " ++ either show show num ++ ") {" ++ done ++ " }"

160+binderToJs varName done (BooleanBinder True) =

161+ return $ "if (" ++ varName ++ ") {" ++ done ++ " }"

162+binderToJs varName done (BooleanBinder False) =

163+ return $ "if (!" ++ varName ++ ") {" ++ done ++ " }"

164+binderToJs varName done (VarBinder ident) =

165+ return $ "var " ++ identToJs ident ++ " = " ++ varName ++ "; " ++ done

166+binderToJs varName done (NullaryBinder ctor) =

167+ return $ "if (" ++ varName ++ ".ctor === \"" ++ ctor ++ "\") { " ++ done ++ " }"

168+binderToJs varName done (UnaryBinder ctor b) = do

169+ value <- fresh

170+ js <- binderToJs value done b

171+ return $ "if (" ++ varName ++ ".ctor === \"" ++ ctor ++ "\") { " ++ "var " ++ value ++ " = " ++ varName ++ ".value; " ++ js ++ " }"

172+binderToJs varName done (ObjectBinder bs) = go done bs

173+ where

174+ go done [] = return done

175+ go done ((prop, binder):bs) = do

176+ propVar <- fresh

177+ done' <- go done bs

178+ js <- binderToJs propVar done' binder

179+ return $ "var " ++ propVar ++ " = " ++ varName ++ "." ++ prop ++ ";" ++ js

180+binderToJs varName done (ArrayBinder bs rest) = do

181+ js <- go done rest 0 bs

182+ return $ "if (" ++ varName ++ ".length " ++ cmp ++ " " ++ show (length bs) ++ ") { " ++ js ++ " }"

183+ where

184+ cmp = maybe "===" (const ">=") rest

185+ go done Nothing _ [] = return done

186+ go done (Just binder) index [] = do

187+ restVar <- fresh

188+ js <- binderToJs restVar done binder

189+ return $ "var " ++ restVar ++ " = " ++ varName ++ ".slice(" ++ show index ++ "); " ++ js

190+ go done rest index (binder:bs) = do

191+ elVar <- fresh

192+ done' <- go done rest (index + 1) bs

193+ js <- binderToJs elVar done' binder

194+ return $ "var " ++ elVar ++ " = " ++ varName ++ "[" ++ show index ++ "]; " ++ js

195+binderToJs varName done (NamedBinder ident binder) = do

196+ js <- binderToJs varName done binder

197+ return $ "var " ++ identToJs ident ++ " = " ++ varName ++ "; " ++ js

198+binderToJs varName done (GuardedBinder cond binder) = binderToJs varName done' binder

199+ where

200+ done' = "if (" ++ valueToJs cond ++ ") { " ++ done ++ "}"

201+

202+objectPropertyToJs :: (String, Value) -> String

203+objectPropertyToJs (key, value) = key ++ ": " ++ valueToJs value

204+

205+statementToJs :: Statement -> String

206+statementToJs (VariableIntroduction ident value) = "var " ++ identToJs ident ++ " = " ++ valueToJs value

207+statementToJs (Assignment target value) = identToJs target ++ " = " ++ valueToJs value

208+statementToJs (While cond sts) = "while ("

209+ ++ valueToJs cond ++ ") {"

210+ ++ intercalate ";" (map statementToJs sts) ++ "}"

211+statementToJs (For ident start end sts) = "for (" ++

212+ identToJs ident ++ " = " ++ valueToJs start ++ ";"

213+ ++ identToJs ident ++ " < " ++ valueToJs end ++ ";"

214+ ++ identToJs ident ++ "++) {"

215+ ++ intercalate ";" (map statementToJs sts) ++ "}"

216+statementToJs (ForEach ident arr sts) = valueToJs arr

217+ ++ ".forEach(function(" ++ identToJs ident ++ ") {"

218+ ++ intercalate ";" (map statementToJs sts) ++ "})"

219+statementToJs (If ifst) = ifStatementToJs ifst

220+statementToJs (Return value) = "return " ++ valueToJs value

221+

222+ifStatementToJs :: IfStatement -> String

223+ifStatementToJs (IfStatement cond thens elst) =

224+ "if ("

225+ ++ valueToJs cond ++ ") {"

226+ ++ intercalate ";" (map statementToJs thens) ++ "}"

227+ ++ maybe "" elseStatementToJs elst

228+

229+elseStatementToJs :: ElseStatement -> String

230+elseStatementToJs (Else sts) = " else {" ++ intercalate ";" (map statementToJs sts) ++ "}"

231+elseStatementToJs (ElseIf ifst) = " else " ++ ifStatementToJs ifst

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+95

@@ -0,0 +1,95 @@

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 :: [(String, Type)] -> Row -> ([(String, Type)], Row)

59+ toList tys (RCons name ty row) = toList ((name, ty):tys) row

60+ toList tys r = (tys, r)

61+

62+typeApp :: Pattern Type (Type, Type)

63+typeApp = Pattern $ A.Kleisli match

64+ where

65+ match (TypeApp f x) = Just (f, x)

66+ match _ = Nothing

67+

68+singleArgumentFunction :: Pattern Type (Type, Type)

69+singleArgumentFunction = Pattern $ A.Kleisli match

70+ where

71+ match (Function [arg] ret) = Just (arg, ret)

72+ match _ = Nothing

73+

74+function :: Pattern Type ([Type], Type)

75+function = Pattern $ A.Kleisli match

76+ where

77+ match (Function args ret) = Just (args, ret)

78+ match _ = Nothing

79+

80+prettyPrintType :: Type -> String

81+prettyPrintType = fromMaybe (error "Incomplete pattern") . pattern matchType

82+ where

83+ matchType :: Pattern Type String

84+ matchType = buildPrettyPrinter operators (typeLiterals <+> fmap parens matchType)

85+ operators :: OperatorTable Type String

86+ operators =

87+ OperatorTable $ [ [ AssocL typeApp $ \f x -> f ++ " " ++ x ]

88+ , [ AssocR singleArgumentFunction $ \arg ret -> arg ++ " -> " ++ ret

89+ , Wrap function $ \args ret -> "(" ++ intercalate ", " (map prettyPrintType args) ++ ") -> " ++ ret

90+ ]

91+ ]

92+

93+prettyPrintPolyType :: PolyType -> String

94+prettyPrintPolyType (PolyType [] ty) = prettyPrintType ty

95+prettyPrintPolyType (PolyType idents ty) = "forall " ++ intercalate " " idents ++ ". " ++ prettyPrintType ty

src/PureScript/CodeGen/Pretty/Values.hsnew file+185

@@ -0,0 +1,185 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : PureScript.CodeGen.Pretty.Values

4+-- Copyright : Kinds.hs(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.Values (

16+ prettyPrintValue,

17+ prettyPrintBinder

18+) where

19+

20+import Data.Char

21+import Data.Maybe (fromMaybe)

22+import Data.List (intercalate)

23+import qualified Control.Arrow as A

24+import Control.Arrow ((<+>))

25+import Control.Applicative

26+

27+import PureScript.Types

28+import PureScript.Values

29+import PureScript.Names

30+import PureScript.CodeGen.Common

31+

32+literals :: Pattern Value String

33+literals = Pattern $ A.Kleisli match

34+ where

35+ match (NumericLiteral n) = Just $ either show show n

36+ match (StringLiteral s) = Just $ show s

37+ match (BooleanLiteral True) = Just "true"

38+ match (BooleanLiteral False) = Just "false"

39+ match (ArrayLiteral xs) = Just $ "[" ++ intercalate ", " (map prettyPrintValue xs) ++ "]"

40+ match (ObjectLiteral ps) = Just $ "{" ++ intercalate ", " (map (uncurry prettyPrintObjectProperty) ps) ++ "}"

41+ match (Constructor name) = Just name

42+ match (Block sts) = Just $ "do { " ++ intercalate " ; " (map prettyPrintStatement sts) ++ " }"

43+ match (Case value binders) = Just $ "case " ++ prettyPrintValue value ++ " of { " ++ intercalate " ; " (map (uncurry prettyPrintCaseAlternative) binders) ++ " }"

44+ match (Var ident) = Just $ show ident

45+ match _ = Nothing

46+

47+prettyPrintCaseAlternative :: Binder -> Value -> String

48+prettyPrintCaseAlternative binder val = prettyPrintBinder binder ++ " -> " ++ prettyPrintValue val

49+

50+ifThenElse :: Pattern Value ((Value, Value), Value)

51+ifThenElse = Pattern $ A.Kleisli match

52+ where

53+ match (IfThenElse cond th el) = Just ((th, el), cond)

54+ match _ = Nothing

55+

56+accessor :: Pattern Value (String, Value)

57+accessor = Pattern $ A.Kleisli match

58+ where

59+ match (Accessor prop val) = Just (prop, val)

60+ match _ = Nothing

61+

62+indexer :: Pattern Value (String, Value)

63+indexer = Pattern $ A.Kleisli match

64+ where

65+ match (Indexer index val) = Just (prettyPrintValue index, val)

66+ match _ = Nothing

67+

68+objectUpdate :: Pattern Value ([String], Value)

69+objectUpdate = Pattern $ A.Kleisli match

70+ where

71+ match (ObjectUpdate o ps) = Just (flip map ps $ \(key, val) -> key ++ " = " ++ prettyPrintValue val, o)

72+ match _ = Nothing

73+

74+app :: Pattern Value (String, Value)

75+app = Pattern $ A.Kleisli match

76+ where

77+ match (App val args) = Just (intercalate "," (map prettyPrintValue args), val)

78+ match _ = Nothing

79+

80+lam :: Pattern Value ([String], Value)

81+lam = Pattern $ A.Kleisli match

82+ where

83+ match (Abs args val) = Just (map show args, val)

84+ match _ = Nothing

85+

86+unary :: UnaryOperator -> String -> Operator Value String

87+unary op str = Wrap pattern (++)

88+ where

89+ pattern :: Pattern Value (String, Value)

90+ pattern = Pattern $ A.Kleisli match

91+ where

92+ match (Unary op' val) | op' == op = Just (str, val)

93+ match _ = Nothing

94+

95+binary :: BinaryOperator -> String -> Operator Value String

96+binary op str = AssocR pattern (\v1 v2 -> v1 ++ " " ++ str ++ " " ++ v2)

97+ where

98+ pattern :: Pattern Value (Value, Value)

99+ pattern = Pattern $ A.Kleisli match

100+ where

101+ match (Binary op' v1 v2) | op' == op = Just (v1, v2)

102+ match _ = Nothing

103+

104+prettyPrintValue :: Value -> String

105+prettyPrintValue = fromMaybe (error "Incomplete pattern") . pattern matchValue

106+ where

107+ matchValue :: Pattern Value String

108+ matchValue = buildPrettyPrinter operators (literals <+> fmap parens matchValue)

109+ operators :: OperatorTable Value String

110+ operators =

111+ OperatorTable $ [ [ Wrap accessor $ \prop val -> val ++ "." ++ prop ]

112+ , [ Wrap indexer $ \index val -> val ++ "[" ++ index ++ "]" ]

113+ , [ Wrap objectUpdate $ \ps val -> val ++ "{ " ++ intercalate ", " ps ++ " }" ]

114+ , [ Wrap app $ \args val -> val ++ "(" ++ args ++ ")" ]

115+ , [ Split lam $ \args val -> "function (" ++ intercalate "," args ++ ") { return " ++ prettyPrintValue val ++ "; }" ]

116+ , [ Wrap ifThenElse $ \(th, el) cond -> cond ++ " ? " ++ prettyPrintValue th ++ " : " ++ prettyPrintValue el ]

117+ , [ binary LessThan "<" ]

118+ , [ binary LessThanOrEqualTo "<=" ]

119+ , [ binary GreaterThan ">" ]

120+ , [ binary GreaterThanOrEqualTo ">=" ]

121+ , [ unary Not "!" ]

122+ , [ unary BitwiseNot "~" ]

123+ , [ unary Negate "-" ]

124+ , [ binary Multiply "*" ]

125+ , [ binary Divide "/" ]

126+ , [ binary Modulus "%" ]

127+ , [ binary Concat "++" ]

128+ , [ binary Add "+" ]

129+ , [ binary Subtract "-" ]

130+ , [ binary ShiftLeft "<<" ]

131+ , [ binary ShiftRight ">>" ]

132+ , [ binary ZeroFillShiftRight ">>>" ]

133+ , [ binary EqualTo "==" ]

134+ , [ binary NotEqualTo "!=" ]

135+ , [ binary BitwiseAnd "&" ]

136+ , [ binary BitwiseXor "^" ]

137+ , [ binary BitwiseOr "|" ]

138+ , [ binary And "&&" ]

139+ , [ binary Or "||" ]

140+ ]

141+

142+prettyPrintBinder :: Binder -> String

143+prettyPrintBinder NullBinder = "_"

144+prettyPrintBinder (StringBinder str) = show str

145+prettyPrintBinder (NumberBinder num) = either show show num

146+prettyPrintBinder (BooleanBinder True) = "true"

147+prettyPrintBinder (BooleanBinder False) = "false"

148+prettyPrintBinder (VarBinder ident) = show ident

149+prettyPrintBinder (NullaryBinder ctor) = ctor

150+prettyPrintBinder (UnaryBinder ctor b) = ctor ++ prettyPrintBinder b

151+prettyPrintBinder (ObjectBinder bs) = "{ " ++ intercalate ", " (map (uncurry prettyPrintObjectPropertyBinder) bs) ++ " }"

152+prettyPrintBinder (ArrayBinder bs rest) = "[ " ++ intercalate ", " (map prettyPrintBinder bs) ++ maybe "" (("; " ++) . prettyPrintBinder) rest ++ " ]"

153+prettyPrintBinder (NamedBinder ident binder) = show ident ++ "@" ++ prettyPrintBinder binder

154+prettyPrintBinder (GuardedBinder cond binder) = prettyPrintBinder binder ++ " | " ++ prettyPrintValue cond

155+

156+prettyPrintObjectPropertyBinder :: String -> Binder -> String

157+prettyPrintObjectPropertyBinder key binder = key ++ ": " ++ prettyPrintBinder binder

158+

159+prettyPrintObjectProperty :: String -> Value -> String

160+prettyPrintObjectProperty key value = key ++ ": " ++ prettyPrintValue value

161+

162+prettyPrintStatement :: Statement -> String

163+prettyPrintStatement (VariableIntroduction ident value) = "var " ++ show ident ++ " = " ++ prettyPrintValue value

164+prettyPrintStatement (Assignment target value) = show target ++ " = " ++ prettyPrintValue value

165+prettyPrintStatement (While cond sts) = "while " ++ prettyPrintValue cond ++ ": {" ++ intercalate ";" (map prettyPrintStatement sts) ++ " }"

166+prettyPrintStatement (For ident start end sts) = "for " ++ show ident

167+ ++ " <- " ++ prettyPrintValue start

168+ ++ " until " ++ prettyPrintValue end ++ ": {"

169+ ++ intercalate "; " (map prettyPrintStatement sts) ++ " }"

170+prettyPrintStatement (ForEach ident arr sts) = "foreach " ++ show ident

171+ ++ " in " ++ prettyPrintValue arr ++ ": {"

172+ ++ intercalate "; " (map prettyPrintStatement sts) ++ " }"

173+prettyPrintStatement (If ifst) = prettyPrintIfStatement ifst

174+prettyPrintStatement (Return value) = "return " ++ prettyPrintValue value

175+

176+prettyPrintIfStatement :: IfStatement -> String

177+prettyPrintIfStatement (IfStatement cond thens elst) =

178+ "if "

179+ ++ prettyPrintValue cond ++ ": {"

180+ ++ intercalate "; " (map prettyPrintStatement thens) ++ " }"

181+ ++ maybe "" prettyPrintElseStatement elst

182+

183+prettyPrintElseStatement :: ElseStatement -> String

184+prettyPrintElseStatement (Else sts) = "else: {" ++ intercalate "; " (map prettyPrintStatement sts) ++ " }"

185+prettyPrintElseStatement (ElseIf ifst) = "else " ++ prettyPrintIfStatement ifst

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+289

@@ -0,0 +1,289 @@

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+parsePropertyUpdate :: P.Parsec String ParseState (String, Value)

113+parsePropertyUpdate = do

114+ name <- C.lexeme C.identifier

115+ C.lexeme $ C.indented *> P.char '='

116+ value <- C.indented *> parseValue

117+ return (name, value)

118+

119+parseValue :: P.Parsec String ParseState Value

120+parseValue = do

121+ customOps <- fixities <$> P.getState

122+ (buildExpressionParser (operators customOps)

123+ . C.buildPostfixParser postfixTable2

124+ $ indexersAndAccessors) P.<?> "expression"

125+ where

126+ indexersAndAccessors = C.buildPostfixParser postfixTable1 $ parseValueAtom

127+ postfixTable1 = [ Accessor <$> (C.indented *> C.dot *> C.indented *> C.identifier)

128+ , Indexer <$> (C.indented *> C.squares parseValue)

129+ , flip ObjectUpdate <$> (C.indented *> C.braces ((C.indented *> parsePropertyUpdate) `P.sepBy1` (C.indented *> C.comma))) ]

130+ postfixTable2 = [ C.indented *> indexersAndAccessors >>= \t2 -> return (\t1 -> App t1 [t2])

131+ , flip App <$> (C.indented *> C.parens (parseValue `P.sepBy` (C.indented *> C.comma)))

132+ , flip TypedValue <$> (P.try $ C.lexeme (C.indented *> P.string "::") *> parsePolyType) ]

133+ operators user =

134+ [ [ Prefix $ C.lexeme (P.try $ C.indented *> C.reservedOp "!") >> return (Unary Not)

135+ , Prefix $ C.lexeme (P.try $ C.indented *> C.reservedOp "~") >> return (Unary BitwiseNot)

136+ , Prefix $ C.lexeme (P.try $ C.indented *> C.reservedOp "-") >> return (Unary Negate)

137+ , Prefix $ C.lexeme (P.try $ C.indented *> C.reservedOp "+") >> return id ]

138+ ] ++ customOperatorTable user ++

139+ [ [ Infix (C.lexeme (P.try (C.indented *> C.parseIdentInfix P.<?> "operator") >>= \ident -> return $ \t1 t2 -> App (App (Var ident) [t1]) [t2])) AssocLeft ]

140+ , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "<=") >> return (Binary LessThanOrEqualTo)) AssocRight

141+ , Infix (C.lexeme (P.try $ C.indented *> C.reservedOp ">=") >> return (Binary GreaterThanOrEqualTo)) AssocRight ]

142+ , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "<") >> return (Binary LessThan)) AssocRight

143+ , Infix (C.lexeme (P.try $ C.indented *> C.reservedOp ">") >> return (Binary GreaterThan)) AssocRight ]

144+ , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "*") >> return (Binary Multiply)) AssocRight

145+ , Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "/") >> return (Binary Divide)) AssocRight

146+ , Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "%") >> return (Binary Modulus)) AssocRight ]

147+ , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "++") >> return (Binary Concat)) AssocRight

148+ , Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "+") >> return (Binary Add)) AssocRight

149+ , Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "-") >> return (Binary Subtract)) AssocRight ]

150+ , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "<<") >> return (Binary ShiftLeft)) AssocRight

151+ , Infix (C.lexeme (P.try $ C.indented *> C.reservedOp ">>>") >> return (Binary ZeroFillShiftRight)) AssocRight

152+ , Infix (C.lexeme (P.try $ C.indented *> C.reservedOp ">>") >> return (Binary ShiftRight)) AssocRight ]

153+ , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "==") >> return (Binary EqualTo)) AssocRight

154+ , Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "!=") >> return (Binary NotEqualTo)) AssocRight ]

155+ , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "&") >> return (Binary BitwiseAnd)) AssocRight ]

156+ , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "^") >> return (Binary BitwiseXor)) AssocRight ]

157+ , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "|") >> return (Binary BitwiseOr)) AssocRight ]

158+ , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "&&") >> return (Binary And)) AssocRight ]

159+ , [ Infix (C.lexeme (P.try $ C.indented *> C.reservedOp "||") >> return (Binary Or)) AssocRight ]

160+ ]

161+

162+customOperatorTable :: M.Map String Fixity -> OperatorTable String ParseState Identity Value

163+customOperatorTable fixities =

164+ let

165+ ops = map (\(name, Fixity a p) -> (name, (a, p))) . M.toList $ fixities

166+ sorted = sortBy (compare `on` (snd . snd)) ops

167+ levels = groupBy ((==) `on` (snd . snd)) sorted

168+ in

169+ flip map levels (map (\(name, (a, _)) -> flip Infix (toAssoc a) $ do

170+ C.lexeme $ P.try $ do

171+ C.indented

172+ C.reservedOp name P.<?> "operator"

173+ return $ \t1 t2 -> App (App (Var (Op name)) [t1]) [t2]))

174+

175+toAssoc :: Associativity -> Assoc

176+toAssoc Infixl = AssocLeft

177+toAssoc Infixr = AssocRight

178+

179+parseVariableIntroduction :: P.Parsec String ParseState Statement

180+parseVariableIntroduction = do

181+ C.reserved "var"

182+ name <- C.indented *> C.parseIdent

183+ C.lexeme $ C.indented *> P.char '='

184+ value <- parseValue

185+ return $ VariableIntroduction name value

186+

187+parseAssignment :: P.Parsec String ParseState Statement

188+parseAssignment = do

189+ tgt <- C.parseIdent

190+ C.lexeme $ C.indented *> P.char '='

191+ value <- parseValue

192+ return $ Assignment tgt value

193+

194+parseWhile :: P.Parsec String ParseState Statement

195+parseWhile = While <$> (C.reserved "while" *> C.indented *> parseValue <* C.indented <* C.colon)

196+ <*> parseManyStatements

197+

198+parseFor :: P.Parsec String ParseState Statement

199+parseFor = For <$> (C.reserved "for" *> C.indented *> C.parseIdent)

200+ <*> (C.indented *> C.lexeme (P.string "<-") *> parseValue)

201+ <*> (C.indented *> C.reserved "until" *> parseValue <* C.colon)

202+ <*> parseManyStatements

203+

204+parseForEach :: P.Parsec String ParseState Statement

205+parseForEach = ForEach <$> (C.reserved "foreach" *> C.indented *> C.parseIdent)

206+ <*> (C.indented *> C.reserved "in" *> parseValue <* C.colon)

207+ <*> parseManyStatements

208+

209+parseIf :: P.Parsec String ParseState Statement

210+parseIf = If <$> parseIfStatement

211+

212+parseIfStatement :: P.Parsec String ParseState IfStatement

213+parseIfStatement =

214+ IfStatement <$> (C.reserved "if" *> C.indented *> parseValue <* C.indented <* C.colon)

215+ <*> parseManyStatements

216+ <*> P.optionMaybe (C.same *> parseElseStatement)

217+

218+parseElseStatement :: P.Parsec String ParseState ElseStatement

219+parseElseStatement = C.reserved "else" >> (ElseIf <$> (C.indented *> parseIfStatement)

220+ <|> Else <$> (C.indented *> C.colon *> parseManyStatements))

221+

222+parseReturn :: P.Parsec String ParseState Statement

223+parseReturn = Return <$> (C.reserved "return" *> parseValue)

224+

225+parseStatement :: P.Parsec String ParseState Statement

226+parseStatement = P.choice (map P.try

227+ [ parseVariableIntroduction

228+ , parseAssignment

229+ , parseWhile

230+ , parseFor

231+ , parseForEach

232+ , parseIf

233+ , parseReturn ]) P.<?> "statement"

234+

235+parseStringBinder :: P.Parsec String ParseState Binder

236+parseStringBinder = StringBinder <$> C.stringLiteral

237+

238+parseBooleanBinder :: P.Parsec String ParseState Binder

239+parseBooleanBinder = BooleanBinder <$> booleanLiteral

240+

241+parseNumberBinder :: P.Parsec String ParseState Binder

242+parseNumberBinder = NumberBinder <$> C.integerOrFloat

243+

244+parseVarBinder :: P.Parsec String ParseState Binder

245+parseVarBinder = VarBinder <$> C.parseIdent

246+

247+parseNullaryBinder :: P.Parsec String ParseState Binder

248+parseNullaryBinder = NullaryBinder <$> C.lexeme C.properName

249+

250+parseUnaryBinder :: P.Parsec String ParseState Binder

251+parseUnaryBinder = UnaryBinder <$> C.lexeme C.properName <*> (C.indented *> parseBinder)

252+

253+parseObjectBinder :: P.Parsec String ParseState Binder

254+parseObjectBinder = ObjectBinder <$> C.braces ((C.indented *> parseIdentifierAndBinder) `P.sepBy` (C.indented *> C.comma))

255+

256+parseArrayBinder :: P.Parsec String ParseState Binder

257+parseArrayBinder = C.squares $ ArrayBinder <$> ((C.indented *> parseBinder) `P.sepBy` (C.indented *> C.comma))

258+ <*> P.optionMaybe (C.indented *> C.colon *> C.indented *> parseBinder)

259+

260+parseNamedBinder :: P.Parsec String ParseState Binder

261+parseNamedBinder = NamedBinder <$> (C.parseIdent <* C.indented <* C.lexeme (P.char '@'))

262+ <*> (C.indented *> parseBinder)

263+

264+parseNullBinder :: P.Parsec String ParseState Binder

265+parseNullBinder = C.lexeme (P.char '_') *> P.notFollowedBy C.identLetter *> return NullBinder

266+

267+parseIdentifierAndBinder :: P.Parsec String ParseState (String, Binder)

268+parseIdentifierAndBinder = do

269+ name <- C.lexeme C.identifier

270+ C.lexeme $ C.indented *> P.char '='

271+ binder <- C.indented *> parseBinder

272+ return (name, binder)

273+

274+parseBinder :: P.Parsec String ParseState Binder

275+parseBinder = P.choice (map P.try

276+ [ parseNullBinder

277+ , parseStringBinder

278+ , parseBooleanBinder

279+ , parseNumberBinder

280+ , parseNamedBinder

281+ , parseVarBinder

282+ , parseUnaryBinder

283+ , parseNullaryBinder

284+ , parseObjectBinder

285+ , parseArrayBinder

286+ , C.parens parseBinder ]) P.<?> "binder"

287+

288+parseGuardedBinder :: P.Parsec String ParseState Binder

289+parseGuardedBinder = flip ($) <$> parseBinder <*> P.option id (GuardedBinder <$> (C.indented *> C.lexeme (P.char '|') *> C.indented *> parseValue))

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+184

@@ -0,0 +1,184 @@

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+{-# LANGUAGE DeriveDataTypeable #-}

16+

17+module PureScript.TypeChecker.Kinds (

18+ KindConstraint(..),

19+ KindSolution(..),

20+ kindsOf,

21+ kindOf

22+) where

23+

24+import Data.List

25+import Data.Maybe (fromMaybe)

26+import Data.Function

27+import Data.Data

28+

29+import PureScript.Types

30+import PureScript.Kinds

31+import PureScript.Declarations

32+import PureScript.TypeChecker.Monad

33+import PureScript.CodeGen.Pretty.Kinds

34+import PureScript.CodeGen.Pretty.Types

35+

36+import Control.Monad.State

37+import Control.Monad.Error

38+

39+import Control.Applicative

40+import Control.Arrow (Kleisli(..), (***))

41+import qualified Control.Category as C

42+

43+import qualified Data.Map as M

44+

45+data KindConstraintOrigin

46+ = DataDeclOrigin

47+ | TypeOrigin Type

48+ | RowOrigin Row deriving (Show, Data, Typeable)

49+

50+prettyPrintKindConstraintOrigin :: KindConstraintOrigin -> String

51+prettyPrintKindConstraintOrigin (DataDeclOrigin) = "data declaration"

52+prettyPrintKindConstraintOrigin (TypeOrigin ty) = prettyPrintType ty

53+prettyPrintKindConstraintOrigin (RowOrigin row) = prettyPrintRow row

54+

55+data KindConstraint = KindConstraint Int Kind KindConstraintOrigin deriving (Show, Data, Typeable)

56+

57+newtype KindSolution = KindSolution { runKindSolution :: Int -> Kind }

58+

59+emptyKindSolution :: KindSolution

60+emptyKindSolution = KindSolution KUnknown

61+

62+kindOf :: PolyType -> Check Kind

63+kindOf (PolyType idents ty) = do

64+ ns <- replicateM (length idents) fresh

65+ (cs, n, m) <- kindConstraints (M.fromList (zip idents ns)) ty

66+ solution <- solveKindConstraints cs emptyKindSolution

67+ return $ starIfUnknown $ runKindSolution solution n

68+

69+kindsOf :: Maybe String -> [String] -> [Type] -> Check Kind

70+kindsOf name args ts = do

71+ tyCon <- fresh

72+ nargs <- replicateM (length args) fresh

73+ (cs, ns, m) <- kindConstraintsAll (maybe id (flip M.insert tyCon) name $ M.fromList (zipWith (,) args nargs)) ts

74+ let extraConstraints =

75+ KindConstraint tyCon (foldr FunKind Star (map KUnknown nargs)) DataDeclOrigin

76+ : zipWith (\n arg -> KindConstraint n Star (TypeOrigin arg)) ns ts

77+ solution <- solveKindConstraints (extraConstraints ++ cs) emptyKindSolution

78+ return $ starIfUnknown $ runKindSolution solution tyCon

79+

80+starIfUnknown :: Kind -> Kind

81+starIfUnknown (KUnknown _) = Star

82+starIfUnknown (FunKind k1 k2) = FunKind (starIfUnknown k1) (starIfUnknown k2)

83+starIfUnknown k = k

84+

85+kindConstraintsAll :: M.Map String Int -> [Type] -> Check ([KindConstraint], [Int], M.Map String Int)

86+kindConstraintsAll m [] = return ([], [], m)

87+kindConstraintsAll m (t:ts) = do

88+ (cs, n1, m') <- kindConstraints m t

89+ (cs', ns, m'') <- kindConstraintsAll m' ts

90+ return ((KindConstraint n1 Star (TypeOrigin t)) : cs ++ cs', n1:ns, m'')

91+

92+kindConstraints :: M.Map String Int -> Type -> Check ([KindConstraint], Int, M.Map String Int)

93+kindConstraints m a@(Array t) = do

94+ me <- fresh

95+ (cs, n1, m') <- kindConstraints m t

96+ return ((KindConstraint n1 Star (TypeOrigin t)) : (KindConstraint me Star (TypeOrigin a)) : cs, me, m')

97+kindConstraints m o@(Object row) = do

98+ me <- fresh

99+ (cs, r, m') <- kindConstraintsForRow m row

100+ return ((KindConstraint me Star (TypeOrigin o)) : (KindConstraint r Row (RowOrigin row)) : cs, me, m')

101+kindConstraints m f@(Function args ret) = do

102+ me <- fresh

103+ (cs, ns, m') <- kindConstraintsAll m args

104+ (cs', retN, m'') <- kindConstraints m' ret

105+ return ((KindConstraint retN Star (TypeOrigin ret)) : (KindConstraint me Star (TypeOrigin f)) : (zipWith (\n arg -> KindConstraint n Star (TypeOrigin arg)) ns args) ++ cs ++ cs', me, m'')

106+kindConstraints m (TypeVar v) = do

107+ case M.lookup v m of

108+ Just u -> return ([], u, m)

109+ Nothing -> throwError $ "Unbound type variable " ++ v

110+kindConstraints m c@(TypeConstructor v) = do

111+ env <- getEnv

112+ me <- fresh

113+ case M.lookup v m of

114+ Nothing -> case M.lookup v (types env) of

115+ Nothing -> throwError $ "Unknown type constructor '" ++ v ++ "'"

116+ Just (kind, _) -> return ([KindConstraint me kind (TypeOrigin c)], me, m)

117+ Just u -> do

118+ return ([KindConstraint me (KUnknown u) (TypeOrigin c)], me, m)

119+kindConstraints m a@(TypeApp t1 t2) = do

120+ me <- fresh

121+ (cs1, n1, m1) <- kindConstraints m t1

122+ (cs2, n2, m2) <- kindConstraints m1 t2

123+ return ((KindConstraint n1 (FunKind (KUnknown n2) (KUnknown me)) (TypeOrigin a)) : cs1 ++ cs2, me, m2)

124+kindConstraints m t = do

125+ me <- fresh

126+ return ([KindConstraint me Star (TypeOrigin t)], me, m)

127+

128+kindConstraintsForRow :: M.Map String Int -> Row -> Check ([KindConstraint], Int, M.Map String Int)

129+kindConstraintsForRow m r@(RowVar v) = do

130+ me <- case M.lookup v m of

131+ Just u -> return u

132+ Nothing -> fresh

133+ return ([KindConstraint me Row (RowOrigin r)], me, M.insert v me m)

134+kindConstraintsForRow m r@REmpty = do

135+ me <- fresh

136+ return ([KindConstraint me Row (RowOrigin r)], me, m)

137+kindConstraintsForRow m r@(RCons _ ty row) = do

138+ me <- fresh

139+ (cs1, n1, m1) <- kindConstraints m ty

140+ (cs2, n2, m2) <- kindConstraintsForRow m1 row

141+ return ((KindConstraint me Row (RowOrigin r)) : (KindConstraint n1 Star (TypeOrigin ty)) : (KindConstraint n2 Row (RowOrigin r)) : cs1 ++ cs2, me, m2)

142+

143+solveKindConstraints :: [KindConstraint] -> KindSolution -> Check KindSolution

144+solveKindConstraints [] s = return s

145+solveKindConstraints all@(KindConstraint n k t : cs) s = do

146+ (cs', s') <- rethrow (\err -> "Error in " ++ prettyPrintKindConstraintOrigin t ++ ": " ++ err) $ do

147+ guardWith "Occurs check failed" $ not $ kindOccursCheck False n k

148+ let s' = KindSolution $ replaceUnknownKind n k . runKindSolution s

149+ cs' <- fmap concat $ mapM (substituteKindConstraint n k) cs

150+ return (cs', s')

151+ solveKindConstraints cs' s'

152+

153+substituteKindConstraint :: Int -> Kind -> KindConstraint -> Check [KindConstraint]

154+substituteKindConstraint n k (KindConstraint m l t)

155+ | n == m = unifyKinds t k l

156+ | otherwise = return [KindConstraint m (replaceUnknownKind n k l) t]

157+

158+replaceUnknownKind :: Int -> Kind -> Kind -> Kind

159+replaceUnknownKind n k = f

160+ where

161+ f (KUnknown m) | m == n = k

162+ f (FunKind k1 k2) = FunKind (f k2) (f k2)

163+ f other = other

164+

165+unifyKinds :: KindConstraintOrigin -> Kind -> Kind -> Check [KindConstraint]

166+unifyKinds _ (KUnknown u1) (KUnknown u2) | u1 == u2 = return []

167+unifyKinds t (KUnknown u) k = do

168+ guardWith "Occurs check failed" $ not $ kindOccursCheck False u k

169+ return [KindConstraint u k t]

170+unifyKinds t k (KUnknown u) = do

171+ guardWith "Occurs check failed" $ not $ kindOccursCheck False u k

172+ return [KindConstraint u k t]

173+unifyKinds _ Star Star = return []

174+unifyKinds _ Row Row = return []

175+unifyKinds t (FunKind k1 k2) (FunKind k3 k4) = do

176+ cs1 <- unifyKinds t k1 k3

177+ cs2 <- unifyKinds t k2 k4

178+ return $ cs1 ++ cs2

179+unifyKinds _ k1 k2 = throwError $ "Cannot unify " ++ prettyPrintKind k1 ++ " with " ++ prettyPrintKind k2 ++ "."

180+

181+kindOccursCheck :: Bool -> Int -> Kind -> Bool

182+kindOccursCheck b u (KUnknown u') | u == u' = b

183+kindOccursCheck _ u (FunKind k1 k2) = kindOccursCheck True u k1 || kindOccursCheck True u k2

184+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+626

@@ -0,0 +1,626 @@

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 Debug.Trace

24+

25+import Data.List

26+import Data.Function

27+import qualified Data.Data as D

28+import Data.Generics (everywhere, everywhereM, everything, mkT, mkM, mkQ, extM, extQ)

29+

30+import PureScript.Values

31+import PureScript.Types

32+import PureScript.Kinds

33+import PureScript.Names

34+import PureScript.TypeChecker.Monad

35+import PureScript.TypeChecker.Kinds

36+import PureScript.TypeChecker.Synonyms

37+import PureScript.CodeGen.Pretty.Types

38+import PureScript.CodeGen.Pretty.Kinds

39+import PureScript.CodeGen.Pretty.Values

40+

41+import Control.Monad.State

42+import Control.Monad.Error

43+

44+import Control.Applicative

45+import Control.Arrow (Kleisli(..), (***), (&&&))

46+import qualified Control.Category as C

47+

48+import qualified Data.Map as M

49+

50+data TypeConstraintOrigin

51+ = ValueOrigin Value

52+ | BinderOrigin Binder

53+ | AssignmentTargetOrigin Ident deriving (Show, D.Data, D.Typeable)

54+

55+prettyPrintOrigin :: TypeConstraintOrigin -> String

56+prettyPrintOrigin (ValueOrigin val) = prettyPrintValue val

57+prettyPrintOrigin (BinderOrigin binder) = prettyPrintBinder binder

58+prettyPrintOrigin (AssignmentTargetOrigin ident) = show ident

59+

60+data TypeConstraint

61+ = TypeConstraint Int Type TypeConstraintOrigin

62+ | RowConstraint Int Row TypeConstraintOrigin deriving (Show, D.Data, D.Typeable)

63+

64+newtype TypeSolution = TypeSolution { runTypeSolution :: (Int -> Type, Int -> Row) }

65+

66+emptyTypeSolution :: TypeSolution

67+emptyTypeSolution = TypeSolution (TUnknown, RUnknown)

68+

69+isFunction :: Value -> Bool

70+isFunction (Abs _ _) = True

71+isFunction (TypedValue untyped _) = isFunction untyped

72+isFunction _ = False

73+

74+allConstraints :: Ident -> Value -> Check ([TypeConstraint], Int)

75+allConstraints name val | isFunction val = do

76+ me <- fresh

77+ (cs, n) <- typeConstraints (M.singleton name me) val

78+ return (TypeConstraint me (TUnknown n) (ValueOrigin val): cs, n)

79+allConstraints _ val = typeConstraints M.empty val

80+

81+typeOf :: Ident -> Value -> Check PolyType

82+typeOf name val = do

83+ (cs, n) <- allConstraints name val

84+ desugared <- replaceAllTypeSynonyms cs

85+ solution <- solveTypeConstraints desugared emptyTypeSolution

86+ let ty = fst (runTypeSolution solution) n

87+ allUnknownsBecameQuantified desugared solution ty

88+ return $ varIfUnknown $ desaturateAllTypeSynonyms $ setifyAll ty

89+

90+allUnknownsBecameQuantified :: [TypeConstraint] -> TypeSolution -> Type -> Check ()

91+allUnknownsBecameQuantified cs solution ty = do

92+ let

93+ typesMentioned = findUnknownTypes ty

94+ unknownTypes = nub $ flip concatMap cs $ \c -> case c of

95+ TypeConstraint u t _ -> u : findUnknownTypes t

96+ RowConstraint _ r _ -> findUnknownTypes r

97+ unsolvedTypes = filter (\n -> TUnknown n == fst (runTypeSolution solution) n) unknownTypes

98+ guardWith "Unsolved type variable" $ null $ unsolvedTypes \\ typesMentioned

99+ let

100+ rowsMentioned = findUnknownRows ty

101+ unknownRows = nub $ flip concatMap cs $ \c -> case c of

102+ TypeConstraint _ t _ -> findUnknownRows t

103+ RowConstraint u r _ -> u : findUnknownRows r

104+ unsolvedRows = filter (\n -> RUnknown n == snd (runTypeSolution solution) n) unknownRows

105+ guardWith "Unsolved row variable" $ null $ unsolvedRows \\ rowsMentioned

106+

107+setify :: Row -> Row

108+setify = rowFromList . (M.toList . M.fromList *** id) . rowToList

109+

110+setifyAll :: (D.Data d) => d -> d

111+setifyAll = everywhere (mkT setify)

112+

113+findUnknownTypes :: (D.Data d) => d -> [Int]

114+findUnknownTypes = everything (++) (mkQ [] f)

115+ where

116+ f :: Type -> [Int]

117+ f (TUnknown n) = [n]

118+ f _ = []

119+

120+findTypeVars :: (D.Data d) => d -> [String]

121+findTypeVars = everything (++) (mkQ [] f)

122+ where

123+ f :: Type -> [String]

124+ f (TypeVar v) = [v]

125+ f _ = []

126+

127+findUnknownRows :: (D.Data d) => d -> [Int]

128+findUnknownRows = everything (++) (mkQ [] f)

129+ where

130+ f :: Row -> [Int]

131+ f (RUnknown n) = [n]

132+ f _ = []

133+

134+varIfUnknown :: Type -> PolyType

135+varIfUnknown ty =

136+ let

137+ (ty', m) = flip runState M.empty $ everywhereM (flip extM g $ mkM f) ty

138+ in

139+ PolyType (sort $ nub $ M.elems m ++ findTypeVars ty) ty'

140+ where

141+ f :: Type -> State (M.Map Int String) Type

142+ f (TUnknown n) = do

143+ m <- get

144+ case M.lookup n m of

145+ Nothing -> do

146+ let name = "t" ++ show (M.size m)

147+ put $ M.insert n name m

148+ return $ TypeVar name

149+ Just name -> return $ TypeVar name

150+ f t = return t

151+ g :: Row -> State (M.Map Int String) Row

152+ g (RUnknown n) = do

153+ m <- get

154+ case M.lookup n m of

155+ Nothing -> do

156+ let name = "r" ++ show (M.size m)

157+ put $ M.insert n name m

158+ return $ RowVar name

159+ Just name -> return $ RowVar name

160+ g r = return r

161+

162+replaceTypeVars :: M.Map String Type -> Type -> Type

163+replaceTypeVars m = everywhere (mkT replace)

164+ where

165+ replace (TypeVar v) = case M.lookup v m of

166+ Just ty -> ty

167+ _ -> TypeVar v

168+ replace t = t

169+

170+replaceVarsWithUnknowns :: [String] -> Type -> Check Type

171+replaceVarsWithUnknowns idents = flip evalStateT M.empty . everywhereM (flip extM f $ mkM g)

172+ where

173+ f :: Type -> StateT (M.Map String Int) Check Type

174+ f (TypeVar var) | var `elem` idents = do

175+ m <- get

176+ n <- lift fresh

177+ case M.lookup var m of

178+ Nothing -> do

179+ put (M.insert var n m)

180+ return $ TUnknown n

181+ Just u -> return $ TUnknown u

182+ f t = return t

183+ g :: Row -> StateT (M.Map String Int) Check Row

184+ g (RowVar var) | var `elem` idents = do

185+ m <- get

186+ n <- lift fresh

187+ case M.lookup var m of

188+ Nothing -> do

189+ put (M.insert var n m)

190+ return $ RUnknown n

191+ Just u -> return $ RUnknown u

192+ g r = return r

193+

194+replaceAllTypeSynonyms :: (D.Data d) => d -> Check d

195+replaceAllTypeSynonyms d = do

196+ env <- getEnv

197+ let syns = map (\(name, (args, _)) -> (name, length args)) . M.toList $ typeSynonyms env

198+ either throwError return $ saturateAllTypeSynonyms syns d

199+

200+desaturateAllTypeSynonyms :: (D.Data d) => d -> d

201+desaturateAllTypeSynonyms = everywhere (mkT $ replace)

202+ where

203+ replace (SaturatedTypeSynonym name args) = foldl (\t arg -> TypeApp t arg) (TypeConstructor name) args

204+ replace t = t

205+

206+replaceType :: (D.Data d) => Int -> Type -> d -> d

207+replaceType n t = everywhere (mkT go)

208+ where

209+ go (TUnknown m) | m == n = t

210+ go t = t

211+

212+replaceRow :: (D.Data d) => Int -> Row -> d -> d

213+replaceRow n r = everywhere (mkT go)

214+ where

215+ go (RUnknown m) | m == n = r

216+ go r = r

217+

218+typeOccursCheck :: Int -> Type -> Check ()

219+typeOccursCheck u (TUnknown _) = return ()

220+typeOccursCheck u t = when (occursCheck u t) $ throwError $ "Occurs check failed: " ++ show u ++ " = " ++ prettyPrintType t

221+

222+rowOccursCheck :: Int -> Row -> Check ()

223+rowOccursCheck u (RUnknown _) = return ()

224+rowOccursCheck u r = when (occursCheck u r) $ throwError $ "Occurs check failed: " ++ show u ++ " = " ++ prettyPrintRow r

225+

226+occursCheck :: (D.Data d) => Int -> d -> Bool

227+occursCheck u = everything (||) $ flip extQ g $ mkQ False f

228+ where

229+ f (TUnknown u') | u' == u = True

230+ f _ = False

231+ g (RUnknown u') | u' == u = True

232+ g _ = False

233+

234+typesToRow :: [(String, Type)] -> Row

235+typesToRow [] = REmpty

236+typesToRow ((name, ty):tys) = RCons name ty (typesToRow tys)

237+

238+rowToList :: Row -> ([(String, Type)], Row)

239+rowToList (RCons name ty row) = let (tys, rest) = rowToList row

240+ in ((name, ty):tys, rest)

241+rowToList r = ([], r)

242+

243+rowFromList :: ([(String, Type)], Row) -> Row

244+rowFromList ([], r) = r

245+rowFromList ((name, t):ts, r) = RCons name t (rowFromList (ts, r))

246+

247+ensureNoDuplicateProperties :: [(String, Value)] -> Check ()

248+ensureNoDuplicateProperties ps = guardWith "Duplicate property names" $ length (nub . map fst $ ps) == length ps

249+

250+typeConstraints :: M.Map Ident Int -> Value -> Check ([TypeConstraint], Int)

251+typeConstraints _ v@(NumericLiteral _) = do

252+ me <- fresh

253+ return ([TypeConstraint me Number (ValueOrigin v)], me)

254+typeConstraints _ v@(StringLiteral _) = do

255+ me <- fresh

256+ return ([TypeConstraint me String (ValueOrigin v)], me)

257+typeConstraints _ v@(BooleanLiteral _) = do

258+ me <- fresh

259+ return ([TypeConstraint me Boolean (ValueOrigin v)], me)

260+typeConstraints m v@(ArrayLiteral vals) = do

261+ all <- mapM (typeConstraints m) vals

262+ let (cs, ns) = (concat . map fst &&& map snd) all

263+ me <- fresh

264+ return (cs ++ zipWith (\n el -> TypeConstraint me (Array $ TUnknown n) (ValueOrigin el)) ns vals, me)

265+typeConstraints m u@(Unary op val) = do

266+ (cs, n1) <- typeConstraints m val

267+ me <- fresh

268+ return (cs ++ unaryOperatorConstraints u op n1 me, me)

269+typeConstraints m b@(Binary op left right) = do

270+ (cs1, n1) <- typeConstraints m left

271+ (cs2, n2) <- typeConstraints m right

272+ me <- fresh

273+ return (cs1 ++ cs2 ++ binaryOperatorConstraints b op n1 n2 me, me)

274+typeConstraints m v@(ObjectLiteral ps) = do

275+ ensureNoDuplicateProperties ps

276+ all <- mapM (typeConstraints m . snd) ps

277+ let (cs, ns) = (concat . map fst &&& map snd) all

278+ me <- fresh

279+ let tys = zipWith (\(name, _) u -> (name, TUnknown u)) ps ns

280+ return ((TypeConstraint me (Object (typesToRow tys)) (ValueOrigin v)) : cs, me)

281+typeConstraints m v@(ObjectUpdate o ps) = do

282+ ensureNoDuplicateProperties ps

283+ (cs1, n1) <- typeConstraints m o

284+ all <- mapM (typeConstraints m . snd) ps

285+ let (cs2, ns) = (concat . map fst &&& map snd) all

286+ row <- fresh

287+ let tys = zipWith (\(name, _) u -> (name, TUnknown u)) ps ns

288+ return (TypeConstraint n1 (Object (rowFromList (tys, RUnknown row))) (ValueOrigin v) : cs1 ++ cs2, n1)

289+typeConstraints m v@(Indexer index val) = do

290+ (cs1, n1) <- typeConstraints m index

291+ (cs2, n2) <- typeConstraints m val

292+ me <- fresh

293+ return ((TypeConstraint n1 Number (ValueOrigin index)) : (TypeConstraint n2 (Array (TUnknown me)) (ValueOrigin v)) : cs1 ++ cs2, me)

294+typeConstraints m v@(Accessor prop val) = do

295+ (cs, n1) <- typeConstraints m val

296+ me <- fresh

297+ rest <- fresh

298+ return ((TypeConstraint n1 (Object (RCons prop (TUnknown me) (RUnknown rest))) (ValueOrigin v)) : cs, me)

299+typeConstraints m v@(Abs args ret) = do

300+ ns <- replicateM (length args) fresh

301+ let m' = m `M.union` M.fromList (zipWith (,) args ns)

302+ (cs, n') <- typeConstraints m' ret

303+ me <- fresh

304+ return ((TypeConstraint me (Function (map TUnknown ns) (TUnknown n')) (ValueOrigin v)) : cs, me)

305+typeConstraints m v@(App f xs) = do

306+ (cs1, n1) <- typeConstraints m f

307+ all <- mapM (typeConstraints m) xs

308+ let (cs2, ns) = (concat . map fst &&& map snd) all

309+ me <- fresh

310+ return ((TypeConstraint n1 (Function (map TUnknown ns) (TUnknown me)) (ValueOrigin v)) : cs1 ++ cs2, me)

311+typeConstraints m v@(Var var) =

312+ case M.lookup var m of

313+ Nothing -> do

314+ env <- getEnv

315+ case M.lookup var (names env) of

316+ Nothing -> throwError $ show var ++ " is undefined"

317+ Just (PolyType idents ty, _) -> do

318+ me <- fresh

319+ replaced <- replaceVarsWithUnknowns idents ty

320+ return ([TypeConstraint me replaced (ValueOrigin v)], me)

321+ Just u -> do

322+ me <- fresh

323+ return ([TypeConstraint u (TUnknown me) (ValueOrigin v)], me)

324+typeConstraints m (Block ss) = do

325+ ret <- fresh

326+ (cs, allCodePathsReturn, _) <- typeConstraintsForBlock m M.empty ret ss

327+ guardWith "Block is missing a return statement" allCodePathsReturn

328+ return (cs, ret)

329+typeConstraints m v@(Constructor c) = do

330+ env <- getEnv

331+ case M.lookup c (dataConstructors env) of

332+ Nothing -> throwError $ "Constructor " ++ c ++ " is undefined"

333+ Just (PolyType idents ty) -> do

334+ me <- fresh

335+ replaced <- replaceVarsWithUnknowns idents ty

336+ return ([TypeConstraint me replaced (ValueOrigin v)], me)

337+typeConstraints m (Case val binders) = do

338+ (cs1, n1) <- typeConstraints m val

339+ ret <- fresh

340+ cs2 <- typeConstraintsForBinders m n1 ret binders

341+ return (cs1 ++ cs2, ret)

342+typeConstraints m v@(IfThenElse cond th el) = do

343+ (cs1, n1) <- typeConstraints m cond

344+ (cs2, n2) <- typeConstraints m th

345+ (cs3, n3) <- typeConstraints m el

346+ return (TypeConstraint n1 Boolean (ValueOrigin cond) : TypeConstraint n2 (TUnknown n3) (ValueOrigin v) : cs1 ++ cs2 ++ cs3, n2)

347+typeConstraints m v@(TypedValue val poly@(PolyType idents ty)) = do

348+ kind <- kindOf poly

349+ guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star

350+ (cs, n1) <- typeConstraints m val

351+ return (TypeConstraint n1 ty (ValueOrigin v) : cs, n1)

352+

353+unaryOperatorConstraints :: Value -> UnaryOperator -> Int -> Int -> [TypeConstraint]

354+unaryOperatorConstraints v Negate val result = [TypeConstraint val Number (ValueOrigin v), TypeConstraint result Number (ValueOrigin v)]

355+unaryOperatorConstraints v Not val result = [TypeConstraint val Boolean (ValueOrigin v), TypeConstraint result Boolean (ValueOrigin v)]

356+unaryOperatorConstraints v BitwiseNot val result = [TypeConstraint val Number (ValueOrigin v), TypeConstraint result Number (ValueOrigin v)]

357+

358+binaryOperatorConstraints :: Value -> BinaryOperator -> Int -> Int -> Int -> [TypeConstraint]

359+binaryOperatorConstraints v Add = symBinOpConstraints v Number

360+binaryOperatorConstraints v Subtract = symBinOpConstraints v Number

361+binaryOperatorConstraints v Multiply = symBinOpConstraints v Number

362+binaryOperatorConstraints v Divide = symBinOpConstraints v Number

363+binaryOperatorConstraints v Modulus = symBinOpConstraints v Number

364+binaryOperatorConstraints v LessThan = asymBinOpConstraints v Number Boolean

365+binaryOperatorConstraints v LessThanOrEqualTo = asymBinOpConstraints v Number Boolean

366+binaryOperatorConstraints v GreaterThan = asymBinOpConstraints v Number Boolean

367+binaryOperatorConstraints v GreaterThanOrEqualTo = asymBinOpConstraints v Number Boolean

368+binaryOperatorConstraints v BitwiseAnd = symBinOpConstraints v Number

369+binaryOperatorConstraints v BitwiseOr = symBinOpConstraints v Number

370+binaryOperatorConstraints v BitwiseXor = symBinOpConstraints v Number

371+binaryOperatorConstraints v ShiftLeft = symBinOpConstraints v Number

372+binaryOperatorConstraints v ShiftRight = symBinOpConstraints v Number

373+binaryOperatorConstraints v ZeroFillShiftRight = symBinOpConstraints v Number

374+binaryOperatorConstraints v EqualTo = equalityBinOpConstraints v

375+binaryOperatorConstraints v NotEqualTo = equalityBinOpConstraints v

376+binaryOperatorConstraints v And = symBinOpConstraints v Boolean

377+binaryOperatorConstraints v Or = symBinOpConstraints v Boolean

378+binaryOperatorConstraints v Concat = symBinOpConstraints v String

379+

380+equalityBinOpConstraints :: Value -> Int -> Int -> Int -> [TypeConstraint]

381+equalityBinOpConstraints v left right result = [TypeConstraint left (TUnknown right) (ValueOrigin v), TypeConstraint result Boolean (ValueOrigin v)]

382+

383+symBinOpConstraints :: Value -> Type -> Int -> Int -> Int -> [TypeConstraint]

384+symBinOpConstraints v ty left right result = asymBinOpConstraints v ty ty left right result

385+

386+asymBinOpConstraints :: Value -> Type -> Type -> Int -> Int -> Int -> [TypeConstraint]

387+asymBinOpConstraints v ty res left right result = [TypeConstraint left ty (ValueOrigin v), TypeConstraint right ty (ValueOrigin v), TypeConstraint result res (ValueOrigin v)]

388+

389+typeConstraintsForBinder :: Int -> Binder -> Check ([TypeConstraint], M.Map Ident Int)

390+typeConstraintsForBinder _ NullBinder = return ([], M.empty)

391+typeConstraintsForBinder val b@(StringBinder _) = constantBinder b val String

392+typeConstraintsForBinder val b@(NumberBinder _) = constantBinder b val Number

393+typeConstraintsForBinder val b@(BooleanBinder _) = constantBinder b val Boolean

394+typeConstraintsForBinder val b@(VarBinder name) = do

395+ me <- fresh

396+ return ([TypeConstraint me (TUnknown val) (BinderOrigin b)], M.singleton name me)

397+typeConstraintsForBinder val b@(NullaryBinder ctor) = do

398+ env <- getEnv

399+ case M.lookup ctor (dataConstructors env) of

400+ Just (PolyType args ret) -> do

401+ ret' <- replaceVarsWithUnknowns args ret

402+ return ([TypeConstraint val ret' (BinderOrigin b)], M.empty)

403+ _ -> throwError $ "Constructor " ++ ctor ++ " is not defined"

404+typeConstraintsForBinder val b@(UnaryBinder ctor binder) = do

405+ env <- getEnv

406+ case M.lookup ctor (dataConstructors env) of

407+ Just (PolyType idents f@(Function [_] _)) -> do

408+ obj <- fresh

409+ (Function [ty] ret) <- replaceVarsWithUnknowns idents f

410+ (cs, m1) <- typeConstraintsForBinder obj binder

411+ return ((TypeConstraint val ret (BinderOrigin b)) : (TypeConstraint obj ty (BinderOrigin b)) : cs, m1)

412+ Just _ -> throwError $ ctor ++ " is not a unary constructor"

413+ _ -> throwError $ "Constructor " ++ ctor ++ " is not defined"

414+typeConstraintsForBinder val b@(ObjectBinder props) = do

415+ row <- fresh

416+ rest <- fresh

417+ (cs, m1) <- typeConstraintsForProperties row (RUnknown rest) props

418+ return ((TypeConstraint val (Object (RUnknown row)) (BinderOrigin b)) : cs, m1)

419+ where

420+ typeConstraintsForProperties :: Int -> Row -> [(String, Binder)] -> Check ([TypeConstraint], M.Map Ident Int)

421+ typeConstraintsForProperties nrow row [] = return ([RowConstraint nrow row (BinderOrigin b)], M.empty)

422+ typeConstraintsForProperties nrow row ((name, binder):binders) = do

423+ propTy <- fresh

424+ (cs1, m1) <- typeConstraintsForBinder propTy binder

425+ (cs2, m2) <- typeConstraintsForProperties nrow (RCons name (TUnknown propTy) row) binders

426+ return (cs1 ++ cs2, M.union m1 m2)

427+typeConstraintsForBinder val b@(ArrayBinder binders rest) = do

428+ el <- fresh

429+ all <- mapM (typeConstraintsForBinder el) binders

430+ let (cs1, m1) = (concat . map fst &&& M.unions . map snd) all

431+ let arrayConstraint = TypeConstraint val (Array (TUnknown el)) (BinderOrigin b)

432+ case rest of

433+ Nothing -> return (arrayConstraint : cs1, m1)

434+ Just binder -> do

435+ (cs2, m2) <- typeConstraintsForBinder val binder

436+ return (arrayConstraint : cs1 ++ cs2, M.union m1 m2)

437+typeConstraintsForBinder val b@(NamedBinder name binder) = do

438+ me <- fresh

439+ (cs, m) <- typeConstraintsForBinder val binder

440+ return (TypeConstraint me (TUnknown val) (BinderOrigin b) : cs, M.insert name me m)

441+typeConstraintsForBinder val b@(GuardedBinder cond binder) = do

442+ (cs1, m) <- typeConstraintsForBinder val binder

443+ (cs2, n) <- typeConstraints m cond

444+ return (TypeConstraint n Boolean (ValueOrigin cond) : cs1 ++ cs2, m)

445+

446+constantBinder :: Binder -> Int -> Type -> Check ([TypeConstraint], M.Map Ident Int)

447+constantBinder b val ty = return ([TypeConstraint val ty (BinderOrigin b)], M.empty)

448+

449+typeConstraintsForBinders :: M.Map Ident Int -> Int -> Int -> [(Binder, Value)] -> Check [TypeConstraint]

450+typeConstraintsForBinders _ _ _ [] = return []

451+typeConstraintsForBinders m nval ret ((binder, val):bs) = do

452+ (cs1, m1) <- typeConstraintsForBinder nval binder

453+ (cs2, n2) <- typeConstraints (M.union m m1) val

454+ cs3 <- typeConstraintsForBinders m nval ret bs

455+ return ((TypeConstraint n2 (TUnknown ret) (BinderOrigin binder)) : cs1 ++ cs2 ++ cs3)

456+

457+assignVariable :: Ident -> M.Map Ident Int -> Check ()

458+assignVariable name m =

459+ case M.lookup name m of

460+ Nothing -> return ()

461+ Just _ -> throwError $ "Variable with name " ++ show name ++ " already exists."

462+

463+typeConstraintsForStatement :: M.Map Ident Int -> M.Map Ident Int -> Int -> Statement -> Check ([TypeConstraint], Bool, M.Map Ident Int)

464+typeConstraintsForStatement m mass ret (VariableIntroduction name val) = do

465+ assignVariable name (m `M.union` mass)

466+ (cs1, n1) <- typeConstraints m val

467+ return $ (cs1, False, M.insert name n1 mass)

468+typeConstraintsForStatement m mass ret (Assignment ident val) = do

469+ (cs1, n1) <- typeConstraints m val

470+ case M.lookup ident mass of

471+ Nothing -> throwError $ "No local variable with name " ++ show ident

472+ Just ty -> do

473+ return (TypeConstraint n1 (TUnknown ty) (AssignmentTargetOrigin ident) : cs1, False, mass)

474+typeConstraintsForStatement m mass ret (While val inner) = do

475+ (cs1, n1) <- typeConstraints m val

476+ (cs2, allCodePathsReturn, _) <- typeConstraintsForBlock m mass ret inner

477+ return $ ((TypeConstraint n1 Boolean (ValueOrigin val)) : cs1 ++ cs2, allCodePathsReturn, mass)

478+typeConstraintsForStatement m mass ret (If ifst) = do

479+ (cs, allCodePathsReturn) <- typeConstraintsForIfStatement m mass ret ifst

480+ return $ (cs, allCodePathsReturn, mass)

481+typeConstraintsForStatement m mass ret (For ident start end inner) = do

482+ assignVariable ident (m `M.union` mass)

483+ (cs1, n1) <- typeConstraints (m `M.union` mass) start

484+ (cs2, n2) <- typeConstraints (m `M.union` mass) end

485+ let mass1 = M.insert ident n1 mass

486+ (cs3, allCodePathsReturn, _) <- typeConstraintsForBlock (m `M.union` mass1) mass1 ret inner

487+ return $ ((TypeConstraint n1 Number (ValueOrigin start)) : (TypeConstraint n2 Number (ValueOrigin end)) : cs1 ++ cs2 ++ cs3, allCodePathsReturn, mass)

488+typeConstraintsForStatement m mass ret (ForEach ident vals inner) = do

489+ assignVariable ident (m `M.union` mass)

490+ val <- fresh

491+ (cs1, n1) <- typeConstraints (m `M.union` mass) vals

492+ let mass1 = M.insert ident val mass

493+ (cs2, allCodePathsReturn, _) <- typeConstraintsForBlock (m `M.union` mass1) mass1 ret inner

494+ guardWith "Cannot return from within a foreach block" $ not allCodePathsReturn

495+ return $ ((TypeConstraint n1 (Array (TUnknown val)) (ValueOrigin vals)) : cs1 ++ cs2, False, mass)

496+typeConstraintsForStatement m mass ret (Return val) = do

497+ (cs1, n1) <- typeConstraints (m `M.union` mass) val

498+ return ((TypeConstraint n1 (TUnknown ret) (ValueOrigin val)) : cs1, True, mass)

499+

500+typeConstraintsForIfStatement :: M.Map Ident Int -> M.Map Ident Int -> Int -> IfStatement -> Check ([TypeConstraint], Bool)

501+typeConstraintsForIfStatement m mass ret (IfStatement val thens Nothing) = do

502+ (cs1, n1) <- typeConstraints m val

503+ (cs2, allCodePathsReturn, _) <- typeConstraintsForBlock m mass ret thens

504+ return ((TypeConstraint n1 Boolean (ValueOrigin val)) : cs1 ++ cs2, allCodePathsReturn)

505+typeConstraintsForIfStatement m mass ret (IfStatement val thens (Just elses)) = do

506+ (cs1, n1) <- typeConstraints m val

507+ (cs2, allCodePathsReturn1, _) <- typeConstraintsForBlock m mass ret thens

508+ (cs3, allCodePathsReturn2) <- typeConstraintsForElseStatement m mass ret elses

509+ return ((TypeConstraint n1 Boolean (ValueOrigin val)) : cs1 ++ cs2 ++ cs3, allCodePathsReturn1 && allCodePathsReturn2)

510+

511+typeConstraintsForElseStatement :: M.Map Ident Int -> M.Map Ident Int -> Int -> ElseStatement -> Check ([TypeConstraint], Bool)

512+typeConstraintsForElseStatement m mass ret (Else elses) = do

513+ (cs, allCodePathsReturn, _) <- typeConstraintsForBlock m mass ret elses

514+ return (cs, allCodePathsReturn)

515+typeConstraintsForElseStatement m mass ret (ElseIf ifst) = do

516+ (cs, allCodePathsReturn) <- typeConstraintsForIfStatement m mass ret ifst

517+ return (cs, allCodePathsReturn)

518+

519+typeConstraintsForBlock :: M.Map Ident Int -> M.Map Ident Int -> Int -> [Statement] -> Check ([TypeConstraint], Bool, M.Map Ident Int)

520+typeConstraintsForBlock _ mass _ [] = return ([], False, mass)

521+typeConstraintsForBlock m mass ret (s:ss) = do

522+ (cs1, b1, mass1) <- typeConstraintsForStatement (m `M.union` mass) mass ret s

523+ case (b1, ss) of

524+ (True, []) -> return (cs1, True, mass1)

525+ (True, _) -> throwError "Unreachable code"

526+ (False, ss) -> do

527+ (cs2, b2, mass2) <- typeConstraintsForBlock m mass1 ret ss

528+ return (cs1 ++ cs2, b2, mass2)

529+

530+solveTypeConstraints :: [TypeConstraint] -> TypeSolution -> Check TypeSolution

531+solveTypeConstraints [] s = return s

532+solveTypeConstraints all@(TypeConstraint n t o:cs) s = do

533+ (cs', s') <- rethrow (\err -> "Error in " ++ prettyPrintOrigin o ++ ": " ++ err) $ do

534+ typeOccursCheck n t

535+ let s' = let (f, g) = runTypeSolution s

536+ in TypeSolution (replaceType n t . f, replaceType n t . g)

537+ cs' <- fmap concat $ mapM (substituteTypeInConstraint n t) cs

538+ return (cs', s')

539+ solveTypeConstraints cs' s'

540+solveTypeConstraints (RowConstraint n r o:cs) s = do

541+ (cs', s') <- rethrow (\err -> "Error in " ++ prettyPrintOrigin o ++ ": " ++ err) $ do

542+ rowOccursCheck n r

543+ let s' = let (f, g) = runTypeSolution s

544+ in TypeSolution $ (replaceRow n r . f, replaceRow n r . g)

545+ cs' <- fmap concat $ mapM (substituteRowInConstraint n r) cs

546+ return (cs', s')

547+ solveTypeConstraints cs' s'

548+

549+substituteTypeInConstraint :: Int -> Type -> TypeConstraint -> Check [TypeConstraint]

550+substituteTypeInConstraint n s (TypeConstraint m t v)

551+ | n == m = unifyTypes v s t

552+ | otherwise = return [TypeConstraint m (replaceType n s t) v]

553+substituteTypeInConstraint n s (RowConstraint m r v)

554+ = return [RowConstraint m (replaceType n s r) v]

555+

556+substituteRowInConstraint :: Int -> Row -> TypeConstraint -> Check [TypeConstraint]

557+substituteRowInConstraint n r (TypeConstraint m t v)

558+ = return [TypeConstraint m (replaceRow n r t) v]

559+substituteRowInConstraint n r (RowConstraint m r1 v)

560+ | m == n = unifyRows v r r1

561+ | otherwise = return [RowConstraint m (replaceRow n r r1) v]

562+

563+unifyTypes :: TypeConstraintOrigin -> Type -> Type -> Check [TypeConstraint]

564+unifyTypes _ (TUnknown u1) (TUnknown u2) | u1 == u2 = return []

565+unifyTypes o (TUnknown u) t = do

566+ typeOccursCheck u t

567+ return [TypeConstraint u t o]

568+unifyTypes o t (TUnknown u) = do

569+ typeOccursCheck u t

570+ return [TypeConstraint u t o]

571+unifyTypes o (SaturatedTypeSynonym name1 args1) (SaturatedTypeSynonym name2 args2) | name1 == name2 =

572+ fmap concat $ zipWithM (unifyTypes o) args1 args2

573+unifyTypes o (SaturatedTypeSynonym name args) ty = do

574+ env <- getEnv

575+ case M.lookup name (typeSynonyms env) of

576+ Just (synArgs, body) -> do

577+ let m = M.fromList $ zip synArgs args

578+ let replaced = replaceTypeVars m body

579+ unifyTypes o replaced ty

580+ Nothing -> error "Type synonym was not defined"

581+unifyTypes o ty s@(SaturatedTypeSynonym _ _) = unifyTypes o s ty

582+unifyTypes _ Number Number = return []

583+unifyTypes _ String String = return []

584+unifyTypes _ Boolean Boolean = return []

585+unifyTypes o (Array s) (Array t) = unifyTypes o s t

586+unifyTypes o (Object row1) (Object row2) = unifyRows o row1 row2

587+unifyTypes o (Function args1 ret1) (Function args2 ret2) = do

588+ guardWith "Function applied to incorrect number of args" $ length args1 == length args2

589+ cs1 <- fmap concat $ zipWithM (unifyTypes o) args1 args2

590+ cs2 <- unifyTypes o ret1 ret2

591+ return $ cs1 ++ cs2

592+unifyTypes _ (TypeVar v1) (TypeVar v2) | v1 == v2 = return []

593+unifyTypes _ (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = return []

594+unifyTypes o (TypeApp t1 t2) (TypeApp t3 t4) = do

595+ cs1 <- unifyTypes o t1 t3

596+ cs2 <- unifyTypes o t2 t4

597+ return $ cs1 ++ cs2

598+unifyTypes _ t1 t2 = throwError $ "Cannot unify " ++ prettyPrintType t1 ++ " with " ++ prettyPrintType t2 ++ "."

599+

600+unifyRows :: TypeConstraintOrigin -> Row -> Row -> Check [TypeConstraint]

601+unifyRows o r1 r2 =

602+ let

603+ (s1, r1') = rowToList r1

604+ (s2, r2') = rowToList r2

605+ int = [ (t1, t2) | (name, t1) <- s1, (name', t2) <- s2, name == name' ]

606+ sd1 = [ (name, t1) | (name, t1) <- s1, not (elem name (map fst s2)) ]

607+ sd2 = [ (name, t2) | (name, t2) <- s2, not (elem name (map fst s1)) ]

608+ in do

609+ cs1 <- fmap concat $ mapM (uncurry $ unifyTypes o) int

610+ cs2 <- unifyRows' o sd1 r1' sd2 r2'

611+ return $ cs1 ++ cs2

612+ where

613+ unifyRows' :: TypeConstraintOrigin -> [(String, Type)] -> Row -> [(String, Type)] -> Row -> Check [TypeConstraint]

614+ unifyRows' o [] (RUnknown u) sd r = do

615+ rowOccursCheck u r

616+ return [RowConstraint u (rowFromList (sd, r)) o]

617+ unifyRows' o sd r [] (RUnknown u) = do

618+ rowOccursCheck u r

619+ return [RowConstraint u (rowFromList (sd, r)) o]

620+ unifyRows' o ns@((name, ty):row) r others (RUnknown u) | not (occursCheck u (ty, row)) = do

621+ u' <- fresh

622+ cs <- unifyRows' o row r others (RUnknown u')

623+ return (RowConstraint u (RCons name ty (RUnknown u')) o : cs)

624+ unifyRows' _ [] REmpty [] REmpty = return []

625+ unifyRows' _ [] (RowVar v1) [] (RowVar v2) | v1 == v2 = return []

626+ unifyRows' _ sd1 r1 sd2 r2 = throwError $ "Cannot unify " ++ prettyPrintRow (rowFromList (sd1, r1)) ++ " with " ++ prettyPrintRow (rowFromList (sd2, r2)) ++ "."

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, Eq, 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+97

@@ -0,0 +1,97 @@

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+ | ObjectUpdate Value [(String, Value)]

62+ | Abs [Ident] Value

63+ | App Value [Value]

64+ | Var Ident

65+ | IfThenElse Value Value Value

66+ | Block [Statement]

67+ | Constructor String

68+ | Case Value [(Binder, Value)]

69+ | TypedValue Value PolyType deriving (Show, Data, Typeable)

70+

71+data Statement

72+ = VariableIntroduction Ident Value

73+ | Assignment Ident Value

74+ | While Value [Statement]

75+ | For Ident Value Value [Statement]

76+ | ForEach Ident Value [Statement]

77+ | If IfStatement

78+ | Return Value deriving (Show, Data, Typeable)

79+

80+data IfStatement = IfStatement Value [Statement] (Maybe ElseStatement) deriving (Show, Data, Typeable)

81+

82+data ElseStatement

83+ = Else [Statement]

84+ | ElseIf IfStatement deriving (Show, Data, Typeable)

85+

86+data Binder

87+ = NullBinder

88+ | BooleanBinder Bool

89+ | StringBinder String

90+ | NumberBinder (Either Integer Double)

91+ | VarBinder Ident

92+ | NullaryBinder String

93+ | UnaryBinder String Binder

94+ | ObjectBinder [(String, Binder)]

95+ | ArrayBinder [Binder] (Maybe Binder)

96+ | NamedBinder Ident Binder

97+ | GuardedBinder Value Binder 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"

tests/Main.hsnew file+71

@@ -0,0 +1,71 @@

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 (main) where

16+

17+import PureScript

18+import PureScript.CodeGen.Pretty.Types

19+

20+import Data.List (isSuffixOf)

21+import Control.Applicative

22+import Control.Monad

23+import System.Exit (exitSuccess, exitFailure)

24+import System.FilePath (pathSeparator)

25+import System.Directory (getCurrentDirectory, getDirectoryContents)

26+import qualified System.IO.UTF8 as U

27+import qualified Data.Map as M

28+

29+compile :: FilePath -> IO (Either String Environment)

30+compile inputFile = do

31+ ast <- runIndentParser parseDeclarations <$> U.readFile inputFile

32+ case ast of

33+ Left parseError -> do

34+ return (Left $ show parseError)

35+ Right decls -> do

36+ case check (typeCheckAll decls) of

37+ Left typeError -> do

38+ return (Left typeError)

39+ Right (_, env) -> do

40+ return (Right env)

41+

42+assert :: FilePath -> (Either String Environment -> Maybe String) -> IO ()

43+assert inputFile f = do

44+ e <- compile inputFile

45+ case f e of

46+ Just err -> exitFailure

47+ Nothing -> return ()

48+

49+assertCompiles :: FilePath -> IO ()

50+assertCompiles inputFile = do

51+ putStrLn $ "assert " ++ inputFile ++ " compiles successfully"

52+ assert inputFile $ either Just (const Nothing)

53+

54+assertDoesNotCompile :: FilePath -> IO ()

55+assertDoesNotCompile inputFile = do

56+ putStrLn $ "assert " ++ inputFile ++ " does not compile"

57+ assert inputFile $ either (const Nothing) (const $ Just "Should not have compiled")

58+

59+main :: IO ()

60+main = do

61+ cd <- getCurrentDirectory

62+ let examples = cd ++ pathSeparator : "examples"

63+ let passing = examples ++ pathSeparator : "passing"

64+ passingTestCases <- getDirectoryContents passing

65+ forM_ passingTestCases $ \inputFile -> when (".ps" `isSuffixOf` inputFile) $

66+ assertCompiles (passing ++ pathSeparator : inputFile)

67+ let failing = examples ++ pathSeparator : "failing"

68+ failingTestCases <- getDirectoryContents failing

69+ forM_ failingTestCases $ \inputFile -> when (".ps" `isSuffixOf` inputFile) $

70+ assertDoesNotCompile (failing ++ pathSeparator : inputFile)

71+ exitSuccess