golang..38e324a · rowtype-yoga/purescript-native

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

122 files changed+5489−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

CONTRIBUTING.mdnew file+14

@@ -0,0 +1,14 @@

1+Pull requests are encouraged.

3+Please follow the following guidelines:

5+- Add at least a test to `examples/passing/` and possibly to `examples/failing`

6+- Run `cabal test`

7+- Consider adding a full test with Javascript to `examples/shelltest`

8+- Please run `hlint`.

10+If you would like to contribute, please consider the issues in the current milestone first.

11+

12+Send me (`paf31`) a message if you have any implementation questions, I'm more than happy to talk about the design, and I'm more than willing to redesign parts if necessary.

13+

14+Finally, if you have made code changes and would like to be included in the copyright notice in the cabal file, please include that change in your pull request.

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.

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

@@ -1,41 +1,736 @@

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

18+

19+## Experimental Features

2120

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

21+- Modules

22+- Rank N Types

2323

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

24+## Try It!

2525

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

26+Try PureScript in the browser [here](http://tryps.functorial.com/).

2727

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

28+## License

2929

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.

30+See the `LICENSE` file

3431

32+## Contributing

3533

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)

34+Contributions are always encouraged! Please see `CONTRIBUTING.md` for guidelines.

35+

36+## Installation

37+

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

39+

40+## Usage

41+

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

43+

44+The following options are supported:

45+

46+ -o --output

47+ Write the generated Javascript to the specified file

48+

49+ -e --foreign imports

50+ Write a list of foreign imports declarations to the specified file in addition to generating Javascript output

51+

52+## Motivation

53+

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

55+

56+- Generate simple readable Javascript

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

58+- Reasonable type system

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

60+- Provides a simple interface to existing Javascript code

61+

62+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.

63+

64+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.

65+

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

67+

68+## Hello, PureScript!

69+

70+As an introductory example, here is the usual "Hello World" written in PureScript:

71+

72+```haskell

73+foreign import console :: { log :: String -> {} }

74+

75+main = \() -> console.log "Hello, World!"

76+```

77+

78+which compiles to the following Javascript:

79+

80+```javascript

81+function main() {

82+ console.log("Hello, World!");

83+}

84+```

85+

86+## Another Example

87+

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

89+

90+```haskell

91+data Person = Person { name :: String, age :: Number }

92+

93+foreign import numberToString :: Number -> String

94+

95+showPerson :: Person -> String

96+showPerson = \p -> case p of

97+ Person o -> o.name ++ ", aged " ++ numberToString(o.age)

98+```

99+

100+Line by line, this reads as follows:

101+

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

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

104+- The `numberToString` function is written in Javascript, and converts a `Number` to its `String` representation

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

106+- `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.

107+

108+The generated Javascript looks like this:

109+

110+```javascript

111+var Person = function (value) {

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

113+};

114+

115+function showPerson(p) {

116+ if (p.ctor === "Person") {

117+ return p.value.name + ", aged " + itoa(p.value.age)

118+ };

119+ throw "Failed pattern match"

120+}

121+

122+```

123+

124+## Type System

125+

126+The type system defines the following types:

127+

128+- Primitive Types

129+ - Number

130+ - String

131+ - Boolean

132+- Arrays

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

134+- Records

135+ - E.g. `{ foo :: String, bar :: Number }`

136+- Tagged Unions

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

138+- Functions

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

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

141+ - Functions can have zero or more arguments

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

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

144+

145+## Primitive Types

146+

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

148+

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

150+

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

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

153+

154+Examples:

155+

156+```haskell

157+num = 1 + 2 * 3

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

159+bool = 1 > 2 || true

160+```

161+

162+## Arrays

163+

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

165+

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

167+

168+Array elements can be read using array index notation `arr !! index`

169+

170+## Records

171+

172+PureScript records correspond to Javascript objects.

173+

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

175+

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

177+

178+## Tagged Unions

179+

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

181+

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

183+

184+For example:

185+

186+```haskell

187+data Foo a = Foo | Bar String

188+

189+runFoo = \foo -> case foo of

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

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

192+

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

194+```

195+

196+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.

197+

198+`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.

199+

200+## Functions

201+

202+Functions in PureScript can have zero or more arguments in general, just like in Javascript.

203+

204+Functions are introduced by using a backslash followed by a list of argument names:

205+

206+```haskell

207+test1 = \a b -> a + b

208+```

209+

210+which would correspond to the Javascript

211+

212+```javascript

213+function test1(a) {

214+ return function (b) {

215+ return a + b;

216+ }

217+}

218+```

219+

220+Multiple argument functions can be introduced by wrapping the arguments in parentheses, and separating them with commas:

221+

222+```haskell

223+test1 = \(a, b) -> a + b

224+```

225+

226+which generates

227+

228+```javascript

229+function test1(a, b) {

230+ return a + b;

231+}

232+```

233+

234+In the case of a function with no arguments, the parentheses may be omitted, as follows:

235+

236+```haskell

237+test2 = \ -> 100

238+```

239+

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

241+

242+Multiple-argument and single-argument syntax can be mixed, as follows:

243+

244+```haskell

245+test3 = \a (b, c) d -> a + b + c + d

246+```

247+

248+which generates

249+

250+```javascript

251+function test3(a) {

252+ return function (b, c) {

253+ return function (d) {

254+ return a + b + c + d;

255+ }

256+ }

257+}

258+```

259+

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

261+

262+```haskell

263+test1(1, 2, 3)

264+test2()

265+```

266+

267+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:

268+

269+```haskell

270+-- has type Number -> Number -> Number -> Number

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

272+

273+-- has type Number -> Number -> Number

274+addThree 1

275+

276+-- has type Number -> Number

277+addThree 1 2

278+

279+-- has type Number

280+addThree 1 2 3

281+```

282+

283+## Polymorphic Types

284+

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

286+

287+Here is an example:

288+

289+```haskell

290+identity = \x -> x

291+```

292+

293+`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.

294+

295+A type annotation can also be provided:

296+

297+```haskell

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

299+identity = \x -> x

300+```

301+

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

303+

304+```haskell

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

306+```

307+

308+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*.

309+

310+So, the following compiles:

311+

312+```haskell

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

314+```

315+

316+but the following does not:

317+

318+```haskell

319+addProps { foo: 1 }

320+```

321+

322+since the `bar` property is missing.

323+

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

325+

326+## Rank N Types (Experimental Feature)

327+

328+It is also possible for the `forall` quantifier to appear on the left of a function arrow, inside types record fields and data constructors, and in type synonyms.

329+

330+In most cases, a type annotation is necessary when using this feature.

331+

332+As an example, we can pass a polymorphic function as an argument to another function:

333+

334+```haskell

335+poly :: (forall a. a -> a) -> Boolean

336+poly = \f -> (f 0 < 1) == f true

337+```

338+

339+Notice that the polymorphic function's type argument is instantiated to both `Number` and `Boolean`.

340+

341+An argument to `poly` must indeed be polymorphic. For example, the following fails:

342+

343+```haskell

344+test = poly (\n -> n + 1)

345+```

346+

347+since the skolemized type variable `a` does not unify with `Number`.

348+

349+## Type Inference

350+

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

352+

353+## Kind System

354+

355+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.

356+

357+## Whitespace

358+

359+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.

360+

361+That is, the following is valid:

362+

363+```haskell

364+foo = bar(x) +

365+ baz(x)

366+```

367+

368+But this is not:

369+

370+```haskell

371+foo = bar(x) +

372+baz(x)

373+```

374+

375+## Do Notation

376+

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

378+

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

380+

381+The following types of statement are supported:

382+

383+- Variable introduction

384+- Variable assignment

385+- For loops

386+- For-each loops

387+- While loops

388+- If-Then-Else statements

389+

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

391+

392+```haskell

393+pow = \n p -> do

394+ var m = n

395+ for i <- 0 until p:

396+ m = m * n

397+ return m

398+```

399+

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

401+

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

403+

404+```haskell

405+incr = \n -> do

406+ n = n + 1

407+ return n

408+```

409+

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

411+

412+This function can be rewritten as follows:

413+

414+```haskell

415+incr = \n -> do

416+ var m = n

417+ m = m + 1

418+ return m

419+```

420+

421+## For Loops

422+

423+For loops look like this:

424+

425+```haskell

426+total = do

427+ var n = 0

428+ for i <- 0 until 10:

429+ n = n + i

430+ return n

431+```

432+

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

434+

435+## For-Each Loops

436+

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

438+

439+```haskell

440+total = \arr -> do

441+ var n = 0

442+ foreach i in arr:

443+ n = n + i

444+ return n

445+```

446+

447+## While Loops

448+

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

450+

451+```haskell

452+log2 = \n -> do

453+ var count = 0

454+ var m = n

455+ while m > 1:

456+ m = m / 2

457+ count = count + 1

458+ return count

459+```

460+

461+## If-Then-Else Statements

462+

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

464+

465+```haskell

466+collatz = \n -> do

467+ var count = 0

468+ var m = n

469+ while m > 1:

470+ if m % 2 == 0:

471+ m = m / 2

472+ else:

473+ m = m * 3 + 1

474+ count = count + 1

475+ return count

476+```

477+

478+## If-Then-Else Expressions

479+

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

481+

482+For example,

483+

484+```haskell

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

486+```

487+

488+## Pattern Matching

489+

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

491+

492+Pattern matches have the following general form

493+

494+```haskell

495+case value of

496+ pattern -> result

497+ -- ...

498+ pattern -> result

499+```

500+

501+The following pattern types are supported:

502+

503+- Wildcard pattern

504+- Literal patterns

505+- Variable pattern

506+- Array patterns

507+- Record patterns

508+- Named patterns

509+- Guards

510+

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

512+

513+## Wildcard Patterns

514+

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

516+

517+```haskell

518+case x of

519+ _ -> 0

520+```

521+

522+## Literal Patterns

523+

524+Literal patterns are provided to match on primitives:

525+

526+```haskell

527+case booleanValue of

528+ true -> 0

529+ false -> 1

530+

531+case stringValue of

532+ "Foo" -> 0

533+ _ -> 1

534+

535+case numericValue of

536+ 0 -> 0

537+ _ -> 1

538+```

539+

540+## Variable Pattern

541+

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

543+

544+```haskell

545+case foo(x) of

546+ result -> bar(result)

547+```

548+

549+## Array Patterns

550+

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

552+

553+For example:

554+

555+```haskell

556+f = \arr -> case arr of

557+ [x] -> x

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

559+ _ -> 0

560+```

561+

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

563+

564+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`.

565+

566+## Record Patterns

567+

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

569+

570+```haskell

571+f = \o -> case o of

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

573+ _ -> 0

574+```

575+

576+## Nested Patterns

577+

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

579+

580+For example:

581+

582+```haskell

583+f = \o -> case o of

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

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

586+ _ -> 0

587+```

588+

589+## Named Patterns

590+

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

592+

593+```haskell

594+f = \arr -> case arr of

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

596+ a -> a

597+```

598+

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

600+

601+## Guards

602+

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

604+

605+```haskell

606+evens = \arr -> case arr of

607+ [] -> 0

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

609+ [_:xs] -> evens xs

610+```

611+

612+## Type Synonyms

613+

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

615+

616+For example:

617+

618+```haskell

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

620+

621+addFoo :: Foo -> Number

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

623+```

624+## Record Updates

625+

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

627+

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

629+

630+```haskell

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

632+```

633+

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

635+

636+```haskell

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

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

639+};

640+```

641+

642+## Operators

643+

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

645+

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

647+

648+```haskell

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

650+

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

652+```

653+

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

655+

656+```haskell

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

658+

659+test = 10 `foo` 20

660+```

661+

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

663+

664+```haskell

665+infixl 5 <>

666+infixr 7 %%

667+```

668+

669+## Modules

670+

671+Simple modules are supported by the `module` keyword.

672+

673+Introduce a module as follows, with a list of indented declarations:

674+

675+```haskell

676+module A where

677+

678+ foo = \x -> x

679+```

680+

681+Modules may be nested:

682+

683+```haskell

684+module A where

685+

686+ foo = \x -> x

687+

688+ module B where

689+

690+ bar = \y -> y

691+```

692+

693+Names may be qualified by using a colon:

694+

695+```

696+foo = A:foo

697+bar = A:B:bar

698+```

699+

700+All the names in a module can be aliased using the `import` declaration:

701+

702+```haskell

703+import A

704+```

705+

706+You can also limit which names are going to be aliased:

707+

708+```haskell

709+import A.B (bar)

710+```

711+

712+## Foreign Function Interface

713+

714+The `foreign import` keyword declares a value which is defined in Javascript, and its type:

715+

716+```haskell

717+foreign import pow :: (Number, Number) -> Number

718+```

719+

720+To declare a new type with no constructors, use `foreign import data` and provide the kind:

721+

722+```haskell

723+foreign import data IO :: * -> *

724+

725+foreign import console :: {

726+ log :: String -> IO {}

727+}

728+```

729+

730+To alias a name of a field defined on a Javascript type to a PureScript function, use `foreign import member`. For example, to define a function `length` which accesses the `length` member of an array:

731+

732+```haskell

733+foreign import member "length" length :: forall a. [a] -> Number

734+```

39735

40736

41−---

Setup.hsdeleted−2

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

1−import Distribution.Simple

2−main = defaultMain

Setup.lhsnew file+6

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

1+#!/usr/bin/runhaskell

2+> module Main where

3+> import Distribution.Simple

4+> main :: IO ()

5+> main = defaultMain

app/Main.hsdeleted−250

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

1−{-# LANGUAGE OverloadedStrings #-}

2−{-# LANGUAGE RankNTypes #-}

3−{-# LANGUAGE TemplateHaskell #-}

4−

5−module Main where

6−

7−import Control.Monad (when)

8−import qualified Control.Monad.Parallel as Par

9−import Data.Aeson

10−import Data.Aeson.Types

11−import Data.Char

12−import Data.FileEmbed (embedFile)

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

14−import Data.Maybe

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

16−import Data.Version

17−import Control.Monad.Supply

18−import Control.Monad.Supply.Class

19−import Text.Printf

20−

21−import System.Environment

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

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

24−import System.FilePath.Find

25−import System.Process

26−

27−import Data.Text (Text)

28−import qualified Data.Text as T

29−import qualified Data.Text.Encoding as T

30−import qualified Data.Text.Lazy as L

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

32−import qualified Data.ByteString as B

33−

34−import Development.GitRev

35−

36−import Language.PureScript.AST.Literals

37−import Language.PureScript.CoreFn

38−import Language.PureScript.CoreFn.FromJSON

39−

40−import CodeGen.IL

41−import CodeGen.IL.Common

42−import CodeGen.IL.Printer

43−

44−import Tests

45−

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

47−

48−parseJson :: Text -> Value

49−parseJson text

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

51− | otherwise = error "Bad json"

52−

53−jsonToModule :: Value -> Module Ann

54−jsonToModule value =

55− case parse moduleFromJSON value of

56− Success (_, r) -> r

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

58−

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

60−splitArgs args =

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

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

63− (moduleName, files') =

64− if null files

65− then (Nothing, files)

66− else

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

68− then do

69− let file0 = head files

70− files' = tail files

71− case file0 of

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

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

74− _ -> (Nothing, files)

75− else (Nothing, files)

76− in (opts, moduleName, files')

77−

78−main :: IO ()

79−main = do

80− args <- getArgs

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

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

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

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

85− then runTests

86− else do

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

88− then do

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

90− putStrLn help

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

92− let branch = $(gitBranch)

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

94− | otherwise = branch

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

96− else do

97− if null files

98− then do

99− currentDir <- getCurrentDirectory

100− processFiles opts' [currentDir]

101− else

102− processFiles opts' files

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

104− then runBuildTool $ Run moduleName

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

106− runBuildTool Build

107− return ()

108− where

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

110− processFiles opts [file] = do

111− isDir <- doesDirectoryExist file

112− if isDir then do

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

114− if null files

115− then errorNoCorefnFiles

116− else generateFiles opts files

117− else generateFiles opts [file]

118− processFiles opts files = do

119− generateFiles opts files

120− basePath :: [FilePath] -> FilePath

121− basePath files =

122− let filepath = takeDirectory (head files) in

123− joinPath $ (init $ splitDirectories filepath)

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

125− generateFiles opts files = do

126− let baseOutpath = basePath files

127− writeSupportFiles baseOutpath

128− Par.mapM (generateCode opts baseOutpath) files

129− return ()

130− runBuildTool :: Command -> IO ()

131− runBuildTool cmd = do

132− project <- projectEnv

133− case cmd of

134− Build -> do

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

136− Run moduleName -> do

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

138− return ()

139−

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

141−generateCode opts baseOutpath jsonFile = do

142− jsonModTime <- getModificationTime jsonFile

143− let filepath = takeDirectory jsonFile

144− dirparts = splitDirectories $ filepath

145− mname = last dirparts

146− basedir = joinPath $ init dirparts

147− mname' = T.pack mname

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

149− exists <- doesFileExist possibleFileName

150− if exists

151− then do

152− modTime <- getModificationTime possibleFileName

153− when (modTime < jsonModTime) $

154− transpile opts baseOutpath jsonFile

155− else transpile opts baseOutpath jsonFile

156−

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

158−transpile opts baseOutpath jsonFile = do

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

160− project <- projectEnv

161− let module' = jsonToModule $ parseJson jsonText

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

163− let mn = moduleNameToIL' $ moduleName module'

164− implementation = prettyPrintIL asts

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

166− implPath = outpath </> implFileName mn

167− createDirectoryIfMissing True outpath

168− putStrLn implPath

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

170−

171−writeSupportFiles :: FilePath -> IO ()

172−writeSupportFiles baseOutpath = do

173− currentDir <- getCurrentDirectory

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

175− ffiOutpath = currentDir </> subdir

176− createDirectoryIfMissing True baseOutpath

177− createDirectoryIfMissing True ffiOutpath

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

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

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

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

182− where

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

184− writeModuleFile outputdir path modText = do

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

186− goModSourceExists <- doesFileExist goModSource

187− when (not goModSourceExists) $ do

188− project <- projectEnv

189− let project' = T.unpack project

190− outputdir' = tail $ T.unpack outputdir

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

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

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

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

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

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

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

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

199− writeLoaderFile ffiOutpath loaderText = do

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

201− loaderSourceExists <- doesFileExist loaderSource

202− when (not loaderSourceExists) $ do

203− B.writeFile loaderSource loaderText

204−

205−implFileName :: Text -> FilePath

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

207−

208−projectEnv :: IO Text

209−projectEnv = do

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

211−

212−help :: String

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

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

215− \Available options:\n\

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

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

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

219− \ executable\n\

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

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

222− \See also:\n\

223− \ purs compile --help\n"

224−

225−corefn :: String

226−corefn = "corefn.json"

227−

228−goSrc :: String

229−goSrc = ".go"

230−

231−goproject :: String

232−goproject = "GOPROJECT"

233−

234−defaultProject :: String

235−defaultProject = "project.localhost"

236−

237−modPrefix' :: String

238−modPrefix' = T.unpack modPrefix

239−

240−ffiLoader' :: String

241−ffiLoader' = T.unpack ffiLoader

242−

243−subdir :: String

244−subdir = T.unpack modLabel

245−

246−errorNoCorefnFiles :: IO ()

247−errorNoCorefnFiles = do

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

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

250− " project build tool"

default.nixdeleted−23

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

1−let

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

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

4−

5− hsc2hsOverlay = self: super: {

6− buildPackages = super.buildPackages // {

7− hsc2hs = super.haskellPackages.hsc2hs;

8− };

9− };

10−

11− nixpkgsArgs = haskellNix.nixpkgsArgs // {

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

13− };

14−in

15−{ pkgs ? import nixpkgsSrc nixpkgsArgs

16−}:

17−

18−pkgs.haskell-nix.stackProject {

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

20− name = "purescript-native";

21− src = ./.;

22− };

23−}

examples/.gitignorenew file+1

@@ -0,0 +1 @@

1+shelltest/tests

examples/failing/Arrays.pursnew file+1

@@ -0,0 +1 @@

1+test = \arr -> arr !! (0 !! 0)

examples/failing/Import.pursnew file+1

@@ -0,0 +1 @@

1+import UndefinedModule

examples/failing/KindError.pursnew file+1

@@ -0,0 +1 @@

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

examples/failing/LocalVars.pursnew file+3

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

1+bad = \x -> do

2+ x = x + 1

3+ return x

examples/failing/PatternScope.pursnew file+7

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

1+-- Pattern scope doesn't leak

2+foobar = \x -> do

3+ var y = case x of

4+ z | z % 2 == 0 -> 1

5+ _ -> 2

6+ return z

examples/failing/Rank2Types.pursnew file+3

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

1+foreign import test :: (forall a. a -> a) -> Number

3+test1 = test (\n -> n + 1)

examples/failing/ReadShow.pursnew file+5

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

1+foreign import read :: forall a. String -> a

3+foreign import show :: forall a. a -> String

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

examples/failing/SkolemEscape.pursnew file+3

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

1+foreign import foo :: (forall a. a -> a) -> Number

3+test = \x -> foo x

examples/failing/TypeError.pursnew file+3

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

1+test = do

2+ var x = 0

3+ return x ++ "A"

examples/passing/Arrays.pursnew file+14

@@ -0,0 +1,14 @@

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)

14+

examples/passing/Assign.pursnew 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/Auto.pursnew file+9

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

1+data Auto s i o = Auto { state :: s, step :: s -> i -> o }

3+type SomeAuto i o = forall r. (forall s. Auto s i o -> r) -> r

5+exists :: forall s i o. s -> (s -> i -> o) -> SomeAuto i o

6+exists = \state step f -> f (Auto { state: state, step: step })

8+run :: forall i o. SomeAuto i o -> i -> o

9+run = \s i -> s (\a -> case a of Auto a -> a.step a.state i)

examples/passing/Church.pursnew file+12

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

1+type List a = forall r. r -> (a -> r -> r) -> r

3+empty :: forall a. List a

4+empty = \r f -> r

6+cons :: forall a. a -> List a -> List a

7+cons = \a l r f -> f a (l r f)

9+append :: forall a. List a -> List a -> List a

10+append = \l1 l2 r f -> l2 (l1 r f) f

11+

12+test = append (cons 1 empty) (cons 2 empty)

examples/passing/Conditional.pursnew 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.pursnew file+19

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

1+foreign import data IO :: * -> *

3+foreign import ret :: forall a. a -> IO a

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

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

9+foreign import 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.pursnew file+13

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

1+foreign import data IO :: * -> *

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

5+foreign import ret :: forall a. a -> IO a

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

9+foreign import showMessage :: String -> IO { }

10+

11+foreign import prompt :: IO String

12+

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

examples/passing/FFI.pursnew file+5

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

1+foreign import foo :: String -> String

3+bar :: String -> String

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

examples/passing/Foreach.pursnew 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/Functions.pursnew file+11

@@ -0,0 +1,11 @@

1+test1 = \ -> 0

3+test2 = \() -> 0

5+test3 = \a (b, c) d -> a + b + c + d

7+test4 = \(a) -> a

9+test5 = \(%%) -> 1 %% 2

10+

11+test6 = \((+++), (***)) -> 1 +++ 2 *** 3

examples/passing/Guards.pursnew file+8

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

1+collatz = \x -> case x of

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

3+ y -> y * 3 + 1

5+-- Guards have access to current scope

6+collatz2 = \x y -> case x of

7+ z | y > 0 -> z / 2

8+ z -> z * 3 + 1

examples/passing/IfThenElse.pursnew 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/Import.pursnew file+12

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

1+module Hello where

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

3+ id = \x -> x

5+ module Nested where

6+ import Hello (id)

8+ foo = id

10+import Hello.Nested

11+

12+main = \() -> foo 42

examples/passing/List.pursnew 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.pursnew file+3

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

1+data Foo a = Foo

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

examples/passing/Maybe.pursnew 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/Module.pursnew file+22

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

1+module Test where

3+ data Foo = Foo String

5+ foo :: Test.Foo -> String

6+ foo = \f -> case f of Foo s -> s ++ "foo"

8+ bar :: Foo -> String

9+ bar = foo

10+

11+ module Inner where

12+

13+ inner = "Inner"

14+

15+baz :: Test.Foo -> String

16+baz = Test.foo

17+

18+innerCopy :: String

19+innerCopy = Test.Inner.inner

20+

21+match :: Test.Foo -> String

22+match = \f -> case f of Test.Foo s -> s ++ "foo"

examples/passing/Monad.pursnew file+26

@@ -0,0 +1,26 @@

1+type Monad m = { ret :: forall a. a -> m a

2+ , bind :: forall a b. m a -> (a -> m b) -> m b }

4+data Id a = Id a

6+id :: Monad Id

7+id = { ret : Id

8+ , bind : \ma f -> case ma of Id a -> f a }

10+data Maybe a = Nothing | Just a

11+

12+maybe :: Monad Maybe

13+maybe = { ret : Just

14+ , bind : \ma f -> case ma of

15+ Nothing -> Nothing

16+ Just a -> f a

17+ }

18+

19+test :: forall m. Monad m -> m Number

20+test = \m -> m.bind (m.ret 1) (\n1 ->

21+ m.bind (m.ret "Test") (\n2 ->

22+ m.ret n1))

23+

24+test1 = test id

25+

26+test2 = test maybe

examples/passing/NameResolution.pursnew file+15

@@ -0,0 +1,15 @@

1+foo = \x -> x

3+module A where

4+ bar = foo

6+ module B where

8+ abc = foo

9+ xyz = bar

10+

11+ foo = \x y -> x

12+

13+ baz = foo

14+

15+ abc = A.B.abc

examples/passing/NamedPatterns.pursnew file+3

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

1+foo = \x -> case x of

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

3+ y -> y

examples/passing/Nested.pursnew 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.pursnew file+14

@@ -0,0 +1,14 @@

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

3+update2 :: forall r. { foo :: String | r } -> { foo :: String | r }

4+update2 = \o -> o { foo = "Foo" }

6+replace = \o -> case o of

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

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

9+ o -> o

10+

11+polyUpdate :: forall a r. { foo :: a | r } -> { foo :: String | r }

12+polyUpdate = \o -> o { foo = "Foo" }

13+

14+inferPolyUpdate = \o -> o { foo = "Foo" }

examples/passing/Objects.pursnew file+12

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

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 }

10+

11+typed :: { foo :: Number }

12+typed = { foo: 0 }

examples/passing/Operators.pursnew file+37

@@ -0,0 +1,37 @@

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!"

22+

23+module Ops where

24+

25+ (@@) :: forall a b. (a -> b) -> a -> b

26+ (@@) = \f x -> f x

27+

28+ foo :: String -> String

29+ foo = \s -> s

30+

31+ test8 = foo @@ "Hello World"

32+

33+ bar = \s1 s2 -> s1 ++ s2

34+

35+test9 = Ops.foo Ops.@@ "Hello World"

36+

37+test10 = "Hello" `Ops.bar` "World"

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

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

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

3+foreign import itoa :: Number -> String

5+showPerson :: Person -> String

6+showPerson = \p -> case p of

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

examples/passing/Rank2Data.pursnew file+23

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

1+data Id = Id forall a. a -> a

3+runId = \id a -> case id of

4+ Id f -> f a

6+data Nat = Nat forall r. r -> (r -> r) -> r

8+runNat = \nat -> case nat of

9+ Nat f -> f 0 (\n -> n + 1)

10+

11+zero = Nat (\zero _ -> zero)

12+

13+succ = \n -> case n of

14+ Nat f -> Nat (\zero succ -> succ (f zero succ))

15+

16+add = \n m -> case n of

17+ Nat f -> case m of

18+ Nat g -> Nat (\zero succ -> g (f zero succ) succ)

19+

20+one = succ zero

21+two = succ zero

22+four = add two two

23+fourNumber = runNat four

examples/passing/Rank2Types.pursnew file+17

@@ -0,0 +1,17 @@

1+test1 :: (forall a. (a -> a)) -> Number

2+test1 = \f -> f 0

4+foreign import data ST :: * -> * -> *

6+foreign import runST :: forall a. (forall s. ST s a) -> a

8+foreign import exampleST :: forall s. ST s Number

10+testST = runST exampleST

11+

12+foreign import push :: forall el. el -> [el] -> [el]

13+

14+replicateM :: forall m a. (forall a. a -> m a) -> (forall a b. m a -> (a -> m b) -> m b) -> Number -> m a -> m [a]

15+replicateM = \ret bind n m -> case n of

16+ 0 -> ret []

17+ n -> bind m (\x -> bind (replicateM ret bind (n - 1) m) (\xs -> ret (push x xs)))

examples/passing/Recursion.pursnew 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.pursnew 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.pursnew 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+foreign import 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.pursnew 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.pursnew 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.purs -o tests/Maybe.js && cat tests/Maybe.js Maybe.js | nodejs

3+<<<

4+>>>

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

6+>>>2

7+>>>= 0

9+# List

10+mkdir -p tests && ../../dist/build/psc/psc ../passing/List.purs -o tests/List.js && cat tests/List.js List.js | nodejs

11+<<<

12+>>>

13+[ 1, 2 ]

14+>>>2

15+>>>= 0

16+

17+# Foreach

18+mkdir -p tests && ../../dist/build/psc/psc ../passing/Foreach.purs -o tests/Foreach.js && cat tests/Foreach.js Foreach.js | nodejs

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.purs example.purs -o all.js

3+ cat jquery.js >> all.js

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

libraries/jquery/example.pursnew 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.pursnew file+23

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

1+-- The jQuery wrapper type

2+foreign import data JQuery :: *

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

5+foreign import select :: String -> JQuery

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

8+foreign import create :: String -> JQuery

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

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

12+

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

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

15+

16+-- .append(...)

17+foreign import append :: JQuery -> JQuery -> JQuery

18+

19+-- .appendTo(...)

20+foreign import appendTo :: JQuery -> JQuery -> JQuery

21+

22+-- .append(...)

23+foreign import appendText :: JQuery -> String -> JQuery

libraries/prelude/Makefilenew file+3

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

1+all:

2+ ../../dist/build/psc/psc prelude.purs -o all.js

3+ cat prelude.js >> all.js

libraries/prelude/prelude.jsnew file+65

@@ -0,0 +1,65 @@

1+// Arrays

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

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

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

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

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

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

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

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

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

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

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

14+

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

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

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

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

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

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

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

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

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

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

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

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

27+

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

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

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

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

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

33+

34+var nan = NaN;

35+var infinity = Infinity;

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

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

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

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

40+

41+var math = Math;

42+

43+function map(f) {

44+ return function(xs) {

45+ var ys = [];

46+ for (var i = 0; i < xs.length; i++) {

47+ ys[i] = f(xs[i]);

48+ }

49+ return ys;

50+ };

51+}

52+

53+function filter(xs) {

54+ return function (p) {

55+ var ys = [];

56+ var j = 0;

57+ for (var i = 0; i < xs.length; i++) {

58+ var x = xs[i];

59+ if (p(x)) {

60+ ys[j++] = x;

61+ }

62+ }

63+ return ys;

64+ };

65+}

libraries/prelude/prelude.pursnew file+261

@@ -0,0 +1,261 @@

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+konst :: forall a b. a -> b -> a

8+konst = \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+bindMaybe :: forall a b. Maybe a -> (a -> Maybe b) -> Maybe b

29+bindMaybe = \m -> \f -> maybe Nothing f m

30+

31+-- Either

32+

33+data Either a b = Left a | Right b

34+

35+either :: forall a b c. (a -> c) -> (b -> c) -> Either a b -> c

36+either = \f -> \g -> \e -> case e of

37+ Left a -> f a

38+ Right b -> g b

39+

40+bindEither :: forall e a b. Either e a -> (a -> Either e b) -> Either e b

41+bindEither = either (\e -> \_ -> Left e) (\a -> \f -> f a)

42+

43+-- Arrays

44+

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

46+head = \xs -> case xs of

47+ [x:_] -> x

48+

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

50+headSafe = \xs -> case xs of

51+ [x:_] -> Just x

52+ _ -> Nothing

53+

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

55+tail = \xs -> case xs of

56+ [_:xs] -> xs

57+

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

59+tailSafe = \xs -> case xs of

60+ [_:xs] -> Just xs

61+ _ -> Nothing

62+

63+foreign import map :: forall a b. (a -> b) -> [a] -> [b]

64+

65+foldr :: forall a b. (a -> b -> a) -> a -> [b] -> a

66+foldr = \f -> \a -> \bs -> case bs of

67+ [b:bs] -> f (foldr f a bs) b

68+ [] -> a

69+

70+foldl :: forall a b. (a -> b -> b) -> b -> [a] -> b

71+foldl = \f -> \b -> \as -> do

72+ var result = b

73+ foreach a in as:

74+ result = f a result

75+ return result

76+

77+foreign import member "length" length :: forall a. [a] -> Number

78+

79+foreign import indexOf :: forall a. [a] -> a -> Number

80+

81+foreign import lastIndexOf :: forall a. [a] -> a -> Number

82+

83+foreign import concat :: forall a. [a] -> [a] -> [a]

84+

85+foreign import join :: [String] -> String

86+

87+foreign import joinWith :: [String] -> String -> String

88+

89+foreign import push :: forall a. [a] -> a -> [a]

90+

91+foreign import reverse :: forall a. [a] -> [a]

92+

93+foreign import shift :: forall a. [a] -> [a]

94+

95+foreign import slice :: forall a. Number -> Number -> [a] -> [a]

96+

97+foreign import sort :: forall a. [a] -> [a]

98+

99+foreign import splice :: forall a. Number -> Number -> [a] -> [a] -> [a]

100+

101+cons :: forall a. a -> [a] -> [a]

102+cons = \a -> concat([a])

103+

104+concatMap :: forall a b. [a] -> (a -> [b]) -> [b]

105+concatMap = \as -> \f -> do

106+ var result = []

107+ foreach a in as:

108+ result = result `concat` f a

109+ return result

110+

111+foreign import filter :: forall a. [a] -> (a -> Boolean) -> [a]

112+

113+empty :: forall a. [a] -> Boolean

114+empty = \as -> case as of

115+ [] -> true

116+ _ -> false

117+

118+range :: Number -> Number -> [Number]

119+range = \lo -> \hi -> do

120+ var ns = []

121+ for n <- lo until hi:

122+ ns = push ns n

123+ return ns

124+

125+zipWith :: forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]

126+zipWith = \f -> \as -> \bs -> case { as: as, bs: bs } of

127+ { as = [a:as1], bs = [b:bs1] } -> cons (f a b) (zipWith f as1 bs1)

128+ _ -> []

129+

130+any :: forall a. (a -> Boolean) -> [a] -> Boolean

131+any = \p -> \as -> do

132+ for i <- 0 until length as:

133+ if p (as !! i):

134+ return true

135+ return false

136+

137+all :: forall a. (a -> Boolean) -> [a] -> Boolean

138+all = \p -> \as -> do

139+ for i <- 0 until length as:

140+ if !(p (as !! i)):

141+ return false

142+ return true

143+

144+-- Pairs

145+

146+type Tuple a b = { fst :: a, snd :: b }

147+

148+curry :: forall a b c. (Tuple a b -> c) -> a -> b -> c

149+curry = \f -> \a -> \b -> f { fst: a, snd: b }

150+

151+uncurry :: forall a b c. (a -> b -> c) -> Tuple a b -> c

152+uncurry = \f -> \t -> f t.fst t.snd

153+

154+tuple :: forall a b. a -> b -> Tuple a b

155+tuple = curry id

156+

157+zip :: forall a b. [a] -> [b] -> [Tuple a b]

158+zip = zipWith tuple

159+

160+unzip :: forall a b. [Tuple a b] -> Tuple [a] [b]

161+unzip = \ts -> case ts of

162+ [t:ts1] -> case unzip ts1 of

163+ { fst = as, snd = bs } -> tuple (cons t.fst as) (cons t.snd bs)

164+ [] -> tuple [] []

165+

166+-- Strings

167+

168+foreign import member "length" lengthS :: String -> Number

169+

170+foreign import charAt :: Number -> String -> String

171+

172+foreign import indexOfS :: String -> String -> Number

173+

174+foreign import lastIndexOfS :: String -> String -> Number

175+

176+foreign import localeCompare :: String -> String -> Number

177+

178+foreign import replace :: String -> String -> String -> String

179+

180+foreign import sliceS :: Number -> Number -> String -> String

181+

182+foreign import split :: String -> String -> [String]

183+

184+foreign import substr :: Number -> Number -> String -> String

185+

186+foreign import substring :: Number -> Number -> String -> String

187+

188+foreign import toLower :: String -> String

189+

190+foreign import toUpper :: String -> String

191+

192+foreign import trim :: String -> String

193+

194+-- Regex

195+

196+foreign import data Regex :: *

197+

198+foreign import regex :: String -> String -> Regex

199+

200+foreign import test :: Regex -> String -> Boolean

201+

202+foreign import match :: Regex -> String -> [String]

203+

204+foreign import replaceR :: Regex -> String -> String -> String

205+

206+foreign import search :: Regex -> String -> Number

207+

208+-- Globals

209+

210+foreign import nan :: Number

211+

212+foreign import infinity :: Number

213+

214+foreign import toExponential :: Number -> String

215+

216+foreign import toFixed :: Number -> Number -> String

217+

218+foreign import toPrecision :: Number -> Number -> String

219+

220+foreign import numberToString :: Number -> String

221+

222+foreign import isNaN :: Number -> Boolean

223+

224+foreign import isFinite :: Number -> Boolean

225+

226+foreign import parseFloat :: String -> Number

227+

228+foreign import parseInt :: String -> Number

229+

230+foreign import encodeURIComponent :: String -> String

231+

232+foreign import decodeURIComponent :: String -> String

233+

234+foreign import encodeURI :: String -> String

235+

236+foreign import decodeURI :: String -> String

237+

238+-- Math

239+

240+type Math =

241+ { abs :: Number -> Number

242+ , acos :: Number -> Number

243+ , asin :: Number -> Number

244+ , atan :: Number -> Number

245+ , atan2 :: (Number, Number) -> Number

246+ , aceil :: Number -> Number

247+ , cos :: Number -> Number

248+ , exp :: Number -> Number

249+ , floor :: Number -> Number

250+ , log :: Number -> Number

251+ , max :: (Number, Number) -> Number

252+ , pow :: (Number, Number) -> Number

253+ , random :: () -> Number

254+ , round :: Number -> Number

255+ , sin :: Number -> Number

256+ , sqrt :: Number -> Number

257+ , tan :: Number -> Number

258+ }

259+

260+foreign import math :: Math

261+

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

purescript.cabalnew file+60

@@ -0,0 +1,60 @@

1+name: purescript

2+version: 0.1.15

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+category: Language

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

14+data-dir: ""

15+

16+library

17+ build-depends: base >=4 && <5, syb -any, cmdtheline -any,

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

19+ utf8-string -any

20+ exposed-modules: Data.Generics.Extras Language.PureScript.Operators

21+ Language.PureScript.Optimize Language.PureScript.Pretty.JS

22+ Language.PureScript.CodeGen.JS.AST Main Language.PureScript

23+ Language.PureScript.Declarations Language.PureScript.Names

24+ Language.PureScript.Types Language.PureScript.Values

25+ Language.PureScript.Kinds Language.PureScript.Pretty

26+ Language.PureScript.Pretty.Common Language.PureScript.Pretty.Values

27+ Language.PureScript.Pretty.Types Language.PureScript.Pretty.Kinds

28+ Language.PureScript.CodeGen Language.PureScript.CodeGen.Externs

29+ Language.PureScript.CodeGen.JS Language.PureScript.CodeGen.Monad

30+ Language.PureScript.Parser Language.PureScript.Parser.Common

31+ Language.PureScript.Parser.Declarations

32+ Language.PureScript.Parser.Types Language.PureScript.Parser.Values

33+ Language.PureScript.Parser.State Language.PureScript.Parser.Kinds

34+ Language.PureScript.TypeChecker

35+ Language.PureScript.TypeChecker.Kinds

36+ Language.PureScript.TypeChecker.Monad

37+ Language.PureScript.TypeChecker.Types

38+ Language.PureScript.TypeChecker.Synonyms

39+ Language.PureScript.Unknown

40+ exposed: True

41+ buildable: True

42+ hs-source-dirs: src

43+

44+executable psc

45+ build-depends: base >=4 && <5, cmdtheline -any, containers -any,

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

47+ syb -any

48+ main-is: Main.hs

49+ buildable: True

50+ hs-source-dirs: src

51+ other-modules:

52+

53+test-suite tests

54+ build-depends: base >=4 && <5, syb -any, directory -any,

55+ filepath -any, containers -any, mtl -any, transformers -any,

56+ parsec -any, utf8-string -any, purescript -any

57+ type: exitcode-stdio-1.0

58+ main-is: Main.hs

59+ buildable: True

60+ hs-source-dirs: tests

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/Data/Generics/Extras.hsnew file+24

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

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

2+--

3+-- Module : Data.Generics.Extras

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 Data.Generics.Extras where

18+

19+import Data.Data

20+

21+everywhereM' :: (Monad m, Data d) => (forall d. (Data d) => d -> m d) -> d -> m d

22+everywhereM' f x = do

23+ y <- f x

24+ gmapM (everywhereM' f) y

src/Language/PureScript.hsnew file+38

@@ -0,0 +1,38 @@

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

2+--

3+-- Module : Language.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 Language.PureScript (module P, compile) where

16+

17+import Language.PureScript.Values as P

18+import Language.PureScript.Types as P

19+import Language.PureScript.Kinds as P

20+import Language.PureScript.Declarations as P

21+import Language.PureScript.Names as P

22+import Language.PureScript.Parser as P

23+import Language.PureScript.CodeGen as P

24+import Language.PureScript.TypeChecker as P

25+import Language.PureScript.Pretty as P

26+import Language.PureScript.Optimize as P

27+import Language.PureScript.Operators as P

28+

29+import Data.List (intercalate)

30+import Data.Maybe (mapMaybe)

31+

32+compile :: [Declaration] -> Either String (String, String, Environment)

33+compile decls = do

34+ bracketted <- rebracket decls

35+ (_, env) <- runCheck (typeCheckAll bracketted)

36+ let js = prettyPrintJS . map optimize . concat . mapMaybe (\decl -> declToJs Nothing global decl env) $ bracketted

37+ let exts = intercalate "\n" . mapMaybe (externToPs 0 global env) $ bracketted

38+ return (js, exts, env)

src/Language/PureScript/CodeGen.hsnew file+18

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

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

2+--

3+-- Module : Language.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 Language.PureScript.CodeGen (module C) where

16+

17+import Language.PureScript.CodeGen.JS as C

18+import Language.PureScript.CodeGen.Externs as C

src/Language/PureScript/CodeGen/Externs.hsnew file+42

@@ -0,0 +1,42 @@

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

2+--

3+-- Module : Language.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 Language.PureScript.CodeGen.Externs (

16+ externToPs

17+) where

18+

19+import Data.List (intercalate)

20+import Data.Maybe (mapMaybe)

21+import qualified Data.Map as M

22+import Language.PureScript.Declarations

23+import Language.PureScript.TypeChecker.Monad

24+import Language.PureScript.Pretty

25+import Language.PureScript.Names

26+

27+externToPs :: Int -> ModulePath -> Environment -> Declaration -> Maybe String

28+externToPs indent path env (ValueDeclaration name _) = do

29+ (ty, _) <- M.lookup (path, name) $ names env

30+ return $ replicate indent ' ' ++ "foreign import " ++ show name ++ " :: " ++ prettyPrintType ty

31+externToPs indent path env (DataDeclaration name _ _) = do

32+ (kind, _) <- M.lookup (path, name) $ types env

33+ return $ replicate indent ' ' ++ "foreign import data " ++ show name ++ " :: " ++ prettyPrintKind kind

34+externToPs indent path env (ExternMemberDeclaration member name ty) =

35+ return $ replicate indent ' ' ++ "foreign import member " ++ show member ++ " " ++ show name ++ " :: " ++ prettyPrintType ty

36+externToPs indent path env (ExternDataDeclaration name kind) =

37+ return $ replicate indent ' ' ++ "foreign import data " ++ show name ++ " :: " ++ prettyPrintKind kind

38+externToPs indent path env (TypeSynonymDeclaration name args ty) =

39+ return $ replicate indent ' ' ++ "type " ++ show name ++ " " ++ unwords args ++ " = " ++ prettyPrintType ty

40+externToPs indent path env (ModuleDeclaration name decls) =

41+ return $ replicate indent ' ' ++ "module " ++ show name ++ " where\n" ++ unlines (mapMaybe (externToPs (indent + 2) (subModule path name) env) decls)

42+externToPs _ _ _ _ = Nothing

src/Language/PureScript/CodeGen/JS.hsnew file+171

@@ -0,0 +1,171 @@

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

2+--

3+-- Module : Language.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 Language.PureScript.CodeGen.JS (

16+ module AST,

17+ declToJs

18+) where

19+

20+import Data.Char

21+import Data.Maybe (fromMaybe, mapMaybe)

22+import Data.List (intercalate)

23+import qualified Data.Map as M

24+import qualified Control.Arrow as A

25+import Control.Arrow ((<+>), second)

26+import Control.Monad (forM)

27+import Control.Applicative

28+

29+import Language.PureScript.TypeChecker (Environment, names)

30+import Language.PureScript.Types

31+import Language.PureScript.Values

32+import Language.PureScript.Names

33+import Language.PureScript.Declarations

34+import Language.PureScript.Pretty.Common

35+import Language.PureScript.CodeGen.Monad

36+import Language.PureScript.CodeGen.JS.AST as AST

37+import Language.PureScript.TypeChecker.Monad (NameKind(..))

38+

39+declToJs :: Maybe Ident -> ModulePath -> Declaration -> Environment -> Maybe [JS]

40+declToJs mod mp (ValueDeclaration ident (Abs args ret)) e =

41+ Just $ JSFunction (Just ident) args (JSBlock [JSReturn (valueToJs mp e ret)]) :

42+ maybe [] (return . setProperty (identToJs ident) (JSVar ident)) mod

43+declToJs mod mp (ValueDeclaration ident val) e =

44+ Just $ JSVariableIntroduction ident (Just (valueToJs mp e val)) :

45+ maybe [] (return . setProperty (identToJs ident) (JSVar ident)) mod

46+declToJs mod _ (ExternMemberDeclaration member ident _) _ =

47+ Just $ JSFunction (Just ident) [Ident "value"] (JSBlock [JSReturn (JSAccessor member (JSVar (Ident "value")))]) :

48+ maybe [] (return . setProperty (show ident) (JSVar ident)) mod

49+declToJs mod mp (DataDeclaration _ _ ctors) _ =

50+ Just $ flip concatMap ctors $ \(pn@(ProperName ctor), maybeTy) ->

51+ let

52+ ctorJs =

53+ case maybeTy of

54+ Nothing -> JSVariableIntroduction (Ident ctor) (Just (JSObjectLiteral [ ("ctor", JSStringLiteral (show (Qualified mp pn))) ]))

55+ Just _ -> JSFunction (Just (Ident ctor)) [Ident "value"]

56+ (JSBlock [JSReturn

57+ (JSObjectLiteral [ ("ctor", JSStringLiteral (show (Qualified mp pn)))

58+ , ("value", JSVar (Ident "value")) ])])

59+ in ctorJs : maybe [] (return . setProperty ctor (JSVar (Ident ctor))) mod

60+declToJs mod mp (ModuleDeclaration pn@(ProperName name) decls) env =

61+ Just $ [ JSVariableIntroduction (Ident name) Nothing

62+ , JSApp (JSFunction Nothing [Ident name]

63+ (JSBlock (concat $ mapMaybe (\decl -> declToJs (Just (Ident name)) (subModule mp pn) decl env) decls)))

64+ [JSAssignment (JSAssignVariable (Ident name))

65+ (JSBinary Or (JSVar (Ident name)) (JSObjectLiteral []))]] ++

66+ maybe [] (return . setProperty name (JSVar (Ident name))) mod

67+declToJs _ _ _ _ = Nothing

68+

69+setProperty :: String -> JS -> Ident -> JS

70+setProperty prop val mod = JSAssignment (JSAssignProperty prop (JSAssignVariable mod)) val

71+

72+valueToJs :: ModulePath -> Environment -> Value -> JS

73+valueToJs _ _ (NumericLiteral n) = JSNumericLiteral n

74+valueToJs _ _ (StringLiteral s) = JSStringLiteral s

75+valueToJs _ _ (BooleanLiteral b) = JSBooleanLiteral b

76+valueToJs m e (ArrayLiteral xs) = JSArrayLiteral (map (valueToJs m e) xs)

77+valueToJs m e (ObjectLiteral ps) = JSObjectLiteral (map (second (valueToJs m e)) ps)

78+valueToJs m e (ObjectUpdate o ps) = JSApp (JSAccessor "extend" (JSVar (Ident "Object"))) [ valueToJs m e o, JSObjectLiteral (map (second (valueToJs m e)) ps)]

79+valueToJs m e (Constructor name) = qualifiedToJS runProperName name

80+valueToJs m e (Block sts) = JSApp (JSFunction Nothing [] (JSBlock (map (statementToJs m e) sts))) []

81+valueToJs m e (Case value binders) = runGen (bindersToJs m e binders (valueToJs m e value))

82+valueToJs m e (IfThenElse cond th el) = JSConditional (valueToJs m e cond) (valueToJs m e th) (valueToJs m e el)

83+valueToJs m e (Accessor prop val) = JSAccessor prop (valueToJs m e val)

84+valueToJs m e (Indexer index val) = JSIndexer (valueToJs m e index) (valueToJs m e val)

85+valueToJs m e (App val args) = JSApp (valueToJs m e val) (map (valueToJs m e) args)

86+valueToJs m e (Abs args val) = JSFunction Nothing args (JSBlock [JSReturn (valueToJs m e val)])

87+valueToJs m e (Unary op val) = JSUnary op (valueToJs m e val)

88+valueToJs m e (Binary op v1 v2) = JSBinary op (valueToJs m e v1) (valueToJs m e v2)

89+valueToJs m e (Var ident) = case M.lookup (qualify m ident) (names e) of

90+ Just (_, Alias aliasModule aliasIdent) -> qualifiedToJS identToJs (Qualified aliasModule aliasIdent)

91+ _ -> qualifiedToJS identToJs ident

92+valueToJs m e (TypedValue val _) = valueToJs m e val

93+

94+qualifiedToJS :: (a -> String) -> Qualified a -> JS

95+qualifiedToJS f (Qualified (ModulePath parts) a) =

96+ delimited (f a : reverse (map show parts))

97+ where delimited [part] = JSVar (Ident (part))

98+ delimited (part:parts) = JSAccessor part (delimited parts)

99+

100+bindersToJs :: ModulePath -> Environment -> [(Binder, Value)] -> JS -> Gen JS

101+bindersToJs m e binders val = do

102+ valName <- fresh

103+ jss <- forM binders $ \(binder, result) -> binderToJs m e valName [JSReturn (valueToJs m e result)] binder

104+ return $ JSApp (JSFunction Nothing [Ident valName] (JSBlock (concat jss ++ [JSThrow (JSStringLiteral "Failed pattern match")])))

105+ [val]

106+

107+binderToJs :: ModulePath -> Environment -> String -> [JS] -> Binder -> Gen [JS]

108+binderToJs _ _ varName done NullBinder = return done

109+binderToJs _ _ varName done (StringBinder str) =

110+ return [JSIfElse (JSBinary EqualTo (JSVar (Ident varName)) (JSStringLiteral str)) (JSBlock done) Nothing]

111+binderToJs _ _ varName done (NumberBinder num) =

112+ return [JSIfElse (JSBinary EqualTo (JSVar (Ident varName)) (JSNumericLiteral num)) (JSBlock done) Nothing]

113+binderToJs _ _ varName done (BooleanBinder True) =

114+ return [JSIfElse (JSVar (Ident varName)) (JSBlock done) Nothing]

115+binderToJs _ _ varName done (BooleanBinder False) =

116+ return [JSIfElse (JSUnary Not (JSVar (Ident varName))) (JSBlock done) Nothing]

117+binderToJs _ e varName done (VarBinder ident) =

118+ return (JSVariableIntroduction ident (Just (JSVar (Ident varName))) : done)

119+binderToJs m e varName done (NullaryBinder ctor) =

120+ return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar (Ident varName))) (JSStringLiteral (show (uncurry Qualified $ qualify m ctor)))) (JSBlock done) Nothing]

121+binderToJs m e varName done (UnaryBinder ctor b) = do

122+ value <- fresh

123+ js <- binderToJs m e value done b

124+ return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar (Ident varName))) (JSStringLiteral (show (uncurry Qualified $ qualify m ctor)))) (JSBlock (JSVariableIntroduction (Ident value) (Just (JSAccessor "value" (JSVar (Ident varName)))) : js)) Nothing]

125+binderToJs m e varName done (ObjectBinder bs) = go done bs

126+ where

127+ go :: [JS] -> [(String, Binder)] -> Gen [JS]

128+ go done [] = return done

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

130+ propVar <- fresh

131+ done' <- go done bs

132+ js <- binderToJs m e propVar done' binder

133+ return (JSVariableIntroduction (Ident propVar) (Just (JSAccessor prop (JSVar (Ident varName)))) : js)

134+binderToJs m e varName done (ArrayBinder bs rest) = do

135+ js <- go done rest 0 bs

136+ return [JSIfElse (JSBinary cmp (JSAccessor "length" (JSVar (Ident varName))) (JSNumericLiteral (Left (fromIntegral $ length bs)))) (JSBlock js) Nothing]

137+ where

138+ cmp :: BinaryOperator

139+ cmp = maybe EqualTo (const GreaterThanOrEqualTo) rest

140+ go :: [JS] -> Maybe Binder -> Integer -> [Binder] -> Gen [JS]

141+ go done Nothing _ [] = return done

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

143+ restVar <- fresh

144+ js <- binderToJs m e restVar done binder

145+ return (JSVariableIntroduction (Ident restVar) (Just (JSApp (JSAccessor "slice" (JSVar (Ident varName))) [JSNumericLiteral (Left index)])) : js)

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

147+ elVar <- fresh

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

149+ js <- binderToJs m e elVar done' binder

150+ return (JSVariableIntroduction (Ident elVar) (Just (JSIndexer (JSNumericLiteral (Left index)) (JSVar (Ident varName)))) : js)

151+binderToJs m e varName done (NamedBinder ident binder) = do

152+ js <- binderToJs m e varName done binder

153+ return (JSVariableIntroduction ident (Just (JSVar (Ident varName))) : js)

154+binderToJs m e varName done (GuardedBinder cond binder) = binderToJs m e varName done' binder

155+ where

156+ done' = [JSIfElse (valueToJs m e cond) (JSBlock done) Nothing]

157+

158+statementToJs :: ModulePath -> Environment -> Statement -> JS

159+statementToJs m e (VariableIntroduction ident value) = JSVariableIntroduction ident (Just (valueToJs m e value))

160+statementToJs m e (Assignment target value) = JSAssignment (JSAssignVariable target) (valueToJs m e value)

161+statementToJs m e (While cond sts) = JSWhile (valueToJs m e cond) (JSBlock (map (statementToJs m e) sts))

162+statementToJs m e (For ident start end sts) = JSFor ident (valueToJs m e start) (valueToJs m e end) (JSBlock (map (statementToJs m e) sts))

163+statementToJs m e (ForEach ident arr sts) = JSApp (JSAccessor "forEach" (valueToJs m e arr)) [JSFunction Nothing [ident] (JSBlock (map (statementToJs m e) sts))]

164+statementToJs m e (If ifst) = ifToJs ifst

165+ where

166+ ifToJs :: IfStatement -> JS

167+ ifToJs (IfStatement cond thens elses) = JSIfElse (valueToJs m e cond) (JSBlock (map (statementToJs m e) thens)) (fmap elseToJs elses)

168+ elseToJs :: ElseStatement -> JS

169+ elseToJs (Else sts) = JSBlock (map (statementToJs m e) sts)

170+ elseToJs (ElseIf ifst) = ifToJs ifst

171+statementToJs m e (Return value) = JSReturn (valueToJs m e value)

src/Language/PureScript/CodeGen/JS/AST.hsnew file+49

@@ -0,0 +1,49 @@

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

2+--

3+-- Module : Language.PureScript.CodeGen.JS.AST

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 Language.PureScript.CodeGen.JS.AST where

18+

19+import Language.PureScript.Names

20+import Language.PureScript.Values

21+

22+import Data.Data

23+

24+data JS

25+ = JSNumericLiteral (Either Integer Double)

26+ | JSStringLiteral String

27+ | JSBooleanLiteral Bool

28+ | JSUnary UnaryOperator JS

29+ | JSBinary BinaryOperator JS JS

30+ | JSArrayLiteral [JS]

31+ | JSIndexer JS JS

32+ | JSObjectLiteral [(String, JS)]

33+ | JSAccessor String JS

34+ | JSFunction (Maybe Ident) [Ident] JS

35+ | JSApp JS [JS]

36+ | JSVar Ident

37+ | JSConditional JS JS JS

38+ | JSBlock [JS]

39+ | JSVariableIntroduction Ident (Maybe JS)

40+ | JSAssignment JSAssignment JS

41+ | JSWhile JS JS

42+ | JSFor Ident JS JS JS

43+ | JSIfElse JS JS (Maybe JS)

44+ | JSReturn JS

45+ | JSThrow JS deriving (Show, Data, Typeable)

46+

47+data JSAssignment

48+ = JSAssignVariable Ident

49+ | JSAssignProperty String JSAssignment deriving (Show, Data, Typeable)

src/Language/PureScript/CodeGen/Monad.hsnew file+31

@@ -0,0 +1,31 @@

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

2+--

3+-- Module : Language.PureScript.CodeGen.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 #-}

16+

17+module Language.PureScript.CodeGen.Monad 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/Language/PureScript/Declarations.hsnew file+43

@@ -0,0 +1,43 @@

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

2+--

3+-- Module : Language.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 Language.PureScript.Declarations where

18+

19+import Language.PureScript.Values

20+import Language.PureScript.Types

21+import Language.PureScript.Names

22+import Language.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 ProperName [String] [(ProperName, Maybe PolyType)]

34+ | TypeSynonymDeclaration ProperName [String] PolyType

35+ | TypeDeclaration Ident PolyType

36+ | ValueDeclaration Ident Value

37+ | ExternDeclaration Ident PolyType

38+ | ExternMemberDeclaration String Ident PolyType

39+ | ExternDataDeclaration ProperName Kind

40+ | FixityDeclaration Fixity String

41+ | ModuleDeclaration ProperName [Declaration]

42+ | ImportDeclaration ModulePath (Maybe [Ident])

43+ deriving (Show, D.Data, D.Typeable)

src/Language/PureScript/Kinds.hsnew file+26

@@ -0,0 +1,26 @@

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

2+--

3+-- Module : Language.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 Language.PureScript.Kinds where

18+

19+import Data.Data

20+import Language.PureScript.Unknown

21+

22+data Kind

23+ = KUnknown (Unknown Kind)

24+ | Star

25+ | Row

26+ | FunKind Kind Kind deriving (Show, Eq, Data, Typeable)

src/Language/PureScript/Names.hsnew file+55

@@ -0,0 +1,55 @@

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

2+--

3+-- Module : Language.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 Language.PureScript.Names where

18+

19+import Data.Data

20+import Data.List (inits, intercalate)

21+

22+data Ident = Ident String | Op String deriving (Eq, Ord, Data, Typeable)

23+

24+instance Show Ident where

25+ show (Ident s) = s

26+ show (Op op) = '(':op ++ ")"

27+

28+newtype ProperName = ProperName { runProperName :: String } deriving (Eq, Ord, Data, Typeable)

29+

30+instance Show ProperName where

31+ show = runProperName

32+

33+data ModulePath = ModulePath [ProperName] deriving (Eq, Ord, Data, Typeable)

34+

35+instance Show ModulePath where

36+ show (ModulePath segments) = intercalate "." $ map show segments

37+

38+subModule :: ModulePath -> ProperName -> ModulePath

39+subModule (ModulePath mp) name = ModulePath (mp ++ [name])

40+

41+global :: ModulePath

42+global = ModulePath []

43+

44+data Qualified a = Qualified ModulePath a deriving (Eq, Ord, Data, Typeable)

45+

46+instance (Show a) => Show (Qualified a) where

47+ show (Qualified (ModulePath names) a) = intercalate "." (map show names ++ [show a])

48+

49+qualify :: ModulePath -> Qualified a -> (ModulePath, a)

50+qualify mp (Qualified (ModulePath []) a) = (mp, a)

51+qualify _ (Qualified mp a) = (mp, a)

52+

53+nameResolution :: ModulePath -> Qualified a -> [(ModulePath, a)]

54+nameResolution (ModulePath mp) (Qualified (ModulePath []) a) = [ (ModulePath mp', a) | mp' <- reverse $ inits mp ]

55+nameResolution _ (Qualified mp a) = [(mp, a)]

src/Language/PureScript/Operators.hsnew file+129

@@ -0,0 +1,129 @@

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

2+--

3+-- Module : Language.PureScript.Operators

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 Language.PureScript.Operators (

18+ rebracket

19+) where

20+

21+import Language.PureScript.Names

22+import Language.PureScript.Declarations

23+import Language.PureScript.Values

24+

25+import qualified Data.Data as D

26+import Data.Function (on)

27+import Data.List (groupBy, sortBy)

28+import qualified Data.Map as M

29+import qualified Data.Generics as G

30+import qualified Data.Generics.Extras as G

31+import Control.Monad.State

32+import Control.Applicative

33+import qualified Text.Parsec as P

34+import qualified Text.Parsec.Pos as P

35+import qualified Text.Parsec.Expr as P

36+

37+rebracket :: [Declaration] -> Either String [Declaration]

38+rebracket ds = do

39+ m <- collectFixities ds

40+ let opTable = customOperatorTable m

41+ ds' <- G.everywhereM' (G.mkM (matchOperators opTable)) ds

42+ return $ G.everywhere (G.mkT removeParens) ds'

43+

44+removeParens :: Value -> Value

45+removeParens (Parens val) = val

46+removeParens val = val

47+

48+customOperatorTable :: M.Map (Qualified Ident) Fixity -> [[(Qualified Ident, Value -> Value -> Value, Associativity)]]

49+customOperatorTable fixities =

50+ let

51+ applyUserOp name t1 t2 = App (App (Var name) [t1]) [t2]

52+ userOps = map (\(name, Fixity a p) -> (name, applyUserOp name, p, a)) . M.toList $ fixities

53+ sorted = sortBy (compare `on` (\(_, _, p, _) -> p)) (userOps ++ builtIns)

54+ groups = groupBy ((==) `on` (\(_, _, p, _) -> p)) sorted

55+ in

56+ map (map (\(name, f, _, a) -> (name, f, a))) groups

57+

58+type Chain = [Either Value (Qualified Ident)]

59+

60+matchOperators :: [[(Qualified Ident, Value -> Value -> Value, Associativity)]] -> Value -> Either String Value

61+matchOperators ops val = G.everywhereM' (G.mkM parseChains) val

62+ where

63+ parseChains :: Value -> Either String Value

64+ parseChains b@(BinaryNoParens _ _ _) = bracketChain (extendChain b)

65+ parseChains val = return val

66+ extendChain :: Value -> Chain

67+ extendChain (BinaryNoParens name l r) = Left l : Right name : extendChain r

68+ extendChain val = [Left val]

69+ bracketChain :: Chain -> Either String Value

70+ bracketChain = either (Left . show) Right . P.parse (P.buildExpressionParser opTable parseValue <* P.eof) "operator expression"

71+ opTable = map (map (\(name, f, a) -> P.Infix (P.try (matchOp name) >> return f) (toAssoc a))) ops

72+ ++ [[P.Infix (P.try (parseOp >>= \ident -> return (\t1 t2 -> App (App (Var ident) [t1]) [t2]))) P.AssocLeft]]

73+

74+toAssoc :: Associativity -> P.Assoc

75+toAssoc Infixl = P.AssocLeft

76+toAssoc Infixr = P.AssocRight

77+

78+parseValue :: P.Parsec Chain () Value

79+parseValue = P.token show (const (P.initialPos "")) (either Just (const Nothing)) P.<?> "expression"

80+

81+parseOp :: P.Parsec Chain () (Qualified Ident)

82+parseOp = P.token show (const (P.initialPos "")) (either (const Nothing) Just) P.<?> "operator"

83+

84+matchOp :: Qualified Ident -> P.Parsec Chain () ()

85+matchOp op = do

86+ ident <- parseOp

87+ guard (ident == op)

88+

89+collectFixities :: [Declaration] -> Either String (M.Map (Qualified Ident) Fixity)

90+collectFixities = go M.empty global

91+ where

92+ go :: M.Map (Qualified Ident) Fixity -> ModulePath -> [Declaration] -> Either String (M.Map (Qualified Ident) Fixity)

93+ go m _ [] = return m

94+ go m p (FixityDeclaration fixity name : rest) = do

95+ let qual = Qualified p (Op name)

96+ when (qual `M.member` m) (Left $ "redefined fixity for " ++ show name)

97+ go (M.insert qual fixity m) p rest

98+ go m p (ModuleDeclaration name decls : rest) = do

99+ m' <- go m (subModule p name) decls

100+ go m' p rest

101+ go m p (_:ds) = go m p ds

102+

103+globalOp :: String -> Qualified Ident

104+globalOp = Qualified global . Op

105+

106+builtIns :: [(Qualified Ident, Value -> Value -> Value, Precedence, Associativity)]

107+builtIns = [ (globalOp "<", Binary LessThan, 3, Infixl)

108+ , (globalOp "<=", Binary LessThanOrEqualTo, 3, Infixl)

109+ , (globalOp ">", Binary GreaterThan, 3, Infixl)

110+ , (globalOp ">=", Binary GreaterThanOrEqualTo, 3, Infixl)

111+ , (globalOp "!!", flip Indexer, 4, Infixl)

112+ , (globalOp "*", Binary Multiply, 5, Infixl)

113+ , (globalOp "/", Binary Divide, 5, Infixl)

114+ , (globalOp "%", Binary Modulus, 5, Infixl)

115+ , (globalOp "++", Binary Concat, 6, Infixr)

116+ , (globalOp "+", Binary Add, 7, Infixl)

117+ , (globalOp "-", Binary Subtract, 7, Infixl)

118+ , (globalOp "<<", Binary ShiftLeft, 8, Infixl)

119+ , (globalOp ">>", Binary ShiftRight, 8, Infixl)

120+ , (globalOp ">>>", Binary ZeroFillShiftRight, 8, Infixl)

121+ , (globalOp "==", Binary EqualTo, 9, Infixl)

122+ , (globalOp "!=", Binary NotEqualTo, 9, Infixl)

123+ , (globalOp "&", Binary BitwiseAnd, 10, Infixl)

124+ , (globalOp "^", Binary BitwiseXor, 10, Infixl)

125+ , (globalOp "|", Binary BitwiseOr, 10, Infixl)

126+ , (globalOp "&&", Binary And, 11, Infixr)

127+ , (globalOp "||", Binary Or, 11, Infixr)

128+ ]

129+

src/Language/PureScript/Optimize.hsnew file+95

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

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

2+--

3+-- Module : Language.PureScript.Optimize

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 Language.PureScript.Optimize (

16+ optimize

17+) where

18+

19+import Data.Data

20+import Data.Generics

21+

22+import Language.PureScript.Names

23+import Language.PureScript.CodeGen.JS.AST

24+

25+optimize :: JS -> JS

26+optimize = removeUnusedVariables . unThunk . etaConvert . inlineVariables

27+

28+replaceIdent :: (Data d) => Ident -> JS -> d -> d

29+replaceIdent var1 js = everywhere (mkT replace)

30+ where

31+ replace (JSVar var2) | var1 == var2 = js

32+ replace js = js

33+

34+isReassigned :: (Data d) => Ident -> d -> Bool

35+isReassigned var1 = everything (||) (mkQ False check)

36+ where

37+ check :: JS -> Bool

38+ check (JSAssignment (JSAssignVariable var2) _) | var1 == var2 = True

39+ check _ = False

40+

41+isUsed :: (Data d) => Ident -> d -> Bool

42+isUsed var1 = everything (||) (mkQ False check)

43+ where

44+ check :: JS -> Bool

45+ check (JSVar var2) | var1 == var2 = True

46+ check (JSAssignment target _) | var1 == targetVariable target = True

47+ check _ = False

48+ targetVariable :: JSAssignment -> Ident

49+ targetVariable (JSAssignVariable var) = var

50+ targetVariable (JSAssignProperty _ tgt) = targetVariable tgt

51+

52+shouldInline :: JS -> Bool

53+shouldInline (JSVar _) = True

54+shouldInline (JSNumericLiteral _) = True

55+shouldInline (JSStringLiteral _) = True

56+shouldInline (JSBooleanLiteral _) = True

57+shouldInline (JSAccessor _ val) = shouldInline val

58+shouldInline (JSIndexer index val) = shouldInline index && shouldInline val

59+shouldInline _ = False

60+

61+inlineVariables :: JS -> JS

62+inlineVariables = everywhere (mkT removeFromBlock)

63+ where

64+ removeFromBlock :: JS -> JS

65+ removeFromBlock (JSBlock sts) = JSBlock (go sts)

66+ removeFromBlock js = js

67+ go :: [JS] -> [JS]

68+ go [] = []

69+ go (JSVariableIntroduction var (Just js) : sts) | shouldInline js && not (isReassigned var sts) = go (replaceIdent var js sts)

70+ go (s:sts) = s : go sts

71+

72+removeUnusedVariables :: JS -> JS

73+removeUnusedVariables = everywhere (mkT removeFromBlock)

74+ where

75+ removeFromBlock :: JS -> JS

76+ removeFromBlock (JSBlock sts) = JSBlock (go sts)

77+ removeFromBlock js = js

78+ go :: [JS] -> [JS]

79+ go [] = []

80+ go (JSVariableIntroduction var _ : sts) | not (isUsed var sts) = go sts

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

82+

83+etaConvert :: JS -> JS

84+etaConvert = everywhere (mkT convert)

85+ where

86+ convert :: JS -> JS

87+ convert (JSBlock [JSReturn (JSApp (JSFunction Nothing [ident] (JSBlock body)) [arg])]) | shouldInline arg = JSBlock (replaceIdent ident arg body)

88+ convert js = js

89+

90+unThunk :: JS -> JS

91+unThunk = everywhere (mkT convert)

92+ where

93+ convert :: JS -> JS

94+ convert (JSBlock [JSReturn (JSApp (JSFunction Nothing [] (JSBlock body)) [])]) = JSBlock body

95+ convert js = js

src/Language/PureScript/Parser.hsnew file+22

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

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

2+--

3+-- Module : Language.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 Language.PureScript.Parser (module P) where

16+

17+import Language.PureScript.Parser.Common as P

18+import Language.PureScript.Parser.Types as P

19+import Language.PureScript.Parser.Values as P

20+import Language.PureScript.Parser.State as P

21+import Language.PureScript.Parser.Kinds as P

22+import Language.PureScript.Parser.Declarations as P

src/Language/PureScript/Parser/Common.hsnew file+211

@@ -0,0 +1,211 @@

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

2+--

3+-- Module : Language.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 Language.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 Language.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 Language.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+ , "foreign"

48+ , "import"

49+ , "member"

50+ , "forall"

51+ , "do"

52+ , "until"

53+ , "in"

54+ , "break"

55+ , "catch"

56+ , "continue"

57+ , "debugger"

58+ , "default"

59+ , "delete"

60+ , "finally"

61+ , "function"

62+ , "instanceof"

63+ , "new"

64+ , "switch"

65+ , "this"

66+ , "throw"

67+ , "try"

68+ , "typeof"

69+ , "void"

70+ , "with"

71+ , "Number"

72+ , "String"

73+ , "Boolean"

74+ , "infixl"

75+ , "infixr"

76+ , "module" ]

77+

78+builtInOperators :: [String]

79+builtInOperators = [ "~", "-", "<=", ">=", "<", ">", "*", "/", "%", "++", "+", "<<", ">>>", ">>"

80+ , "==", "!=", "&&", "||", "&", "^", "|", "!!", "!" ]

81+

82+reservedOpNames :: [String]

83+reservedOpNames = builtInOperators ++ [ "->" ]

84+

85+identStart :: P.Parsec String u Char

86+identStart = P.lower <|> P.oneOf "_$"

87+

88+properNameStart :: P.Parsec String u Char

89+properNameStart = P.upper

90+

91+identLetter :: P.Parsec String u Char

92+identLetter = P.alphaNum <|> P.oneOf "_'"

93+

94+opStart :: P.Parsec String u Char

95+opStart = P.oneOf "!#$%&*+/<=>?@^|~"

96+

97+opLetter :: P.Parsec String u Char

98+opLetter = P.oneOf ":#$%&*+./<=>?@^|"

99+

100+langDef = PT.LanguageDef

101+ { PT.reservedNames = reservedNames

102+ , PT.reservedOpNames = reservedOpNames

103+ , PT.commentStart = "{-"

104+ , PT.commentEnd = "-}"

105+ , PT.commentLine = "--"

106+ , PT.nestedComments = True

107+ , PT.identStart = identStart

108+ , PT.identLetter = identLetter

109+ , PT.opStart = opStart

110+ , PT.opLetter = opLetter

111+ , PT.caseSensitive = True

112+ }

113+

114+tokenParser = PT.makeTokenParser langDef

115+

116+lexeme = PT.lexeme tokenParser

117+identifier = PT.identifier tokenParser

118+reserved = PT.reserved tokenParser

119+reservedOp = PT.reservedOp tokenParser

120+operator = PT.operator tokenParser

121+stringLiteral = PT.stringLiteral tokenParser

122+whiteSpace = PT.whiteSpace tokenParser

123+squares = PT.squares tokenParser

124+semi = PT.semi tokenParser

125+comma = PT.comma tokenParser

126+colon = PT.colon tokenParser

127+dot = PT.dot tokenParser

128+natural = PT.natural tokenParser

129+

130+parens = P.between (lexeme $ P.char '(') (lexeme $ indented *> P.char ')') . (indented *>)

131+braces = P.between (lexeme $ P.char '{') (lexeme $ indented *> P.char '}') . (indented *>)

132+angles = P.between (lexeme $ P.char '<') (lexeme $ indented *> P.char '>') . (indented *>)

133+

134+sepBy p s = P.sepBy (indented *> p) (indented *> s)

135+sepBy1 p s = P.sepBy1 (indented *> p) (indented *> s)

136+

137+semiSep = flip sepBy semi

138+semiSep1 = flip sepBy1 semi

139+commaSep = flip sepBy comma

140+commaSep1 = flip sepBy1 comma

141+

142+tick = lexeme $ P.char '`'

143+pipe = lexeme $ P.char '|'

144+

145+properName :: P.Parsec String u ProperName

146+properName = lexeme $ ProperName <$> P.try ((:) <$> P.upper <*> many (PT.identLetter langDef) P.<?> "name")

147+

148+parseQualified :: P.Parsec String ParseState a -> P.Parsec String ParseState (Qualified a)

149+parseQualified parser = part global

150+ where

151+ part path = (do name <- P.try (properName <* delimiter)

152+ part (subModule path name))

153+ <|> (Qualified path <$> P.try parser)

154+ delimiter = indented *> dot

155+

156+integerOrFloat :: P.Parsec String u (Either Integer Double)

157+integerOrFloat = (Left <$> P.try (PT.natural tokenParser) <|>

158+ Right <$> P.try (PT.float tokenParser)) P.<?> "number"

159+

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

161+augment p q f = flip (maybe id $ flip f) <$> p <*> P.optionMaybe q

162+

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

164+fold first more combine = do

165+ a <- first

166+ bs <- P.many more

167+ return $ foldl combine a bs

168+

169+buildPostfixParser :: P.Stream s m t => [a -> P.ParsecT s u m a] -> P.ParsecT s u m a -> P.ParsecT s u m a

170+buildPostfixParser fs first = do

171+ a <- first

172+ go a

173+ where

174+ go a = do

175+ maybeA <- P.optionMaybe $ P.choice (map ($ a) fs)

176+ case maybeA of

177+ Nothing -> return a

178+ Just a' -> go a'

179+

180+operatorOrBuiltIn :: P.Parsec String u String

181+operatorOrBuiltIn = P.try operator <|> P.choice (map (\s -> P.try (reservedOp s) >> return s) builtInOperators)

182+

183+parseIdent :: P.Parsec String ParseState Ident

184+parseIdent = (Ident <$> identifier) <|> (Op <$> parens operatorOrBuiltIn)

185+

186+parseIdentInfix :: P.Parsec String ParseState (Qualified Ident)

187+parseIdentInfix = (P.between tick tick (parseQualified (Ident <$> identifier))) <|> parseQualified (Op <$> operatorOrBuiltIn)

188+

189+mark :: P.Parsec String ParseState a -> P.Parsec String ParseState a

190+mark p = do

191+ current <- indentationLevel <$> P.getState

192+ pos <- P.sourceColumn <$> P.getPosition

193+ P.modifyState $ \st -> st { indentationLevel = pos }

194+ a <- p

195+ P.modifyState $ \st -> st { indentationLevel = current }

196+ return a

197+

198+checkIndentation :: (P.Column -> P.Column -> Bool) -> P.Parsec String ParseState ()

199+checkIndentation rel = do

200+ col <- P.sourceColumn <$> P.getPosition

201+ current <- indentationLevel <$> P.getState

202+ guard (col `rel` current)

203+

204+indented :: P.Parsec String ParseState ()

205+indented = checkIndentation (>) P.<?> "indentation"

206+

207+same :: P.Parsec String ParseState ()

208+same = checkIndentation (==) P.<?> "no indentation"

209+

210+runIndentParser :: P.Parsec String ParseState a -> String -> Either P.ParseError a

211+runIndentParser p = P.runParser p (ParseState 0) ""

src/Language/PureScript/Parser/Declarations.hsnew file+123

@@ -0,0 +1,123 @@

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

2+--

3+-- Module : Language.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 Language.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 Language.PureScript.Names

32+import Language.PureScript.Values

33+import Language.PureScript.Types

34+import Language.PureScript.Parser.State

35+import Language.PureScript.Parser.Common

36+import Language.PureScript.Declarations

37+import Language.PureScript.Parser.Values

38+import Language.PureScript.Parser.Types

39+import Language.PureScript.Parser.Kinds

40+

41+parseDataDeclaration :: P.Parsec String ParseState Declaration

42+parseDataDeclaration = do

43+ reserved "data"

44+ name <- indented *> properName

45+ tyArgs <- many (indented *> identifier)

46+ lexeme $ indented *> P.char '='

47+ ctors <- sepBy1 ((,) <$> properName <*> P.optionMaybe (indented *> parsePolyType)) pipe

48+ return $ DataDeclaration name tyArgs ctors

49+

50+parseTypeDeclaration :: P.Parsec String ParseState Declaration

51+parseTypeDeclaration =

52+ TypeDeclaration <$> P.try (parseIdent <* lexeme (indented *> P.string "::"))

53+ <*> parsePolyType

54+

55+parseTypeSynonymDeclaration :: P.Parsec String ParseState Declaration

56+parseTypeSynonymDeclaration =

57+ TypeSynonymDeclaration <$> (P.try (reserved "type") *> indented *> properName)

58+ <*> many (indented *> identifier)

59+ <*> (lexeme (indented *> P.char '=') *> parsePolyType)

60+

61+parseValueDeclaration :: P.Parsec String ParseState Declaration

62+parseValueDeclaration =

63+ ValueDeclaration <$> P.try (parseIdent <* lexeme (indented *> P.char '='))

64+ <*> parseValue

65+

66+parseExternDeclaration :: P.Parsec String ParseState Declaration

67+parseExternDeclaration = P.try (reserved "foreign") *> indented *> (reserved "import") *> indented *>

68+ (ExternDataDeclaration <$> (P.try (reserved "data") *> indented *> properName)

69+ <*> (lexeme (indented *> P.string "::") *> parseKind)

70+ <|> ExternDeclaration <$> parseIdent

71+ <*> (lexeme (indented *> P.string "::") *> parsePolyType)

72+ <|> ExternMemberDeclaration <$> (P.try (reserved "member") *> indented *> stringLiteral)

73+ <*> (indented *> parseIdent)

74+ <*> (lexeme (indented *> P.string "::") *> parsePolyType))

75+

76+parseAssociativity :: P.Parsec String ParseState Associativity

77+parseAssociativity =

78+ (P.try (reserved "infixl") >> return Infixl) <|>

79+ (P.try (reserved "infixr") >> return Infixr)

80+

81+parseFixity :: P.Parsec String ParseState Fixity

82+parseFixity = Fixity <$> parseAssociativity <*> (indented *> natural)

83+

84+parseFixityDeclaration :: P.Parsec String ParseState Declaration

85+parseFixityDeclaration = do

86+ fixity <- parseFixity

87+ indented

88+ name <- operator

89+ return $ FixityDeclaration fixity name

90+

91+parseModuleDeclaration :: P.Parsec String ParseState Declaration

92+parseModuleDeclaration = do

93+ reserved "module"

94+ indented

95+ name <- properName

96+ lexeme $ P.string "where"

97+ decls <- mark (P.many (same *> parseDeclaration))

98+ return $ ModuleDeclaration name decls

99+

100+parseModulePath :: P.Parsec String ParseState ModulePath

101+parseModulePath = ModulePath <$> properName `sepBy1` dot

102+

103+parseImportDeclaration :: P.Parsec String ParseState Declaration

104+parseImportDeclaration = do

105+ reserved "import"

106+ indented

107+ modulePath <- parseModulePath

108+ idents <- P.optionMaybe $ parens $ commaSep1 parseIdent

109+ return $ ImportDeclaration modulePath idents

110+

111+parseDeclaration :: P.Parsec String ParseState Declaration

112+parseDeclaration = P.choice

113+ [ parseDataDeclaration

114+ , parseTypeDeclaration

115+ , parseTypeSynonymDeclaration

116+ , parseValueDeclaration

117+ , parseExternDeclaration

118+ , parseFixityDeclaration

119+ , parseModuleDeclaration

120+ , parseImportDeclaration ] P.<?> "declaration"

121+

122+parseDeclarations :: P.Parsec String ParseState [Declaration]

123+parseDeclarations = whiteSpace *> mark (P.many (same *> parseDeclaration)) <* P.eof

src/Language/PureScript/Parser/Kinds.hsnew file+41

@@ -0,0 +1,41 @@

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

2+--

3+-- Module : Language.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 Language.PureScript.Parser.Kinds (

16+ parseKind

17+) where

18+

19+import Language.PureScript.Kinds

20+import Language.PureScript.Parser.State

21+import Language.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/Language/PureScript/Parser/State.hsnew file+26

@@ -0,0 +1,26 @@

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

2+--

3+-- Module : Language.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 Language.PureScript.Parser.State where

16+

17+import Language.PureScript.Names

18+import Language.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 } deriving Show

25+

26+

src/Language/PureScript/Parser/Types.hsnew file+105

@@ -0,0 +1,105 @@

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

2+--

3+-- Module : Language.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 Language.PureScript.Parser.Types (

16+ parseType,

17+ parsePolyType,

18+ parseRow

19+) where

20+

21+import Language.PureScript.Types

22+import Language.PureScript.Parser.State

23+import Language.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+import Control.Monad (unless)

29+

30+parseNumber :: P.Parsec String ParseState Type

31+parseNumber = const Number <$> reserved "Number"

32+

33+parseString :: P.Parsec String ParseState Type

34+parseString = const String <$> reserved "String"

35+

36+parseBoolean :: P.Parsec String ParseState Type

37+parseBoolean = const Boolean <$> reserved "Boolean"

38+

39+parseArray :: P.Parsec String ParseState Type

40+parseArray = squares $ Array <$> parseType

41+

42+parseObject :: P.Parsec String ParseState Type

43+parseObject = braces $ Object <$> parseRow

44+

45+parseFunction :: P.Parsec String ParseState Type

46+parseFunction = do

47+ args <- lexeme $ parens $ commaSep parsePolyType

48+ lexeme $ P.string "->"

49+ resultType <- parseType

50+ return $ Function args resultType

51+

52+parseTypeVariable :: P.Parsec String ParseState Type

53+parseTypeVariable = TypeVar <$> identifier

54+

55+parseTypeConstructor :: P.Parsec String ParseState Type

56+parseTypeConstructor = TypeConstructor <$> parseQualified properName

57+

58+parseForAll :: P.Parsec String ParseState Type

59+parseForAll = (mkForAll <$> (P.try (reserved "forall") *> P.many1 (indented *> identifier) <* indented <* dot)

60+ <*> parseType)

61+

62+parseTypeAtom :: P.Parsec String ParseState Type

63+parseTypeAtom = indented *> P.choice (map P.try

64+ [ parseNumber

65+ , parseString

66+ , parseBoolean

67+ , parseArray

68+ , parseObject

69+ , parseFunction

70+ , parseTypeVariable

71+ , parseTypeConstructor

72+ , parseForAll

73+ , parens parseType ])

74+

75+parseAnyType :: P.Parsec String ParseState Type

76+parseAnyType = (P.buildExpressionParser operators . buildPostfixParser postfixTable $ parseTypeAtom) P.<?> "type"

77+ where

78+ postfixTable :: [Type -> P.Parsec String ParseState Type]

79+ postfixTable = [ \x -> TypeApp x <$> P.try (indented *> parseTypeAtom) ]

80+ operators = [ [ P.Infix (lexeme (P.try (P.string "->")) >> return (\t1 t2 -> Function [t1] t2)) P.AssocRight ] ]

81+

82+parseType :: P.Parsec String ParseState Type

83+parseType = do

84+ ty <- parseAnyType

85+ unless (isMonoType ty) $ P.unexpected "polymorphic type"

86+ return ty

87+

88+parsePolyType :: P.Parsec String ParseState PolyType

89+parsePolyType = do

90+ ty <- parseAnyType

91+ unless (isPolyType ty) $ P.unexpected "polymorphic type"

92+ return ty

93+

94+parseNameAndType :: P.Parsec String ParseState (String, Type)

95+parseNameAndType = (,) <$> (indented *> identifier <* indented <* lexeme (P.string "::")) <*> parsePolyType

96+

97+parseRowEnding :: P.Parsec String ParseState Row

98+parseRowEnding = P.option REmpty (RowVar <$> (lexeme (indented *> P.char '|') *> indented *> identifier))

99+

100+parseRow :: P.Parsec String ParseState Row

101+parseRow = (fromList <$> (commaSep parseNameAndType) <*> parseRowEnding) P.<?> "row"

102+ where

103+ fromList :: [(String, Type)] -> Row -> Row

104+ fromList [] r = r

105+ fromList ((name, t):ts) r = RCons name t (fromList ts r)

src/Language/PureScript/Parser/Values.hsnew file+263

@@ -0,0 +1,263 @@

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

2+--

3+-- Module : Language.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 Language.PureScript.Parser.Values (

16+ parseValue,

17+ parseBinder

18+) where

19+

20+import Language.PureScript.Values

21+import Language.PureScript.Names

22+import Language.PureScript.Declarations

23+import Language.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 Language.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 Language.PureScript.Parser.Types

35+import Language.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 (C.commaSep parseValue)

51+

52+parseObjectLiteral :: P.Parsec String ParseState Value

53+parseObjectLiteral = ObjectLiteral <$> C.braces (C.commaSep parseIdentifierAndValue)

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 <- P.many (C.indented *> (P.try singleArg <|> manyArgs))

63+ C.lexeme $ C.indented *> P.string "->"

64+ value <- parseValue

65+ return $ toFunction args value

66+ where

67+ manyArgs :: P.Parsec String ParseState (Value -> Value)

68+ manyArgs = do

69+ args <- C.parens (C.commaSep C.parseIdent)

70+ return $ Abs args

71+ singleArg :: P.Parsec String ParseState (Value -> Value)

72+ singleArg = Abs . return <$> C.parseIdent

73+ toFunction :: [Value -> Value] -> Value -> Value

74+ toFunction [] value = Abs [] value

75+ toFunction args value = foldr (($)) value args

76+

77+parseApp :: P.Parsec String ParseState Value

78+parseApp = App <$> parseValue

79+ <*> (C.indented *> C.parens (C.commaSep parseValue))

80+

81+parseVar :: P.Parsec String ParseState Value

82+parseVar = Var <$> C.parseQualified C.parseIdent

83+

84+parseConstructor :: P.Parsec String ParseState Value

85+parseConstructor = Constructor <$> C.parseQualified C.properName

86+

87+parseCase :: P.Parsec String ParseState Value

88+parseCase = Case <$> P.between (P.try (C.reserved "case")) (C.indented *> C.reserved "of") parseValue

89+ <*> (C.indented *> C.mark (P.many (C.same *> C.mark parseCaseAlternative)))

90+

91+parseCaseAlternative :: P.Parsec String ParseState (Binder, Value)

92+parseCaseAlternative = (,) <$> (parseGuardedBinder <* C.lexeme (P.string "->"))

93+ <*> parseValue

94+ P.<?> "case alternative"

95+

96+parseIfThenElse :: P.Parsec String ParseState Value

97+parseIfThenElse = IfThenElse <$> (P.try (C.reserved "if") *> C.indented *> parseValue)

98+ <*> (C.indented *> C.reserved "then" *> C.indented *> parseValue)

99+ <*> (C.indented *> C.reserved "else" *> C.indented *> parseValue)

100+

101+parseBlock :: P.Parsec String ParseState Value

102+parseBlock = Block <$> (P.try (C.reserved "do") *> parseManyStatements)

103+

104+parseManyStatements :: P.Parsec String ParseState [Statement]

105+parseManyStatements = C.indented *> C.mark (P.many (C.same *> C.mark parseStatement)) P.<?> "block"

106+

107+parseValueAtom :: P.Parsec String ParseState Value

108+parseValueAtom = C.indented *> P.choice

109+ [ P.try parseNumericLiteral

110+ , P.try parseStringLiteral

111+ , P.try parseBooleanLiteral

112+ , parseArrayLiteral

113+ , parseObjectLiteral

114+ , parseAbs

115+ , P.try parseConstructor

116+ , P.try parseVar

117+ , parseBlock

118+ , parseCase

119+ , parseIfThenElse

120+ , Parens <$> C.parens parseValue ]

121+

122+parsePropertyUpdate :: P.Parsec String ParseState (String, Value)

123+parsePropertyUpdate = do

124+ name <- C.lexeme C.identifier

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

126+ value <- C.indented *> parseValue

127+ return (name, value)

128+

129+parseAccessor :: Value -> P.Parsec String ParseState Value

130+parseAccessor (Constructor _) = P.unexpected "constructor"

131+parseAccessor obj = Accessor <$> (C.indented *> C.dot *> C.indented *> C.identifier) <*> pure obj

132+

133+parseValue :: P.Parsec String ParseState Value

134+parseValue =

135+ (buildExpressionParser operators

136+ . C.buildPostfixParser postfixTable2

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

138+ where

139+ indexersAndAccessors = C.buildPostfixParser postfixTable1 parseValueAtom

140+ postfixTable1 = [ parseAccessor

141+ , \v -> P.try $ flip ObjectUpdate <$> (C.indented *> C.braces (C.commaSep1 (C.indented *> parsePropertyUpdate))) <*> pure v ]

142+ postfixTable2 = [ \v -> P.try (C.indented *> indexersAndAccessors >>= \t2 -> return (\t1 -> App t1 [t2])) <*> pure v

143+ , \v -> P.try $ flip App <$> (C.indented *> C.parens (C.commaSep parseValue)) <*> pure v

144+ , \v -> flip TypedValue <$> (P.try (C.lexeme (C.indented *> P.string "::")) *> parsePolyType) <*> pure v ]

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

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

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

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

149+ , [ Infix (C.lexeme (P.try (C.indented *> C.parseIdentInfix P.<?> "operator") >>= \ident ->

150+ return (BinaryNoParens ident))) AssocRight ]

151+ ]

152+

153+parseVariableIntroduction :: P.Parsec String ParseState Statement

154+parseVariableIntroduction = do

155+ C.reserved "var"

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

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

158+ value <- parseValue

159+ return $ VariableIntroduction name value

160+

161+parseAssignment :: P.Parsec String ParseState Statement

162+parseAssignment = do

163+ tgt <- C.parseIdent

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

165+ value <- parseValue

166+ return $ Assignment tgt value

167+

168+parseWhile :: P.Parsec String ParseState Statement

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

170+ <*> parseManyStatements

171+

172+parseFor :: P.Parsec String ParseState Statement

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

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

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

176+ <*> parseManyStatements

177+

178+parseForEach :: P.Parsec String ParseState Statement

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

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

181+ <*> parseManyStatements

182+

183+parseIf :: P.Parsec String ParseState Statement

184+parseIf = If <$> parseIfStatement

185+

186+parseIfStatement :: P.Parsec String ParseState IfStatement

187+parseIfStatement =

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

189+ <*> parseManyStatements

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

191+

192+parseElseStatement :: P.Parsec String ParseState ElseStatement

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

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

195+

196+parseReturn :: P.Parsec String ParseState Statement

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

198+

199+parseStatement :: P.Parsec String ParseState Statement

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

201+ [ parseVariableIntroduction

202+ , parseAssignment

203+ , parseWhile

204+ , parseFor

205+ , parseForEach

206+ , parseIf

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

208+

209+parseStringBinder :: P.Parsec String ParseState Binder

210+parseStringBinder = StringBinder <$> C.stringLiteral

211+

212+parseBooleanBinder :: P.Parsec String ParseState Binder

213+parseBooleanBinder = BooleanBinder <$> booleanLiteral

214+

215+parseNumberBinder :: P.Parsec String ParseState Binder

216+parseNumberBinder = NumberBinder <$> C.integerOrFloat

217+

218+parseVarBinder :: P.Parsec String ParseState Binder

219+parseVarBinder = VarBinder <$> C.parseIdent

220+

221+parseNullaryBinder :: P.Parsec String ParseState Binder

222+parseNullaryBinder = NullaryBinder <$> C.lexeme (C.parseQualified C.properName)

223+

224+parseUnaryBinder :: P.Parsec String ParseState Binder

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

226+

227+parseObjectBinder :: P.Parsec String ParseState Binder

228+parseObjectBinder = ObjectBinder <$> C.braces (C.commaSep (C.indented *> parseIdentifierAndBinder))

229+

230+parseArrayBinder :: P.Parsec String ParseState Binder

231+parseArrayBinder = C.squares $ ArrayBinder <$> (C.commaSep (C.indented *> parseBinder))

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

233+

234+parseNamedBinder :: P.Parsec String ParseState Binder

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

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

237+

238+parseNullBinder :: P.Parsec String ParseState Binder

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

240+

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

242+parseIdentifierAndBinder = do

243+ name <- C.lexeme C.identifier

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

245+ binder <- C.indented *> parseBinder

246+ return (name, binder)

247+

248+parseBinder :: P.Parsec String ParseState Binder

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

250+ [ parseNullBinder

251+ , parseStringBinder

252+ , parseBooleanBinder

253+ , parseNumberBinder

254+ , parseNamedBinder

255+ , parseVarBinder

256+ , parseUnaryBinder

257+ , parseNullaryBinder

258+ , parseObjectBinder

259+ , parseArrayBinder

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

261+

262+parseGuardedBinder :: P.Parsec String ParseState Binder

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

src/Language/PureScript/Pretty.hsnew file+23

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

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

2+--

3+-- Module : Language.PureScript.Pretty

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 Language.PureScript.Pretty (module P) where

16+

17+import Language.PureScript.Pretty.Kinds as P

18+import Language.PureScript.Pretty.Values as P

19+import Language.PureScript.Pretty.Types as P

20+import Language.PureScript.Pretty.JS as P

21+

22+

23+

src/Language/PureScript/Pretty/Common.hsnew file+86

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

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

2+--

3+-- Module : Language.PureScript.Pretty.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 Language.PureScript.Pretty.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 Language.PureScript.Names

31+import Language.PureScript.Values

32+import Language.PureScript.Types

33+import Language.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 u a b = Pattern { runPattern :: A.Kleisli (StateT u Maybe) a b } deriving (C.Category, A.Arrow, A.ArrowZero, A.ArrowPlus)

43+

44+instance Functor (Pattern u a) where

45+ fmap f (Pattern p) = Pattern $ A.Kleisli $ fmap f . A.runKleisli p

46+

47+pattern :: Pattern u a b -> u -> a -> Maybe b

48+pattern p u = flip evalStateT u . A.runKleisli (runPattern p)

49+

50+mkPattern :: (a -> Maybe b) -> Pattern u a b

51+mkPattern f = Pattern $ A.Kleisli (lift . f)

52+

53+mkPattern' :: (a -> StateT u Maybe b) -> Pattern u a b

54+mkPattern' = Pattern . A.Kleisli

55+

56+parens :: String -> String

57+parens s = ('(':s) ++ ")"

58+

59+chainl :: Pattern u a (a, a) -> (r -> r -> r) -> Pattern u a r -> Pattern u a r

60+chainl split f p = fix $ \c -> split >>> ((c <+> p) *** p) >>> A.arr (uncurry f)

61+

62+chainr :: Pattern u a (a, a) -> (r -> r -> r) -> Pattern u a r -> Pattern u a r

63+chainr split f p = fix $ \c -> split >>> (p *** (c <+> p)) >>> A.arr (uncurry f)

64+

65+wrap :: Pattern u a (s, a) -> (s -> r -> r) -> Pattern u a r -> Pattern u a r

66+wrap split f p = fix $ \c -> split >>> (C.id *** (c <+> p)) >>> A.arr (uncurry f)

67+

68+split :: Pattern u a (s, t) -> (s -> t -> r) -> Pattern u a r -> Pattern u a r

69+split s f p = s >>> A.arr (uncurry f)

70+

71+data OperatorTable u a r = OperatorTable { runOperatorTable :: [ [Operator u a r] ] }

72+

73+data Operator u a r where

74+ AssocL :: Pattern u a (a, a) -> (r -> r -> r) -> Operator u a r

75+ AssocR :: Pattern u a (a, a) -> (r -> r -> r) -> Operator u a r

76+ Wrap :: Pattern u a (s, a) -> (s -> r -> r) -> Operator u a r

77+ Split :: Pattern u a (s, t) -> (s -> t -> r) -> Operator u a r

78+

79+buildPrettyPrinter :: OperatorTable u a r -> Pattern u a r -> Pattern u a r

80+buildPrettyPrinter table p = foldl (\p' ops -> foldl1 (<+>) (flip map ops $ \op ->

81+ case op of

82+ AssocL pat g -> chainl pat g p'

83+ AssocR pat g -> chainr pat g p'

84+ Wrap pat g -> wrap pat g p'

85+ Split pat g -> split pat g p'

86+ ) <+> p') p $ runOperatorTable table

src/Language/PureScript/Pretty/JS.hsnew file+225

@@ -0,0 +1,225 @@

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

2+--

3+-- Module : Language.PureScript.Pretty.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 Language.PureScript.Pretty.JS (

16+ prettyPrintJS

17+) where

18+

19+import Language.PureScript.Names

20+import Language.PureScript.Values

21+import Language.PureScript.Pretty.Common

22+import Language.PureScript.CodeGen.JS.AST

23+

24+import Data.List

25+import Data.Maybe (fromMaybe)

26+import qualified Control.Arrow as A

27+import Control.Arrow ((***), (<+>), first, second)

28+import Control.Applicative

29+import Control.Monad.State

30+

31+newtype PrinterState = PrinterState { indent :: Int } deriving (Show, Eq, Ord)

32+

33+blockIndent :: Int

34+blockIndent = 4

35+

36+withIndent :: StateT PrinterState Maybe String -> StateT PrinterState Maybe String

37+withIndent s = do

38+ current <- get

39+ modify $ \s -> s { indent = indent s + blockIndent }

40+ result <- s

41+ modify $ \s -> s { indent = indent s - blockIndent }

42+ return result

43+

44+currentIndent :: StateT PrinterState Maybe String

45+currentIndent = do

46+ current <- get

47+ return $ replicate (indent current) ' '

48+

49+literals :: Pattern PrinterState JS String

50+literals = mkPattern' match

51+ where

52+ match :: JS -> StateT PrinterState Maybe String

53+ match (JSNumericLiteral n) = return $ either show show n

54+ match (JSStringLiteral s) = return $ show s

55+ match (JSBooleanLiteral True) = return "true"

56+ match (JSBooleanLiteral False) = return "false"

57+ match (JSArrayLiteral xs) = fmap concat $ sequence

58+ [ return "[ "

59+ , fmap (intercalate ", ") $ forM xs prettyPrintJS'

60+ , return " ]"

61+ ]

62+ match (JSObjectLiteral ps) = fmap concat $ sequence

63+ [ return "{\n"

64+ , withIndent $ do

65+ jss <- forM ps $ \(key, value) -> fmap ((key ++ ": ") ++) . prettyPrintJS' $ value

66+ indentString <- currentIndent

67+ return $ intercalate ", \n" $ map (indentString ++) jss

68+ , return "\n"

69+ , currentIndent

70+ , return "}"

71+ ]

72+ match (JSBlock sts) = fmap concat $ sequence

73+ [ return "{\n"

74+ , withIndent $ do

75+ jss <- forM sts prettyPrintJS'

76+ indentString <- currentIndent

77+ return $ intercalate "\n" $ map (++ "; ") $ map (indentString ++) jss

78+ , return "\n"

79+ , currentIndent

80+ , return "}"

81+ ]

82+ match (JSVar ident) = return (identToJs ident)

83+ match (JSVariableIntroduction ident value) = fmap concat $ sequence

84+ [ return "var "

85+ , return $ identToJs ident

86+ , maybe (return "") (fmap (" = " ++) . prettyPrintJS') value

87+ ]

88+ match (JSAssignment target value) = fmap concat $ sequence

89+ [ return $ targetToJs target

90+ , return " = "

91+ , prettyPrintJS' value

92+ ]

93+ match (JSWhile cond sts) = fmap concat $ sequence

94+ [ return "while ("

95+ , prettyPrintJS' cond

96+ , return ") "

97+ , prettyPrintJS' sts

98+ ]

99+ match (JSFor ident start end sts) = fmap concat $ sequence

100+ [ return $ "for (" ++ identToJs ident ++ " = "

101+ , prettyPrintJS' start

102+ , return $ "; " ++ identToJs ident ++ " < "

103+ , prettyPrintJS' end

104+ , return $ "; " ++ identToJs ident ++ "++) "

105+ , prettyPrintJS' sts

106+ ]

107+ match (JSIfElse cond thens elses) = fmap concat $ sequence

108+ [ return "if ("

109+ , prettyPrintJS' cond

110+ , return ") "

111+ , prettyPrintJS' thens

112+ , maybe (return "") (fmap (" else " ++) . prettyPrintJS') elses

113+ ]

114+ match (JSReturn value) = fmap concat $ sequence

115+ [ return "return "

116+ , prettyPrintJS' value

117+ ]

118+ match (JSThrow value) = fmap concat $ sequence

119+ [ return "throw "

120+ , prettyPrintJS' value

121+ ]

122+ match _ = mzero

123+

124+targetToJs :: JSAssignment -> String

125+targetToJs (JSAssignVariable ident) = identToJs ident

126+targetToJs (JSAssignProperty prop target) = targetToJs target ++ "." ++ prop

127+

128+conditional :: Pattern PrinterState JS ((JS, JS), JS)

129+conditional = mkPattern match

130+ where

131+ match (JSConditional cond th el) = Just ((th, el), cond)

132+ match _ = Nothing

133+

134+accessor :: Pattern PrinterState JS (String, JS)

135+accessor = mkPattern match

136+ where

137+ match (JSAccessor prop val) = Just (prop, val)

138+ match _ = Nothing

139+

140+indexer :: Pattern PrinterState JS (String, JS)

141+indexer = mkPattern' match

142+ where

143+ match (JSIndexer index val) = (,) <$> prettyPrintJS' index <*> pure val

144+ match _ = mzero

145+

146+lam :: Pattern PrinterState JS ((Maybe Ident, [Ident]), JS)

147+lam = mkPattern match

148+ where

149+ match (JSFunction name args ret) = Just ((name, args), ret)

150+ match _ = Nothing

151+

152+app :: Pattern PrinterState JS (String, JS)

153+app = mkPattern' match

154+ where

155+ match (JSApp val args) = do

156+ jss <- mapM prettyPrintJS' args

157+ return (intercalate ", " jss, val)

158+ match _ = mzero

159+

160+unary :: UnaryOperator -> String -> Operator PrinterState JS String

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

162+ where

163+ pattern :: Pattern PrinterState JS (String, JS)

164+ pattern = mkPattern match

165+ where

166+ match (JSUnary op' val) | op' == op = Just (str, val)

167+ match _ = Nothing

168+

169+binary :: BinaryOperator -> String -> Operator PrinterState JS String

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

171+ where

172+ pattern :: Pattern PrinterState JS (JS, JS)

173+ pattern = mkPattern match

174+ where

175+ match (JSBinary op' v1 v2) | op' == op = Just (v1, v2)

176+ match _ = Nothing

177+

178+prettyPrintJS1 :: JS -> String

179+prettyPrintJS1 = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyPrintJS'

180+

181+prettyPrintJS :: [JS] -> String

182+prettyPrintJS sts = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) $ do

183+ jss <- forM sts prettyPrintJS'

184+ indentString <- currentIndent

185+ return $ intercalate "\n" $ map (++ "; ") $ map (indentString ++) jss

186+

187+prettyPrintJS' :: JS -> StateT PrinterState Maybe String

188+prettyPrintJS' = A.runKleisli $ runPattern matchValue

189+ where

190+ matchValue :: Pattern PrinterState JS String

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

192+ operators :: OperatorTable PrinterState JS String

193+ operators =

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

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

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

197+ , [ Wrap lam $ \(name, args) ret -> "function "

198+ ++ maybe "" identToJs name

199+ ++ "(" ++ intercalate ", " (map identToJs args) ++ ") "

200+ ++ ret ]

201+ , [ Wrap conditional $ \(th, el) cond -> cond ++ " ? " ++ prettyPrintJS1 th ++ " : " ++ prettyPrintJS1 el ]

202+ , [ binary LessThan "<" ]

203+ , [ binary LessThanOrEqualTo "<=" ]

204+ , [ binary GreaterThan ">" ]

205+ , [ binary GreaterThanOrEqualTo ">=" ]

206+ , [ unary Not "!" ]

207+ , [ unary BitwiseNot "~" ]

208+ , [ unary Negate "-" ]

209+ , [ binary Multiply "*" ]

210+ , [ binary Divide "/" ]

211+ , [ binary Modulus "%" ]

212+ , [ binary Concat "+" ]

213+ , [ binary Add "+" ]

214+ , [ binary Subtract "-" ]

215+ , [ binary ShiftLeft "<<" ]

216+ , [ binary ShiftRight ">>" ]

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

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

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

220+ , [ binary BitwiseAnd "&" ]

221+ , [ binary BitwiseXor "^" ]

222+ , [ binary BitwiseOr "|" ]

223+ , [ binary And "&&" ]

224+ , [ binary Or "||" ]

225+ ]

src/Language/PureScript/Pretty/Kinds.hsnew file+51

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

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

2+--

3+-- Module : Language.PureScript.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 Language.PureScript.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 Language.PureScript.Kinds

27+import Language.PureScript.Pretty.Common

28+import Language.PureScript.Unknown

29+

30+typeLiterals :: Pattern () Kind String

31+typeLiterals = mkPattern match

32+ where

33+ match Star = Just "*"

34+ match Row = Just "#"

35+ match (KUnknown (Unknown u)) = Just $ 'u' : show u

36+ match _ = Nothing

37+

38+funKind :: Pattern () Kind (Kind, Kind)

39+funKind = mkPattern match

40+ where

41+ match (FunKind arg ret) = Just (arg, ret)

42+ match _ = Nothing

43+

44+prettyPrintKind :: Kind -> String

45+prettyPrintKind = fromMaybe (error "Incomplete pattern") . pattern matchKind ()

46+ where

47+ matchKind :: Pattern () Kind String

48+ matchKind = buildPrettyPrinter operators (typeLiterals <+> fmap parens matchKind)

49+ operators :: OperatorTable () Kind String

50+ operators =

51+ OperatorTable [ [ AssocR funKind $ \arg ret -> arg ++ " -> " ++ ret ] ]

src/Language/PureScript/Pretty/Types.hsnew file+94

@@ -0,0 +1,94 @@

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

2+--

3+-- Module : Language.PureScript.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 Language.PureScript.Pretty.Types (

16+ prettyPrintType,

17+ prettyPrintRow

18+) where

19+

20+import Data.Maybe (fromMaybe)

21+import Data.List (intersperse, intercalate)

22+import qualified Control.Arrow as A

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

24+import qualified Data.Map as M

25+import Control.Applicative

26+

27+import Language.PureScript.Values

28+import Language.PureScript.Types

29+import Language.PureScript.Names

30+import Language.PureScript.Declarations

31+import Language.PureScript.TypeChecker.Monad

32+import Language.PureScript.Pretty.Common

33+import Language.PureScript.Unknown

34+

35+typeLiterals :: Pattern () Type String

36+typeLiterals = mkPattern 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 $ show ctor

45+ match (TUnknown (Unknown u)) = Just $ 'u' : show u

46+ match (Skolem s) = Just $ 's' : show s

47+ match (SaturatedTypeSynonym name args) = Just $ show name ++ "<" ++ intercalate "," (map prettyPrintType args) ++ ">"

48+ match (ForAll ident ty) = Just $ "forall " ++ ident ++ ". " ++ prettyPrintType ty

49+ match _ = Nothing

50+

51+prettyPrintRow :: Row -> String

52+prettyPrintRow = (\(tys, tail) -> intercalate ", " (map (uncurry nameAndTypeToPs) tys) ++ tailToPs tail) . toList []

53+ where

54+ nameAndTypeToPs :: String -> Type -> String

55+ nameAndTypeToPs name ty = name ++ " :: " ++ prettyPrintType ty

56+ tailToPs :: Row -> String

57+ tailToPs REmpty = ""

58+ tailToPs (RUnknown (Unknown u)) = " | u" ++ show u

59+ tailToPs (RowVar var) = " | " ++ var

60+ tailToPs (RSkolem s) = " | s" ++ show s

61+ toList :: [(String, Type)] -> Row -> ([(String, Type)], Row)

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

63+ toList tys r = (tys, r)

64+

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

66+typeApp = mkPattern match

67+ where

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

69+ match _ = Nothing

70+

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

72+singleArgumentFunction = mkPattern match

73+ where

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

75+ match _ = Nothing

76+

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

78+function = mkPattern match

79+ where

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

81+ match _ = Nothing

82+

83+prettyPrintType :: Type -> String

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

85+ where

86+ matchType :: Pattern () Type String

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

88+ operators :: OperatorTable () Type String

89+ operators =

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

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

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

93+ ]

94+ ]

src/Language/PureScript/Pretty/Values.hsnew file+193

@@ -0,0 +1,193 @@

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

2+--

3+-- Module : Language.PureScript.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 Language.PureScript.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 Language.PureScript.Types

28+import Language.PureScript.Values

29+import Language.PureScript.Names

30+import Language.PureScript.Pretty.Common

31+import Language.PureScript.Pretty.Types

32+

33+literals :: Pattern () Value String

34+literals = mkPattern match

35+ where

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

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

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

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

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

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

42+ match (Constructor name) = Just $ show name

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

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

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

46+ match _ = Nothing

47+

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

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

50+

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

52+ifThenElse = mkPattern match

53+ where

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

55+ match _ = Nothing

56+

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

58+accessor = mkPattern match

59+ where

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

61+ match _ = Nothing

62+

63+indexer :: Pattern () Value (Value, Value)

64+indexer = mkPattern match

65+ where

66+ match (Indexer index val) = Just (index, val)

67+ match _ = Nothing

68+

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

70+objectUpdate = mkPattern match

71+ where

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

73+ match _ = Nothing

74+

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

76+app = mkPattern match

77+ where

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

79+ match _ = Nothing

80+

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

82+lam = mkPattern match

83+ where

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

85+ match _ = Nothing

86+

87+typed :: Pattern () Value (PolyType, Value)

88+typed = mkPattern match

89+ where

90+ match (TypedValue val ty) = Just (ty, val)

91+ match _ = Nothing

92+

93+unary :: UnaryOperator -> String -> Operator () Value String

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

95+ where

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

97+ pattern = mkPattern match

98+ where

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

100+ match _ = Nothing

101+

102+binary :: BinaryOperator -> String -> Operator () Value String

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

104+ where

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

106+ pattern = mkPattern match

107+ where

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

109+ match _ = Nothing

110+

111+prettyPrintValue :: Value -> String

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

113+ where

114+ matchValue :: Pattern () Value String

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

116+ operators :: OperatorTable () Value String

117+ operators =

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

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

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

121+ , [ Split lam $ \args val -> "\\" ++ intercalate ", " args ++ " -> " ++ prettyPrintValue val ]

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

123+ , [ Wrap typed $ \ty val -> val ++ " :: " ++ prettyPrintType ty ]

124+ , [ AssocR indexer (\index val -> val ++ " !! " ++ index) ]

125+ , [ binary LessThan "<" ]

126+ , [ binary LessThanOrEqualTo "<=" ]

127+ , [ binary GreaterThan ">" ]

128+ , [ binary GreaterThanOrEqualTo ">=" ]

129+ , [ unary Not "!" ]

130+ , [ unary BitwiseNot "~" ]

131+ , [ unary Negate "-" ]

132+ , [ binary Multiply "*" ]

133+ , [ binary Divide "/" ]

134+ , [ binary Modulus "%" ]

135+ , [ binary Concat "++" ]

136+ , [ binary Add "+" ]

137+ , [ binary Subtract "-" ]

138+ , [ binary ShiftLeft "<<" ]

139+ , [ binary ShiftRight ">>" ]

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

141+ , [ binary EqualTo "==" ]

142+ , [ binary NotEqualTo "!=" ]

143+ , [ binary BitwiseAnd "&" ]

144+ , [ binary BitwiseXor "^" ]

145+ , [ binary BitwiseOr "|" ]

146+ , [ binary And "&&" ]

147+ , [ binary Or "||" ]

148+ ]

149+

150+prettyPrintBinder :: Binder -> String

151+prettyPrintBinder NullBinder = "_"

152+prettyPrintBinder (StringBinder str) = show str

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

154+prettyPrintBinder (BooleanBinder True) = "true"

155+prettyPrintBinder (BooleanBinder False) = "false"

156+prettyPrintBinder (VarBinder ident) = show ident

157+prettyPrintBinder (NullaryBinder ctor) = show ctor

158+prettyPrintBinder (UnaryBinder ctor b) = show ctor ++ " " ++ prettyPrintBinder b

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

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

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

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

163+

164+prettyPrintObjectPropertyBinder :: String -> Binder -> String

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

166+

167+prettyPrintObjectProperty :: String -> Value -> String

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

169+

170+prettyPrintStatement :: Statement -> String

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

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

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

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

175+ ++ " <- " ++ prettyPrintValue start

176+ ++ " until " ++ prettyPrintValue end ++ ": {"

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

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

179+ ++ " in " ++ prettyPrintValue arr ++ ": {"

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

181+prettyPrintStatement (If ifst) = prettyPrintIfStatement ifst

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

183+

184+prettyPrintIfStatement :: IfStatement -> String

185+prettyPrintIfStatement (IfStatement cond thens elst) =

186+ "if "

187+ ++ prettyPrintValue cond ++ ": {"

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

189+ ++ maybe "" prettyPrintElseStatement elst

190+

191+prettyPrintElseStatement :: ElseStatement -> String

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

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

src/Language/PureScript/TypeChecker.hsnew file+141

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

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

2+--

3+-- Module : Language.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 FlexibleInstances #-}

16+

17+module Language.PureScript.TypeChecker (

18+ module T,

19+ typeCheckAll

20+) where

21+

22+import Language.PureScript.TypeChecker.Monad as T

23+import Language.PureScript.TypeChecker.Kinds as T

24+import Language.PureScript.TypeChecker.Types as T

25+import Language.PureScript.TypeChecker.Synonyms as T

26+

27+import Data.List

28+import Data.Maybe

29+import Data.Function

30+import qualified Data.Map as M

31+

32+import Language.PureScript.Values

33+import Language.PureScript.Types

34+import Language.PureScript.Names

35+import Language.PureScript.Kinds

36+import Language.PureScript.Declarations

37+

38+import Control.Monad (forM_)

39+import Control.Monad.State

40+import Control.Monad.Error

41+

42+typeCheckAll :: [Declaration] -> Check ()

43+typeCheckAll [] = return ()

44+typeCheckAll (DataDeclaration name args dctors : rest) = do

45+ rethrow (("Error in type constructor " ++ show name ++ ":\n") ++) $ do

46+ env <- getEnv

47+ modulePath <- checkModulePath `fmap` get

48+ guardWith (show name ++ " is already defined") $ not $ M.member (modulePath, name) (types env)

49+ ctorKind <- kindsOf (Just name) args (mapMaybe snd dctors)

50+ putEnv $ env { types = M.insert (modulePath, name) (ctorKind, Data) (types env) }

51+ forM_ dctors $ \(dctor, maybeTy) ->

52+ rethrow (("Error in data constructor " ++ show name ++ ":\n") ++) $ do

53+ env' <- getEnv

54+ guardWith (show dctor ++ " is already defined") $ not $ M.member (modulePath, dctor) (dataConstructors env')

55+ let retTy = foldl TypeApp (TypeConstructor (Qualified modulePath name)) (map TypeVar args)

56+ let dctorTy = maybe retTy (\ty -> Function [ty] retTy) maybeTy

57+ let polyType = mkForAll args dctorTy

58+ putEnv $ env' { dataConstructors = M.insert (modulePath, dctor) polyType (dataConstructors env') }

59+ typeCheckAll rest

60+typeCheckAll (TypeSynonymDeclaration name args ty : rest) = do

61+ rethrow (("Error in type synonym " ++ show name ++ ":\n") ++) $ do

62+ env <- getEnv

63+ modulePath <- checkModulePath `fmap` get

64+ guardWith (show name ++ " is already defined") $ not $ M.member (modulePath, name) (types env)

65+ kind <- kindsOf (Just name) args [ty]

66+ putEnv $ env { types = M.insert (modulePath, name) (kind, TypeSynonym) (types env)

67+ , typeSynonyms = M.insert (modulePath, name) (args, ty) (typeSynonyms env) }

68+ typeCheckAll rest

69+typeCheckAll (TypeDeclaration name ty : ValueDeclaration name' val : rest) | name == name' =

70+ typeCheckAll (ValueDeclaration name (TypedValue val ty) : rest)

71+typeCheckAll (TypeDeclaration name _ : _) = throwError $ "Orphan type declaration for " ++ show name

72+typeCheckAll (ValueDeclaration name val : rest) = do

73+ rethrow (("Error in declaration " ++ show name ++ ":\n") ++) $ do

74+ env <- getEnv

75+ modulePath <- checkModulePath `fmap` get

76+ case M.lookup (modulePath, name) (names env) of

77+ Just ty -> throwError $ show name ++ " is already defined"

78+ Nothing -> do

79+ ty <- typeOf (Just name) val

80+ putEnv (env { names = M.insert (modulePath, name) (ty, Value) (names env) })

81+ typeCheckAll rest

82+typeCheckAll (ExternDataDeclaration name kind : rest) = do

83+ env <- getEnv

84+ modulePath <- checkModulePath `fmap` get

85+ guardWith (show name ++ " is already defined") $ not $ M.member (modulePath, name) (types env)

86+ putEnv $ env { types = M.insert (modulePath, name) (kind, TypeSynonym) (types env) }

87+ typeCheckAll rest

88+typeCheckAll (ExternMemberDeclaration member name ty : rest) = do

89+ rethrow (("Error in foreign import member declaration " ++ show name ++ ":\n") ++) $ do

90+ env <- getEnv

91+ modulePath <- checkModulePath `fmap` get

92+ kind <- kindOf ty

93+ guardWith "Expected kind *" $ kind == Star

94+ case M.lookup (modulePath, name) (names env) of

95+ Just _ -> throwError $ show name ++ " is already defined"

96+ Nothing -> case ty of

97+ _ | isSingleArgumentFunction ty -> do

98+ putEnv (env { names = M.insert (modulePath, name) (ty, Extern) (names env)

99+ , members = M.insert (modulePath, name) member (members env) })

100+ | otherwise -> throwError "Foreign member declarations must have function types, with an single argument."

101+ typeCheckAll rest

102+ where

103+ isSingleArgumentFunction (Function [_] _) = True

104+ isSingleArgumentFunction (ForAll _ ty) = isSingleArgumentFunction ty

105+ isSingleArgumentFunction _ = False

106+typeCheckAll (ExternDeclaration name ty : rest) = do

107+ rethrow (("Error in foreign import declaration " ++ show name ++ ":\n") ++) $ do

108+ env <- getEnv

109+ modulePath <- checkModulePath `fmap` get

110+ kind <- kindOf ty

111+ guardWith "Expected kind *" $ kind == Star

112+ case M.lookup (modulePath, name) (names env) of

113+ Just _ -> throwError $ show name ++ " is already defined"

114+ Nothing -> putEnv (env { names = M.insert (modulePath, name) (ty, Extern) (names env) })

115+ typeCheckAll rest

116+typeCheckAll (FixityDeclaration _ name : rest) = do

117+ typeCheckAll rest

118+ env <- getEnv

119+ modulePath <- checkModulePath `fmap` get

120+ guardWith ("Fixity declaration with no binding: " ++ name) $ M.member (modulePath, Op name) $ names env

121+typeCheckAll (ModuleDeclaration name decls : rest) = do

122+ withModule name $ typeCheckAll decls

123+ typeCheckAll rest

124+typeCheckAll (ImportDeclaration modulePath idents : rest) = do

125+ env <- getEnv

126+ currentModule <- checkModulePath `fmap` get

127+ rethrow errorMessage $ do

128+ guardWith ("Module " ++ show modulePath ++ " does not exist") $ moduleExists env

129+ case idents of

130+ Nothing -> bindIdents (map snd $ filterModule env) currentModule env

131+ Just idents -> bindIdents idents currentModule env

132+ typeCheckAll rest

133+ where errorMessage = (("Error in import declaration " ++ show modulePath ++ ":\n") ++)

134+ filterModule = filter ((== modulePath) . fst) . M.keys . names

135+ moduleExists env = not $ null $ filterModule env

136+ bindIdents idents currentModule env =

137+ forM_ idents $ \ident -> do

138+ guardWith (show currentModule ++ "." ++ show ident ++ " is already defined") $ (currentModule, ident) `M.notMember` names env

139+ case (modulePath, ident) `M.lookup` names env of

140+ Just (pt, _) -> modifyEnv (\e -> e { names = M.insert (currentModule, ident) (pt, Alias modulePath ident) (names e) })

141+ Nothing -> throwError (show modulePath ++ "." ++ show ident ++ " is undefined")

src/Language/PureScript/TypeChecker/Kinds.hsnew file+132

@@ -0,0 +1,132 @@

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

2+--

3+-- Module : Language.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 Language.PureScript.TypeChecker.Kinds (

18+ kindsOf,

19+ kindOf

20+) where

21+

22+import Data.List

23+import Data.Maybe (fromMaybe)

24+import Data.Function

25+import Data.Data

26+

27+import Language.PureScript.Types

28+import Language.PureScript.Kinds

29+import Language.PureScript.Names

30+import Language.PureScript.Declarations

31+import Language.PureScript.TypeChecker.Monad

32+import Language.PureScript.Pretty

33+import Language.PureScript.Unknown

34+

35+import Control.Monad.State

36+import Control.Monad.Error

37+

38+import Control.Applicative

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

40+import qualified Control.Category as C

41+

42+import qualified Data.Map as M

43+

44+instance Unifiable Kind where

45+ unknown = KUnknown

46+ isUnknown (KUnknown u) = Just u

47+ isUnknown _ = Nothing

48+ KUnknown u1 ~~ KUnknown u2 | u1 == u2 = return ()

49+ KUnknown u ~~ k = replace u k

50+ k ~~ KUnknown u = replace u k

51+ Star ~~ Star = return ()

52+ Row ~~ Row = return ()

53+ FunKind k1 k2 ~~ FunKind k3 k4 = do

54+ k1 ~~ k3

55+ k2 ~~ k4

56+ k1 ~~ k2 = throwError $ "Cannot unify " ++ prettyPrintKind k1 ++ " with " ++ prettyPrintKind k2 ++ "."

57+ apply s (KUnknown u) = runSubstitution s u

58+ apply s (FunKind k1 k2) = FunKind (apply s k1) (apply s k2)

59+ apply _ k = k

60+ unknowns (KUnknown (Unknown u)) = [u]

61+ unknowns (FunKind k1 k2) = unknowns k1 ++ unknowns k2

62+ unknowns _ = []

63+

64+kindOf :: Type -> Check Kind

65+kindOf ty = fmap (\(k, _, _) -> k) . runSubst $ starIfUnknown <$> infer Nothing M.empty ty

66+

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

68+kindsOf name args ts = fmap (starIfUnknown . (\(k, _, _) -> k)) . runSubst $ do

69+ tyCon <- fresh

70+ kargs <- replicateM (length args) fresh

71+ ks <- inferAll (fmap (\pn -> (pn, tyCon)) name) (M.fromList (zip args kargs)) ts

72+ tyCon ~~ foldr FunKind Star kargs

73+ forM_ ks $ \k -> k ~~ Star

74+ return tyCon

75+

76+starIfUnknown :: Kind -> Kind

77+starIfUnknown (KUnknown _) = Star

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

79+starIfUnknown k = k

80+

81+inferAll :: Maybe (ProperName, Kind) -> M.Map String Kind -> [Type] -> Subst [Kind]

82+inferAll name m = mapM (infer name m)

83+

84+infer :: Maybe (ProperName, Kind) -> M.Map String Kind -> Type -> Subst Kind

85+infer name m (Array t) = do

86+ k <- infer name m t

87+ k ~~ Star

88+ return Star

89+infer name m (Object row) = do

90+ k <- inferRow name m row

91+ k ~~ Row

92+ return Star

93+infer name m (Function args ret) = do

94+ ks <- inferAll name m args

95+ k <- infer name m ret

96+ k ~~ Star

97+ forM ks $ \k -> k ~~ Star

98+ return Star

99+infer _ m (TypeVar v) =

100+ case M.lookup v m of

101+ Just k -> return k

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

103+infer (Just (name, k)) m c@(TypeConstructor v@(Qualified (ModulePath []) pn)) | name == pn = return k

104+infer name m (TypeConstructor v) = do

105+ env <- liftCheck getEnv

106+ modulePath <- checkModulePath `fmap` get

107+ case M.lookup (qualify modulePath v) (types env) of

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

109+ Just (kind, _) -> return kind

110+infer name m (TypeApp t1 t2) = do

111+ k0 <- fresh

112+ k1 <- infer name m t1

113+ k2 <- infer name m t2

114+ k1 ~~ FunKind k2 k0

115+ return k0

116+infer name m (ForAll ident ty) = do

117+ k <- fresh

118+ infer name (M.insert ident k m) ty

119+infer _ m t = return Star

120+

121+inferRow :: Maybe (ProperName, Kind) -> M.Map String Kind -> Row -> Subst Kind

122+inferRow _ m (RowVar v) = do

123+ case M.lookup v m of

124+ Just k -> return k

125+ Nothing -> throwError $ "Unbound row variable " ++ v

126+inferRow _ m r@REmpty = return Row

127+inferRow name m r@(RCons _ ty row) = do

128+ k1 <- infer name m ty

129+ k2 <- inferRow name m row

130+ k1 ~~ Star

131+ k2 ~~ Row

132+ return Row

src/Language/PureScript/TypeChecker/Monad.hsnew file+185

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

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

2+--

3+-- Module : Language.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, RankNTypes, DeriveDataTypeable,

16+ GADTs, StandaloneDeriving, MultiParamTypeClasses, FlexibleContexts #-}

17+

18+module Language.PureScript.TypeChecker.Monad where

19+

20+import Language.PureScript.Types

21+import Language.PureScript.Kinds

22+import Language.PureScript.Names

23+import Language.PureScript.Unknown

24+

25+import Data.Data

26+import Data.Maybe

27+import Data.Monoid

28+import Data.Typeable

29+import Control.Applicative

30+import Control.Monad.State

31+import Control.Monad.Error

32+

33+import Control.Arrow ((***), first, second)

34+

35+import qualified Data.Map as M

36+

37+data NameKind = Value | Extern | Alias ModulePath Ident | LocalVariable deriving Show

38+

39+data TypeDeclarationKind = Data | ExternData | TypeSynonym deriving Show

40+

41+data Environment = Environment

42+ { names :: M.Map (ModulePath, Ident) (Type, NameKind)

43+ , types :: M.Map (ModulePath, ProperName) (Kind, TypeDeclarationKind)

44+ , dataConstructors :: M.Map (ModulePath, ProperName) Type

45+ , typeSynonyms :: M.Map (ModulePath, ProperName) ([String], Type)

46+ , members :: M.Map (ModulePath, Ident) String

47+ } deriving (Show)

48+

49+emptyEnvironment :: Environment

50+emptyEnvironment = Environment M.empty M.empty M.empty M.empty M.empty

51+

52+bindNames :: (MonadState CheckState m) => M.Map (ModulePath, Ident) (Type, NameKind) -> m a -> m a

53+bindNames newNames action = do

54+ orig <- get

55+ modify $ \st -> st { checkEnv = (checkEnv st) { names = newNames `M.union` (names . checkEnv $ st) } }

56+ a <- action

57+ modify $ \st -> st { checkEnv = (checkEnv st) { names = names . checkEnv $ orig } }

58+ return a

59+

60+bindLocalVariables :: (Functor m, MonadState CheckState m) => [(Ident, Type)] -> m a -> m a

61+bindLocalVariables bindings action = do

62+ modulePath <- checkModulePath `fmap` get

63+ bindNames (M.fromList $ flip map bindings $ \(name, ty) -> ((modulePath, name), (ty, LocalVariable))) action

64+

65+lookupVariable :: (Functor m, MonadState CheckState m, MonadError String m) => Qualified Ident -> m Type

66+lookupVariable var = do

67+ env <- getEnv

68+ modulePath <- checkModulePath <$> get

69+ let tries = map (First . flip M.lookup (names env)) (nameResolution modulePath var)

70+ case getFirst (mconcat tries) of

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

72+ Just (ty, _) -> return ty

73+

74+data AnyUnifiable where

75+ AnyUnifiable :: forall t. (Unifiable t) => t -> AnyUnifiable

76+

77+data CheckState = CheckState { checkEnv :: Environment

78+ , checkNextVar :: Int

79+ , checkModulePath :: ModulePath

80+ }

81+

82+newtype Check a = Check { unCheck :: StateT CheckState (Either String) a }

83+ deriving (Functor, Monad, Applicative, MonadPlus, MonadState CheckState, MonadError String)

84+

85+getEnv :: (Functor m, MonadState CheckState m) => m Environment

86+getEnv = checkEnv <$> get

87+

88+putEnv :: (MonadState CheckState m) => Environment -> m ()

89+putEnv env = modify (\s -> s { checkEnv = env })

90+

91+modifyEnv :: (MonadState CheckState m) => (Environment -> Environment) -> m ()

92+modifyEnv f = modify (\s -> s { checkEnv = f (checkEnv s) })

93+

94+runCheck :: Check a -> Either String (a, Environment)

95+runCheck c = do

96+ (a, s) <- flip runStateT (CheckState emptyEnvironment 0 global) $ unCheck c

97+ return (a, checkEnv s)

98+

99+guardWith :: (MonadError e m) => e -> Bool -> m ()

100+guardWith _ True = return ()

101+guardWith e False = throwError e

102+

103+rethrow :: (MonadError e m) => (e -> e) -> m a -> m a

104+rethrow f = flip catchError $ \e -> throwError (f e)

105+

106+withModule :: ProperName -> Check a -> Check a

107+withModule name act = do

108+ original <- checkModulePath `fmap` get

109+ modify $ \s -> s { checkModulePath = subModule (checkModulePath s) name }

110+ a <- act

111+ modify $ \s -> s { checkModulePath = original }

112+ return a

113+

114+newtype Substitution = Substitution { runSubstitution :: forall t. (Unifiable t) => Unknown t -> t }

115+

116+instance Monoid Substitution where

117+ mempty = Substitution unknown

118+ s1 `mappend` s2 = Substitution $ \u -> apply s1 (apply s2 (unknown u))

119+

120+data SubstState = SubstState { substSubst :: Substitution

121+ , substFutureEscapeChecks :: [AnyUnifiable] }

122+

123+newtype Subst a = Subst { unSubst :: StateT SubstState Check a }

124+ deriving (Functor, Monad, Applicative, MonadPlus)

125+

126+instance MonadState CheckState Subst where

127+ get = Subst . lift $ get

128+ put = Subst . lift . put

129+

130+deriving instance MonadError String Subst

131+

132+liftCheck :: Check a -> Subst a

133+liftCheck = Subst . lift

134+

135+runSubst :: (Unifiable a) => Subst a -> Check (a, Substitution, [AnyUnifiable])

136+runSubst subst = do

137+ (a, s) <- flip runStateT (SubstState mempty []) . unSubst $ subst

138+ return (apply (substSubst s) a, substSubst s, substFutureEscapeChecks s)

139+

140+substituteWith :: (Typeable t) => (Unknown t -> t) -> Substitution

141+substituteWith f = Substitution $ \u -> fromMaybe (unknown u) $ do

142+ u1 <- cast u

143+ cast (f u1)

144+

145+substituteOne :: (Unifiable t) => Unknown t -> t -> Substitution

146+substituteOne u t = substituteWith $ \u1 ->

147+ case u1 of

148+ u2 | u2 == u -> t

149+ | otherwise -> unknown u2

150+

151+replace :: (Unifiable t) => Unknown t -> t -> Subst ()

152+replace u t' = do

153+ sub <- substSubst <$> Subst get

154+ let t = apply sub t'

155+ occursCheck u t

156+ let current = apply sub $ unknown u

157+ case isUnknown current of

158+ Just u1 | u1 == u -> return ()

159+ _ -> current ~~ t

160+ Subst . modify $ \s -> s { substSubst = substituteOne u t <> substSubst s }

161+

162+class (Typeable t, Data t, Show t) => Unifiable t where

163+ unknown :: Unknown t -> t

164+ (~~) :: t -> t -> Subst ()

165+ isUnknown :: t -> Maybe (Unknown t)

166+ apply :: Substitution -> t -> t

167+ unknowns :: t -> [Int]

168+

169+occursCheck :: (Unifiable t) => Unknown s -> t -> Subst ()

170+occursCheck (Unknown u) t =

171+ case isUnknown t of

172+ Nothing -> guardWith "Occurs check fails" (u `notElem` unknowns t)

173+ _ -> return ()

174+

175+fresh' :: Subst Int

176+fresh' = do

177+ n <- checkNextVar <$> get

178+ modify $ \s -> s { checkNextVar = succ (checkNextVar s) }

179+ return n

180+

181+fresh :: (Unifiable t) => Subst t

182+fresh = unknown . Unknown <$> fresh'

183+

184+escapeCheckLater :: (Unifiable t) => t -> Subst ()

185+escapeCheckLater t = Subst . modify $ \s -> s { substFutureEscapeChecks = AnyUnifiable t : substFutureEscapeChecks s }

src/Language/PureScript/TypeChecker/Synonyms.hsnew file+51

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

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

2+--

3+-- Module : Language.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+module Language.PureScript.TypeChecker.Synonyms (

16+ saturateTypeSynonym,

17+ saturateAllTypeSynonyms

18+) where

19+

20+import Language.PureScript.Types

21+import Language.PureScript.Declarations

22+import Language.PureScript.Names

23+

24+import Data.Maybe (fromMaybe)

25+import Data.Data

26+import Data.Generics

27+import Data.Generics.Extras

28+import Control.Arrow

29+import Control.Monad.Writer

30+import Control.Monad.Error

31+import qualified Data.Map as M

32+

33+buildTypeSubstitution :: Qualified ProperName -> 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 " ++ show name

39+ go n args (TypeApp f arg) = go (n - 1) (arg:args) f

40+ go _ _ _ = return Nothing

41+

42+saturateTypeSynonym :: (Data d) => Qualified ProperName -> Int -> d -> Either String d

43+saturateTypeSynonym name n = everywhereM' (mkM replace)

44+ where

45+ replace t = fmap (fromMaybe t) $ buildTypeSubstitution name n t

46+

47+saturateAllTypeSynonyms :: (Data d) => [(Qualified ProperName, Int)] -> d -> Either String d

48+saturateAllTypeSynonyms syns d = foldM (\d (name, n) -> saturateTypeSynonym name n d) d syns

49+

50+

51+

src/Language/PureScript/TypeChecker/Types.hsnew file+753

@@ -0,0 +1,753 @@

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

2+--

3+-- Module : Language.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, FlexibleContexts #-}

16+

17+module Language.PureScript.TypeChecker.Types (

18+ typeOf

19+) where

20+

21+import Data.List

22+import Data.Maybe (isJust, fromMaybe)

23+import Data.Function

24+import qualified Data.Data as D

25+import Data.Generics

26+ (extT, something, everywhere, everywhereM, everything,

27+ everywhereBut, mkT, mkM, mkQ, extM, extQ)

28+

29+import Language.PureScript.Values

30+import Language.PureScript.Types

31+import Language.PureScript.Kinds

32+import Language.PureScript.Names

33+import Language.PureScript.TypeChecker.Monad

34+import Language.PureScript.TypeChecker.Kinds

35+import Language.PureScript.TypeChecker.Synonyms

36+import Language.PureScript.Pretty

37+import Language.PureScript.Unknown

38+

39+import Control.Monad.State

40+import Control.Monad.Error

41+

42+import Control.Applicative

43+import Control.Arrow (Arrow(..), Kleisli(..), (***), (&&&), second)

44+import qualified Control.Category as C

45+

46+import qualified Data.Map as M

47+

48+instance Unifiable Type where

49+ unknown = TUnknown

50+ isUnknown (TUnknown u) = Just u

51+ isUnknown _ = Nothing

52+ (~~) = unifyTypes

53+ apply s (TUnknown u) = runSubstitution s u

54+ apply s (SaturatedTypeSynonym name tys) = SaturatedTypeSynonym name $ map (apply s) tys

55+ apply s (ForAll idents ty) = ForAll idents $ apply s ty

56+ apply s (Array t) = Array (apply s t)

57+ apply s (Object r) = Object (apply s r)

58+ apply s (Function args ret) = Function (map (apply s) args) (apply s ret)

59+ apply s (TypeApp t1 t2) = TypeApp (apply s t1) (apply s t2)

60+ apply _ t = t

61+ unknowns (TUnknown (Unknown u)) = [u]

62+ unknowns (SaturatedTypeSynonym _ tys) = concatMap unknowns tys

63+ unknowns (ForAll idents ty) = unknowns ty

64+ unknowns (Array t) = unknowns t

65+ unknowns (Object r) = unknowns r

66+ unknowns (Function args ret) = concatMap unknowns args ++ unknowns ret

67+ unknowns (TypeApp t1 t2) = unknowns t1 ++ unknowns t2

68+ unknowns _ = []

69+

70+instance Unifiable Row where

71+ unknown = RUnknown

72+ isUnknown (RUnknown u) = Just u

73+ isUnknown _ = Nothing

74+ r1 ~~ r2 =

75+ let

76+ (s1, r1') = rowToList r1

77+ (s2, r2') = rowToList r2

78+ int = [ (t1, t2) | (name, t1) <- s1, (name', t2) <- s2, name == name' ]

79+ sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ]

80+ sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ]

81+ in do

82+ forM_ int (uncurry (~~))

83+ unifyRows sd1 r1' sd2 r2'

84+ where

85+ unifyRows :: [(String, Type)] -> Row -> [(String, Type)] -> Row -> Subst ()

86+ unifyRows [] (RUnknown u) sd r = replace u (rowFromList (sd, r))

87+ unifyRows sd r [] (RUnknown u) = replace u (rowFromList (sd, r))

88+ unifyRows ns@((name, ty):row) r others u@(RUnknown un) = do

89+ occursCheck un ty

90+ forM row $ \(_, ty) -> occursCheck un ty

91+ u' <- fresh

92+ u ~~ RCons name ty u'

93+ unifyRows row r others u'

94+ unifyRows [] REmpty [] REmpty = return ()

95+ unifyRows [] (RowVar v1) [] (RowVar v2) | v1 == v2 = return ()

96+ unifyRows [] (RSkolem s1) [] (RSkolem s2) | s1 == s2 = return ()

97+ unifyRows sd1 r1 sd2 r2 = throwError $ "Cannot unify " ++ prettyPrintRow (rowFromList (sd1, r1)) ++ " with " ++ prettyPrintRow (rowFromList (sd2, r2)) ++ "."

98+ apply s (RUnknown u) = runSubstitution s u

99+ apply s (RCons name ty r) = RCons name (apply s ty) (apply s r)

100+ apply _ r = r

101+ unknowns (RUnknown (Unknown u)) = [u]

102+ unknowns (RCons _ ty r) = unknowns ty ++ unknowns r

103+ unknowns _ = []

104+

105+unifyTypes :: Type -> Type -> Subst ()

106+unifyTypes t1 t2 = rethrow (\e -> "Error unifying type " ++ prettyPrintType t1 ++ " with type " ++ prettyPrintType t2 ++ ":\n" ++ e) $ do

107+ unifyTypes' t1 t2

108+ where

109+ unifyTypes' (TUnknown u1) (TUnknown u2) | u1 == u2 = return ()

110+ unifyTypes' (TUnknown u) t = replace u t

111+ unifyTypes' t (TUnknown u) = replace u t

112+ unifyTypes' (SaturatedTypeSynonym name1 args1) (SaturatedTypeSynonym name2 args2)

113+ | name1 == name2 = zipWithM_ unifyTypes args1 args2

114+ unifyTypes' (SaturatedTypeSynonym name args) ty = do

115+ ty1 <- expandTypeSynonym name args

116+ ty1 `unifyTypes` ty

117+ unifyTypes' ty s@(SaturatedTypeSynonym _ _) = s `unifyTypes` ty

118+ unifyTypes' (ForAll ident1 ty1) (ForAll ident2 ty2) = do

119+ sk <- skolemize ident1 ty1

120+ replaced <- replaceVarWithUnknown ident2 ty2

121+ sk `unifyTypes` replaced

122+ unifyTypes' (ForAll ident ty1) ty2 = do

123+ sk <- skolemize ident ty1

124+ sk `unifyTypes` ty2

125+ unifyTypes' ty f@(ForAll _ _) = f `unifyTypes` ty

126+ unifyTypes' Number Number = return ()

127+ unifyTypes' String String = return ()

128+ unifyTypes' Boolean Boolean = return ()

129+ unifyTypes' (Array s) (Array t) = s `unifyTypes` t

130+ unifyTypes' (Object row1) (Object row2) = row1 ~~ row2

131+ unifyTypes' (Function args1 ret1) (Function args2 ret2) = do

132+ guardWith "Function applied to incorrect number of args" $ length args1 == length args2

133+ zipWithM_ unifyTypes args1 args2

134+ ret1 `unifyTypes` ret2

135+ unifyTypes' (TypeVar v1) (TypeVar v2) | v1 == v2 = return ()

136+ unifyTypes' (TypeConstructor c1) (TypeConstructor c2) = do

137+ modulePath <- checkModulePath `fmap` get

138+ guardWith ("Cannot unify " ++ show c1 ++ " with " ++ show c2 ++ ".") (qualify modulePath c1 == qualify modulePath c2)

139+ unifyTypes' (TypeApp t1 t2) (TypeApp t3 t4) = do

140+ t1 `unifyTypes` t3

141+ t2 `unifyTypes` t4

142+ unifyTypes' (Skolem s1) (Skolem s2) | s1 == s2 = return ()

143+ unifyTypes' t1 t2 = throwError $ "Cannot unify " ++ prettyPrintType t1 ++ " with " ++ prettyPrintType t2 ++ "."

144+

145+isFunction :: Value -> Bool

146+isFunction (Abs _ _) = True

147+isFunction (TypedValue untyped _) = isFunction untyped

148+isFunction _ = False

149+

150+typeOf :: Maybe Ident -> Value -> Check Type

151+typeOf name val = do

152+ (ty, sub, checks) <- runSubst $ case name of

153+ Just ident | isFunction val ->

154+ case val of

155+ TypedValue val ty -> do

156+ kind <- liftCheck $ kindOf ty

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

158+ ty' <- replaceAllTypeSynonyms ty

159+ modulePath <- checkModulePath <$> get

160+ bindNames (M.singleton (modulePath, ident) (ty, LocalVariable)) $ check val ty'

161+ return ty'

162+ _ -> do

163+ me <- fresh

164+ modulePath <- checkModulePath <$> get

165+ ty <- bindNames (M.singleton (modulePath, ident) (me, LocalVariable)) $ infer val

166+ ty ~~ me

167+ return ty

168+ _ -> infer val

169+ escapeCheck checks ty sub

170+ skolemEscapeCheck ty

171+ return $ varIfUnknown $ desaturateAllTypeSynonyms $ setifyAll ty

172+

173+escapeCheck :: [AnyUnifiable] -> Type -> Substitution -> Check ()

174+escapeCheck checks ty sub =

175+ let

176+ visibleUnknowns = nub $ unknowns ty

177+ in

178+ forM_ checks $ \check -> case check of

179+ AnyUnifiable t -> do

180+ let unsolvedUnknowns = nub . unknowns $ apply sub t

181+ guardWith "Escape check fails" $ null $ unsolvedUnknowns \\ visibleUnknowns

182+

183+skolemEscapeCheck :: Type -> Check ()

184+skolemEscapeCheck ty =

185+ case something (extQ (mkQ Nothing findSkolems) findRSkolems) ty of

186+ Nothing -> return ()

187+ Just _ -> throwError "Skolem variables cannot escape. Consider adding a type signature."

188+ where

189+ findSkolems (Skolem _) = return ()

190+ findSkolems _ = mzero

191+ findRSkolems (RSkolem _) = return ()

192+ findRSkolems _ = mzero

193+

194+setify :: Row -> Row

195+setify = rowFromList . first (M.toList . M.fromList) . rowToList

196+

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

198+setifyAll = everywhere (mkT setify)

199+

200+varIfUnknown :: Type -> Type

201+varIfUnknown ty =

202+ let unks = nub $ unknowns ty

203+ toName = (:) 't' . show

204+ ty' = everywhere (mkT rowToVar) . everywhere (mkT typeToVar) $ ty

205+ typeToVar :: Type -> Type

206+ typeToVar (TUnknown (Unknown u)) = TypeVar (toName u)

207+ typeToVar t = t

208+ rowToVar :: Row -> Row

209+ rowToVar (RUnknown (Unknown u)) = RowVar (toName u)

210+ rowToVar t = t

211+ in mkForAll (sort . map toName $ unks) ty'

212+

213+replaceAllTypeVars :: (D.Data d) => [(String, Type)] -> d -> d

214+replaceAllTypeVars = foldl' (\f (name, ty) -> replaceTypeVars name ty . f) id

215+

216+replaceTypeVars :: (D.Data d) => String -> Type -> d -> d

217+replaceTypeVars name t = everywhereBut (mkQ False isShadowed) (mkT replace)

218+ where

219+ replace (TypeVar v) | v == name = t

220+ replace t = t

221+ isShadowed (ForAll v _) | v == name = True

222+ isShadowed _ = False

223+

224+replaceRowVars :: (D.Data d) => String -> Row -> d -> d

225+replaceRowVars name r = everywhere (mkT replace)

226+ where

227+ replace (RowVar v) | v == name = r

228+ replace t = t

229+

230+replaceAllVarsWithUnknowns :: Type -> Subst Type

231+replaceAllVarsWithUnknowns (ForAll ident ty) = replaceVarWithUnknown ident ty >>= replaceAllVarsWithUnknowns

232+replaceAllVarsWithUnknowns ty = return ty

233+

234+replaceVarWithUnknown :: String -> Type -> Subst Type

235+replaceVarWithUnknown ident ty = do

236+ tu <- fresh

237+ ru <- fresh

238+ return $ replaceRowVars ident ru . replaceTypeVars ident tu $ ty

239+

240+replaceAllTypeSynonyms :: (Functor m, MonadState CheckState m, MonadError String m) => (D.Data d) => d -> m d

241+replaceAllTypeSynonyms d = do

242+ env <- getEnv

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

244+ either throwError return $ saturateAllTypeSynonyms syns d

245+

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

247+desaturateAllTypeSynonyms = everywhere (mkT replace)

248+ where

249+ replace (SaturatedTypeSynonym name args) = foldl TypeApp (TypeConstructor name) args

250+ replace t = t

251+

252+expandAllTypeSynonyms :: Type -> Subst Type

253+expandAllTypeSynonyms (SaturatedTypeSynonym name args) = expandTypeSynonym name args >>= expandAllTypeSynonyms

254+expandAllTypeSynonyms ty = return ty

255+

256+expandTypeSynonym :: Qualified ProperName -> [Type] -> Subst Type

257+expandTypeSynonym name args = do

258+ env <- getEnv

259+ modulePath <- checkModulePath `fmap` get

260+ case M.lookup (qualify modulePath name) (typeSynonyms env) of

261+ Just (synArgs, body) -> return $ replaceAllTypeVars (zip synArgs args) body

262+ Nothing -> error "Type synonym was not defined"

263+

264+ensureNoDuplicateProperties :: (MonadError String m) => [(String, Value)] -> m ()

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

266+

267+infer :: Value -> Subst Type

268+infer val = rethrow (\e -> "Error inferring type of term " ++ prettyPrintValue val ++ ":\n" ++ e) $ do

269+ ty <- infer' val

270+ escapeCheckLater ty

271+ return ty

272+

273+infer' :: Value -> Subst Type

274+infer' (NumericLiteral _) = return Number

275+infer' (StringLiteral _) = return String

276+infer' (BooleanLiteral _) = return Boolean

277+infer' (ArrayLiteral vals) = do

278+ ts <- mapM (infer) vals

279+ arr <- fresh

280+ forM_ ts $ \t -> arr ~~ Array t

281+ return arr

282+infer' (Unary op val) = do

283+ t <- infer val

284+ inferUnary op t

285+infer' (Binary op left right) = do

286+ t1 <- infer left

287+ t2 <- infer right

288+ inferBinary op t1 t2

289+infer' (ObjectLiteral ps) = do

290+ ensureNoDuplicateProperties ps

291+ ts <- mapM (infer . snd) ps

292+ let fields = zipWith (\(name, _) t -> (name, t)) ps ts

293+ return $ Object $ rowFromList (fields, REmpty)

294+infer' (ObjectUpdate o ps) = do

295+ ensureNoDuplicateProperties ps

296+ row <- fresh

297+ newTys <- zipWith (\(name, _) t -> (name, t)) ps <$> mapM (infer . snd) ps

298+ oldTys <- zip (map fst ps) <$> replicateM (length ps) fresh

299+ check o $ Object $ rowFromList (oldTys, row)

300+ return $ Object $ rowFromList (newTys, row)

301+infer' (Indexer index val) = do

302+ el <- fresh

303+ check index Number

304+ check val (Array el)

305+ return el

306+infer' (Accessor prop val) = do

307+ obj <- infer val

308+ propTy <- inferProperty obj prop

309+ case propTy of

310+ Nothing -> do

311+ field <- fresh

312+ rest <- fresh

313+ obj `subsumes` Object (RCons prop field rest)

314+ return field

315+ Just ty -> return ty

316+infer' (Abs args ret) = do

317+ ts <- replicateM (length args) fresh

318+ bindLocalVariables (zip args ts) $ do

319+ body <- infer' ret

320+ return $ Function ts body

321+infer' app@(App _ _) = do

322+ let (f, argss) = unfoldApplication app

323+ ft <- infer f

324+ ret <- fresh

325+ checkFunctionApplications ft argss ret

326+ return ret

327+infer' (Var var@(Qualified mp name)) = do

328+ ty <- lookupVariable var

329+ replaceAllTypeSynonyms ty

330+infer' (Block ss) = do

331+ ret <- fresh

332+ (allCodePathsReturn, _) <- checkBlock M.empty ret ss

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

334+ return ret

335+infer' (Constructor c) = do

336+ env <- getEnv

337+ modulePath <- checkModulePath `fmap` get

338+ case M.lookup (qualify modulePath c) (dataConstructors env) of

339+ Nothing -> throwError $ "Constructor " ++ show c ++ " is undefined"

340+ Just ty -> replaceAllTypeSynonyms ty

341+infer' (Case val binders) = do

342+ t1 <- infer val

343+ ret <- fresh

344+ checkBinders t1 ret binders

345+ return ret

346+infer' (IfThenElse cond th el) = do

347+ check cond Boolean

348+ t2 <- infer th

349+ t3 <- infer el

350+ t2 ~~ t3

351+ return t2

352+infer' (TypedValue val ty) = do

353+ kind <- liftCheck $ kindOf ty

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

355+ ty' <- replaceAllTypeSynonyms ty

356+ check val ty'

357+ return ty'

358+

359+inferProperty :: Type -> String -> Subst (Maybe Type)

360+inferProperty (Object row) prop = do

361+ let (props, _) = rowToList row

362+ return $ lookup prop props

363+inferProperty (SaturatedTypeSynonym name args) prop = do

364+ replaced <- expandTypeSynonym name args

365+ inferProperty replaced prop

366+inferProperty (ForAll ident ty) prop = do

367+ replaced <- replaceVarWithUnknown ident ty

368+ inferProperty replaced prop

369+inferProperty _ prop = return Nothing

370+

371+inferUnary :: UnaryOperator -> Type -> Subst Type

372+inferUnary op val =

373+ case fromMaybe (error "Invalid operator") $ lookup op unaryOps of

374+ (valTy, resTy) -> do

375+ val ~~ valTy

376+ return resTy

377+

378+checkUnary :: UnaryOperator -> Value -> Type -> Subst ()

379+checkUnary op val res =

380+ case fromMaybe (error "Invalid operator") $ lookup op unaryOps of

381+ (valTy, resTy) -> do

382+ res ~~ resTy

383+ check val valTy

384+

385+unaryOps :: [(UnaryOperator, (Type, Type))]

386+unaryOps = [ (Negate, (Number, Number))

387+ , (Not, (Boolean, Boolean))

388+ , (BitwiseNot, (Number, Number))

389+ ]

390+

391+inferBinary :: BinaryOperator -> Type -> Type -> Subst Type

392+inferBinary op left right | isEqualityTest op = do

393+ left ~~ right

394+ return Boolean

395+inferBinary op left right =

396+ case fromMaybe (error "Invalid operator") $ lookup op binaryOps of

397+ (valTy, resTy) -> do

398+ left ~~ valTy

399+ right ~~ valTy

400+ return resTy

401+

402+checkBinary :: BinaryOperator -> Value -> Value -> Type -> Subst ()

403+checkBinary op left right res | isEqualityTest op = do

404+ res ~~ Boolean

405+ t1 <- infer left

406+ t2 <- infer right

407+ t1 ~~ t2

408+checkBinary op left right res =

409+ case fromMaybe (error "Invalid operator") $ lookup op binaryOps of

410+ (valTy, resTy) -> do

411+ res ~~ resTy

412+ check left valTy

413+ check right valTy

414+

415+isEqualityTest :: BinaryOperator -> Bool

416+isEqualityTest EqualTo = True

417+isEqualityTest NotEqualTo = True

418+isEqualityTest _ = False

419+

420+binaryOps :: [(BinaryOperator, (Type, Type))]

421+binaryOps = [ (Add, (Number, Number))

422+ , (Subtract, (Number, Number))

423+ , (Multiply, (Number, Number))

424+ , (Divide, (Number, Number))

425+ , (Modulus, (Number, Number))

426+ , (BitwiseAnd, (Number, Number))

427+ , (BitwiseOr, (Number, Number))

428+ , (BitwiseXor, (Number, Number))

429+ , (ShiftRight, (Number, Number))

430+ , (ZeroFillShiftRight, (Number, Number))

431+ , (And, (Boolean, Boolean))

432+ , (Or, (Boolean, Boolean))

433+ , (Concat, (String, String))

434+ , (Modulus, (Number, Number))

435+ , (LessThan, (Number, Boolean))

436+ , (LessThanOrEqualTo, (Number, Boolean))

437+ , (GreaterThan, (Number, Boolean))

438+ , (GreaterThanOrEqualTo, (Number, Boolean))

439+ ]

440+

441+inferBinder :: Type -> Binder -> Subst (M.Map Ident Type)

442+inferBinder _ NullBinder = return M.empty

443+inferBinder val (StringBinder _) = val ~~ String >> return M.empty

444+inferBinder val (NumberBinder _) = val ~~ Number >> return M.empty

445+inferBinder val (BooleanBinder _) = val ~~ Boolean >> return M.empty

446+inferBinder val (VarBinder name) = return $ M.singleton name val

447+inferBinder val (NullaryBinder ctor) = do

448+ env <- getEnv

449+ modulePath <- checkModulePath <$> get

450+ case M.lookup (qualify modulePath ctor) (dataConstructors env) of

451+ Just ty -> do

452+ ty `subsumes` val

453+ return M.empty

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

455+inferBinder val (UnaryBinder ctor binder) = do

456+ env <- getEnv

457+ modulePath <- checkModulePath <$> get

458+ case M.lookup (qualify modulePath ctor) (dataConstructors env) of

459+ Just ty -> do

460+ Function [obj] ret <- replaceAllVarsWithUnknowns ty

461+ val `subsumes` ret

462+ inferBinder obj binder

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

464+inferBinder val (ObjectBinder props) = do

465+ row <- fresh

466+ rest <- fresh

467+ m1 <- inferRowProperties row rest props

468+ val ~~ Object row

469+ return m1

470+ where

471+ inferRowProperties :: Row -> Row -> [(String, Binder)] -> Subst (M.Map Ident Type)

472+ inferRowProperties nrow row [] = nrow ~~ row >> return M.empty

473+ inferRowProperties nrow row ((name, binder):binders) = do

474+ propTy <- fresh

475+ m1 <- inferBinder propTy binder

476+ m2 <- inferRowProperties nrow (RCons name propTy row) binders

477+ return $ m1 `M.union` m2

478+inferBinder val (ArrayBinder binders rest) = do

479+ el <- fresh

480+ m1 <- M.unions <$> mapM (inferBinder el) binders

481+ val ~~ Array el

482+ case rest of

483+ Nothing -> return m1

484+ Just binder -> do

485+ m2 <- inferBinder val binder

486+ return $ m1 `M.union` m2

487+inferBinder val (NamedBinder name binder) = do

488+ m <- inferBinder val binder

489+ return $ M.insert name val m

490+

491+inferGuardedBinder :: Type -> Binder -> Subst (M.Map Ident Type)

492+inferGuardedBinder val (GuardedBinder cond binder) = do

493+ m1 <- inferBinder val binder

494+ bindLocalVariables (M.toList m1) $ check cond Boolean

495+ return m1

496+inferGuardedBinder val b = inferBinder val b

497+

498+checkBinders :: Type -> Type -> [(Binder, Value)] -> Subst ()

499+checkBinders _ _ [] = return ()

500+checkBinders nval ret ((binder, val):bs) = do

501+ m1 <- inferGuardedBinder nval binder

502+ bindLocalVariables (M.toList m1) $ check val ret

503+ checkBinders nval ret bs

504+

505+assignVariable :: Ident -> Subst ()

506+assignVariable name = do

507+ env <- checkEnv <$> get

508+ modulePath <- checkModulePath <$> get

509+ case M.lookup (modulePath, name) (names env) of

510+ Just (_, LocalVariable) -> throwError $ "Variable with name " ++ show name ++ " already exists."

511+ _ -> return ()

512+

513+checkStatement :: M.Map Ident Type -> Type -> Statement -> Subst (Bool, M.Map Ident Type)

514+checkStatement mass ret (VariableIntroduction name val) = do

515+ assignVariable name

516+ t <- infer val

517+ return (False, M.insert name t mass)

518+checkStatement mass ret (Assignment ident val) = do

519+ t <- infer val

520+ case M.lookup ident mass of

521+ Nothing -> throwError $ "No local variable with name " ++ show ident

522+ Just ty -> do t ~~ ty

523+ return (False, mass)

524+checkStatement mass ret (While val inner) = do

525+ check val Boolean

526+ (allCodePathsReturn, _) <- checkBlock mass ret inner

527+ return (allCodePathsReturn, mass)

528+checkStatement mass ret (If ifst) = do

529+ allCodePathsReturn <- checkIfStatement mass ret ifst

530+ return (allCodePathsReturn, mass)

531+checkStatement mass ret (For ident start end inner) = do

532+ assignVariable ident

533+ check start Number

534+ check end Number

535+ (allCodePathsReturn, _) <- bindLocalVariables [(ident, Number)] $ checkBlock mass ret inner

536+ return (allCodePathsReturn, mass)

537+checkStatement mass ret (ForEach ident vals inner) = do

538+ assignVariable ident

539+ val <- fresh

540+ check vals (Array val)

541+ (allCodePathsReturn, _) <- bindLocalVariables [(ident, val)] $ checkBlock mass ret inner

542+ guardWith "Cannot return from within a foreach block" $ not allCodePathsReturn

543+ return (False, mass)

544+checkStatement mass ret (Return val) = do

545+ check val ret

546+ return (True, mass)

547+

548+checkIfStatement :: M.Map Ident Type -> Type -> IfStatement -> Subst Bool

549+checkIfStatement mass ret (IfStatement val thens Nothing) = do

550+ check val Boolean

551+ _ <- checkBlock mass ret thens

552+ return False

553+checkIfStatement mass ret (IfStatement val thens (Just elses)) = do

554+ check val Boolean

555+ (allCodePathsReturn1, _) <- checkBlock mass ret thens

556+ allCodePathsReturn2 <- checkElseStatement mass ret elses

557+ return $ allCodePathsReturn1 && allCodePathsReturn2

558+

559+checkElseStatement :: M.Map Ident Type -> Type -> ElseStatement -> Subst Bool

560+checkElseStatement mass ret (Else elses) = fst <$> checkBlock mass ret elses

561+checkElseStatement mass ret (ElseIf ifst) = checkIfStatement mass ret ifst

562+

563+checkBlock :: M.Map Ident Type -> Type -> [Statement] -> Subst (Bool, M.Map Ident Type)

564+checkBlock mass _ [] = return (False, mass)

565+checkBlock mass ret (s:ss) = do

566+ (b1, mass1) <- checkStatement mass ret s

567+ bindLocalVariables (M.toList mass1) $ case (b1, ss) of

568+ (True, []) -> return (True, mass1)

569+ (True, _) -> throwError "Unreachable code"

570+ (False, ss) -> checkBlock mass1 ret ss

571+

572+skolemize :: String -> Type -> Subst Type

573+skolemize ident ty = do

574+ tsk <- Skolem <$> fresh'

575+ rsk <- RSkolem <$> fresh'

576+ return $ replaceRowVars ident rsk $ replaceTypeVars ident tsk ty

577+

578+check :: Value -> Type -> Subst ()

579+check val ty = rethrow errorMessage $ check' val ty

580+ where

581+ errorMessage msg =

582+ "Error checking type of term " ++

583+ prettyPrintValue val ++

584+ " against type " ++

585+ prettyPrintType ty ++

586+ ":\n" ++

587+ msg

588+

589+check' :: Value -> Type -> Subst ()

590+check' val (ForAll idents ty) = do

591+ sk <- skolemize idents ty

592+ check val sk

593+check' val u@(TUnknown _) = do

594+ ty <- infer val

595+ -- Don't unify an unknown with an inferred polytype

596+ ty' <- replaceAllVarsWithUnknowns ty

597+ ty' ~~ u

598+check' (NumericLiteral _) Number = return ()

599+check' (StringLiteral _) String = return ()

600+check' (BooleanLiteral _) Boolean = return ()

601+check' (Unary op val) ty = checkUnary op val ty

602+check' (Binary op left right) ty = checkBinary op left right ty

603+check' (ArrayLiteral vals) (Array ty) = forM_ vals (\val -> check val ty)

604+check' (Indexer index vals) ty = check index Number >> check vals (Array ty)

605+check' (Abs args ret) (Function argTys retTy) = do

606+ guardWith "Incorrect number of function arguments" (length args == length argTys)

607+ bindLocalVariables (zip args argTys) $ check ret retTy

608+check' app@(App _ _) ret = do

609+ let (f, argss) = unfoldApplication app

610+ ft <- infer f

611+ checkFunctionApplications ft argss ret

612+check' v@(Var var@(Qualified mp name)) ty = do

613+ ty1 <- lookupVariable var

614+ repl <- replaceAllTypeSynonyms ty1

615+ repl `subsumes` ty

616+check' (TypedValue val ty1) ty2 = do

617+ kind <- liftCheck $ kindOf ty1

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

619+ ty1 `subsumes` ty2

620+ check val ty1

621+check' (Case val binders) ret = do

622+ t1 <- infer val

623+ checkBinders t1 ret binders

624+check' (IfThenElse cond th el) ty = do

625+ check cond Boolean

626+ check th ty

627+ check el ty

628+check' (ObjectLiteral ps) (Object row) = do

629+ ensureNoDuplicateProperties ps

630+ checkProperties ps row False

631+check' (ObjectUpdate obj ps) (Object row) = do

632+ ensureNoDuplicateProperties ps

633+ us <- zip (map fst ps) <$> replicateM (length ps) fresh

634+ let (propsToCheck, rest) = rowToList row

635+ propsToRemove = map fst ps

636+ remainingProps = filter (\(p, _) -> p `notElem` propsToRemove) propsToCheck

637+ check obj (Object (rowFromList (us ++ remainingProps, rest)))

638+ checkProperties ps row True

639+check' (Accessor prop val) ty = do

640+ rest <- fresh

641+ check val (Object (RCons prop ty rest))

642+check' (Block ss) ret = do

643+ (allCodePathsReturn, _) <- checkBlock M.empty ret ss

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

645+check' (Constructor c) ty = do

646+ env <- getEnv

647+ modulePath <- checkModulePath <$> get

648+ case M.lookup (qualify modulePath c) (dataConstructors env) of

649+ Nothing -> throwError $ "Constructor " ++ show c ++ " is undefined"

650+ Just ty1 -> do

651+ repl <- replaceAllTypeSynonyms ty1

652+ repl `subsumes` ty

653+check' val (SaturatedTypeSynonym name args) = do

654+ ty <- expandTypeSynonym name args

655+ check val ty

656+check' val ty = throwError $ prettyPrintValue val ++ " does not have type " ++ prettyPrintType ty

657+

658+checkProperties :: [(String, Value)] -> Row -> Bool -> Subst ()

659+checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where

660+ go [] [] REmpty = return ()

661+ go [] [] u@(RUnknown _) = u ~~ REmpty

662+ go [] [] (RSkolem _) | lax = return ()

663+ go [] ((p, _): _) _ | lax = return ()

664+ | otherwise = throwError $ prettyPrintValue (ObjectLiteral ps) ++ " does not have property " ++ p

665+ go ((p,_):_) [] REmpty = throwError $ "Property " ++ p ++ " is not present in closed object type " ++ prettyPrintRow row

666+ go ((p,v):ps) [] u@(RUnknown _) = do

667+ ty <- infer v

668+ rest <- fresh

669+ u ~~ RCons p ty rest

670+ go ps [] rest

671+ go ((p,v):ps) ts r =

672+ case lookup p ts of

673+ Nothing -> do

674+ ty <- infer v

675+ rest <- fresh

676+ r ~~ RCons p ty rest

677+ go ps ts rest

678+ Just ty -> do

679+ check v ty

680+ go ps (delete (p, ty) ts) r

681+ go _ _ _ = throwError $ prettyPrintValue (ObjectLiteral ps) ++ " does not have type " ++ prettyPrintType (Object row)

682+

683+unfoldApplication :: Value -> (Value, [[Value]])

684+unfoldApplication = go []

685+ where

686+ go argss (App f args) = go (args:argss) f

687+ go argss f = (f, argss)

688+

689+checkFunctionApplications :: Type -> [[Value]] -> Type -> Subst ()

690+checkFunctionApplications _ [] _ = error "Nullary function application"

691+checkFunctionApplications fnTy [args] ret = checkFunctionApplication fnTy args ret

692+checkFunctionApplications fnTy (args:argss) ret = do

693+ argTys <- mapM (infer) args

694+ f <- inferFunctionApplication fnTy argTys

695+ checkFunctionApplications f argss ret

696+

697+checkFunctionApplication :: Type -> [Value] -> Type -> Subst ()

698+checkFunctionApplication fnTy args ret = rethrow errorMessage $ checkFunctionApplication' fnTy args ret

699+ where

700+ errorMessage msg = "Error applying function of type "

701+ ++ prettyPrintType fnTy

702+ ++ " to arguments " ++ intercalate ", " (map prettyPrintValue args)

703+ ++ ", expecting value of type "

704+ ++ prettyPrintType ret ++ ":\n" ++ msg

705+

706+inferFunctionApplication :: Type -> [Type] -> Subst Type

707+inferFunctionApplication (Function argTys retTy) args = do

708+ guardWith "Incorrect number of function arguments" (length args == length argTys)

709+ zipWithM subsumes args argTys

710+ return retTy

711+inferFunctionApplication (ForAll ident ty) args = do

712+ replaced <- replaceVarWithUnknown ident ty

713+ inferFunctionApplication replaced args

714+inferFunctionApplication u@(TUnknown _) args = do

715+ ret <- fresh

716+ args' <- mapM replaceAllVarsWithUnknowns args

717+ u ~~ Function args' ret

718+ return ret

719+inferFunctionApplication (SaturatedTypeSynonym name tyArgs) args = do

720+ ty <- expandTypeSynonym name tyArgs

721+ inferFunctionApplication ty args

722+inferFunctionApplication fnTy args = throwError $ "Cannot apply function of type "

723+ ++ prettyPrintType fnTy

724+ ++ " to argument(s) of type(s) " ++ intercalate ", " (map prettyPrintType args)

725+

726+checkFunctionApplication' :: Type -> [Value] -> Type -> Subst ()

727+checkFunctionApplication' (Function argTys retTy) args ret = do

728+ guardWith "Incorrect number of function arguments" (length args == length argTys)

729+ zipWithM (check) args argTys

730+ retTy `subsumes` ret

731+checkFunctionApplication' (ForAll ident ty) args ret = do

732+ replaced <- replaceVarWithUnknown ident ty

733+ checkFunctionApplication replaced args ret

734+checkFunctionApplication' u@(TUnknown _) args ret = do

735+ tyArgs <- mapM (\arg -> infer arg >>= replaceAllVarsWithUnknowns) args

736+ u ~~ Function tyArgs ret

737+checkFunctionApplication' (SaturatedTypeSynonym name tyArgs) args ret = do

738+ ty <- expandTypeSynonym name tyArgs

739+ checkFunctionApplication' ty args ret

740+checkFunctionApplication' fnTy args ret = throwError $ "Applying a function of type "

741+ ++ prettyPrintType fnTy

742+ ++ " to argument(s) " ++ intercalate ", " (map prettyPrintValue args)

743+ ++ " does not yield a value of type " ++ prettyPrintType ret ++ "."

744+

745+subsumes :: Type -> Type -> Subst ()

746+subsumes (ForAll ident ty1) ty2 = do

747+ replaced <- replaceVarWithUnknown ident ty1

748+ replaced `subsumes` ty2

749+subsumes (Function args1 ret1) (Function args2 ret2) = do

750+ zipWithM subsumes args2 args1

751+ ret1 `subsumes` ret2

752+subsumes ty1 ty2 = ty1 ~~ ty2

753+

src/Language/PureScript/Types.hsnew file+70

@@ -0,0 +1,70 @@

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

2+--

3+-- Module : Language.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 Language.PureScript.Types where

18+

19+import Data.Data

20+import Language.PureScript.Names

21+import Language.PureScript.Unknown (Unknown(..))

22+

23+data Type

24+ = TUnknown (Unknown Type)

25+ | Number

26+ | String

27+ | Boolean

28+ | Array Type

29+ | Object Row

30+ | Function [PolyType] Type

31+ | TypeVar String

32+ | TypeConstructor (Qualified ProperName)

33+ | TypeApp Type Type

34+ | SaturatedTypeSynonym (Qualified ProperName) [Type]

35+ | ForAll String Type

36+ | Skolem Int deriving (Show, Eq, Data, Typeable)

37+

38+type PolyType = Type

39+

40+data Row

41+ = RUnknown (Unknown Row)

42+ | RowVar String

43+ | REmpty

44+ | RCons String Type Row

45+ | RSkolem Int deriving (Show, Eq, Data, Typeable)

46+

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

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

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

50+rowToList r = ([], r)

51+

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

53+rowFromList ([], r) = r

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

55+

56+isMonoType :: Type -> Bool

57+isMonoType (ForAll _ _) = False

58+isMonoType ty = isPolyType ty

59+

60+isPolyType :: Type -> Bool

61+isPolyType (Array ty) = isMonoType ty

62+isPolyType (Object ps) = all isPolyType (map snd . fst $ rowToList ps)

63+isPolyType (Function args ret) = all isPolyType args && isPolyType ret

64+isPolyType (TypeApp t1 t2) = isMonoType t1 && isMonoType t2

65+isPolyType (SaturatedTypeSynonym _ args) = all isPolyType args

66+isPolyType (ForAll idents ty) = isPolyType ty

67+isPolyType _ = True

68+

69+mkForAll :: [String] -> Type -> Type

70+mkForAll = flip . foldl . flip $ ForAll

src/Language/PureScript/Unknown.hsnew file+25

@@ -0,0 +1,25 @@

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

2+--

3+-- Module : Language.PureScript.Unknown

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 Language.PureScript.Unknown where

18+

19+import Data.Data

20+import Data.Typeable

21+

22+newtype Unknown t = Unknown { runUnknown :: Int } deriving (Show, Eq, Ord, Data, Typeable)

23+

24+

25+

src/Language/PureScript/Values.hsnew file+99

@@ -0,0 +1,99 @@

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

2+--

3+-- Module : Language.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 Language.PureScript.Values where

18+

19+import Language.PureScript.Types

20+import Language.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+ | BinaryNoParens (Qualified Ident) Value Value

58+ | Parens Value

59+ | ArrayLiteral [Value]

60+ | Indexer Value Value

61+ | ObjectLiteral [(String, Value)]

62+ | Accessor String Value

63+ | ObjectUpdate Value [(String, Value)]

64+ | Abs [Ident] Value

65+ | App Value [Value]

66+ | Var (Qualified Ident)

67+ | IfThenElse Value Value Value

68+ | Block [Statement]

69+ | Constructor (Qualified ProperName)

70+ | Case Value [(Binder, Value)]

71+ | TypedValue Value PolyType deriving (Show, Data, Typeable)

72+

73+data Statement

74+ = VariableIntroduction Ident Value

75+ | Assignment Ident Value

76+ | While Value [Statement]

77+ | For Ident Value Value [Statement]

78+ | ForEach Ident Value [Statement]

79+ | If IfStatement

80+ | Return Value deriving (Show, Data, Typeable)

81+

82+data IfStatement = IfStatement Value [Statement] (Maybe ElseStatement) deriving (Show, Data, Typeable)

83+

84+data ElseStatement

85+ = Else [Statement]

86+ | ElseIf IfStatement deriving (Show, Data, Typeable)

87+

88+data Binder

89+ = NullBinder

90+ | BooleanBinder Bool

91+ | StringBinder String

92+ | NumberBinder (Either Integer Double)

93+ | VarBinder Ident

94+ | NullaryBinder (Qualified ProperName)

95+ | UnaryBinder (Qualified ProperName) Binder

96+ | ObjectBinder [(String, Binder)]

97+ | ArrayBinder [Binder] (Maybe Binder)

98+ | NamedBinder Ident Binder

99+ | GuardedBinder Value Binder deriving (Show, Data, Typeable)

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 qualified Language.PureScript as P

18+import Data.Maybe (mapMaybe)

19+import Data.List (intercalate)

20+import System.Console.CmdTheLine

21+import Control.Applicative

22+import Control.Monad (forM)

23+import System.Exit (exitSuccess, exitFailure)

24+import qualified Text.Parsec as P

25+import qualified System.IO.UTF8 as U

26+import qualified Data.Map as M

27+

28+compile :: [FilePath] -> Maybe FilePath -> Maybe FilePath -> IO ()

29+compile inputFiles outputFile externsFile = do

30+ asts <- fmap (fmap concat . sequence) $ forM inputFiles $ \inputFile -> do

31+ text <- U.readFile inputFile

32+ return $ P.runIndentParser P.parseDeclarations text

33+ case asts of

34+ Left err -> do

35+ U.print err

36+ exitFailure

37+ Right decls ->

38+ case P.compile decls of

39+ Left error -> do

40+ U.putStrLn error

41+ exitFailure

42+ Right (js, exts, _) -> do

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 exts

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/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 qualified Language.PureScript as P

18+

19+import Data.List (isSuffixOf)

20+import Control.Applicative

21+import Control.Monad

22+import System.Exit (exitSuccess, exitFailure)

23+import System.FilePath (pathSeparator)

24+import System.Directory (getCurrentDirectory, getDirectoryContents)

25+import qualified System.IO.UTF8 as U

26+import qualified Data.Map as M

27+

28+compile :: FilePath -> IO (Either String P.Environment)

29+compile inputFile = do

30+ ast <- P.runIndentParser P.parseDeclarations <$> U.readFile inputFile

31+ case ast of

32+ Left parseError -> do

33+ return (Left $ show parseError)

34+ Right decls -> do

35+ case P.compile decls of

36+ Left typeError -> do

37+ return (Left typeError)

38+ Right (_, _, env) -> do

39+ return (Right env)

40+

41+assert :: FilePath -> (Either String P.Environment -> Maybe String) -> IO ()

42+assert inputFile f = do

43+ e <- compile inputFile

44+ case f e of

45+ Just err -> exitFailure

46+ Nothing -> return ()

47+

48+assertCompiles :: FilePath -> IO ()

49+assertCompiles inputFile = do

50+ putStrLn $ "assert " ++ inputFile ++ " compiles successfully"

51+ assert inputFile $ either Just (const Nothing)

52+

53+assertDoesNotCompile :: FilePath -> IO ()

54+assertDoesNotCompile inputFile = do

55+ putStrLn $ "assert " ++ inputFile ++ " does not compile"

56+ assert inputFile $ either (const Nothing) (const $ Just "Should not have compiled")

57+

58+main :: IO ()

59+main = do

60+ cd <- getCurrentDirectory

61+ putStrLn $ cd

62+ let examples = cd ++ pathSeparator : "examples"

63+ let passing = examples ++ pathSeparator : "passing"

64+ passingTestCases <- getDirectoryContents passing

65+ forM_ passingTestCases $ \inputFile -> when (".purs" `isSuffixOf` inputFile) $

66+ assertCompiles (passing ++ pathSeparator : inputFile)

67+ let failing = examples ++ pathSeparator : "failing"

68+ failingTestCases <- getDirectoryContents failing

69+ forM_ failingTestCases $ \inputFile -> when (".purs" `isSuffixOf` inputFile) $

70+ assertDoesNotCompile (failing ++ pathSeparator : inputFile)

71+ exitSuccess