golang..5b2d549 · rowtype-yoga/purescript-native

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

145 files changed+7725−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+857−28

@@ -1,41 +1,870 @@

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+Bitcoin donations are gratefully accepted at 14ZhCym28WDuFhocP44tU1dBpCzjX1DvhF.

209

10+## Current Features

2111

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

12+- Full Type Inference

13+- Higher Kinded Polymorphism

14+- Support for basic Javascript types

15+- Extensible records

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

17+- Functions with multiple arguments

18+- Pattern matching

19+- Simple FFI

20+- Modules

21+- Rank N Types

22+- Do Notation

23+- Optional tail-call elimination

24+- Type Classes

2325

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

26+## Try It!

2527

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

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

2729

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

30+## License

2931

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.

32+See the `LICENSE` file

3433

34+## Contributing

3535

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)

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

3937

38+Join the discussion on FreeNode at <a href="irc://irc.freenode.net/#purescript">#purescript</a>.

4039

41−---

40+## Installation

41+

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

43+

44+## Usage

45+

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

47+

48+The following options are supported:

49+

50+ -s --stdin

51+ Read input from standard input instead of from files

52+

53+ -o --output

54+ Write the generated Javascript to the specified file

55+

56+ -e --foreign imports

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

58+

59+ --runtime-type-checks

60+ Generate simple runtime type checks for function arguments with simple types.

61+

62+ --tco

63+ Perform tail-call elimination on the generated Javascript.

64+

65+ --no-prelude

66+ Do not include the Prelude in the generated Javascript.

67+

68+ --magic-do

69+ Overload the `do` keyword to inline calls to `bind` for the `Eff` monad, to generate more efficient code.

70+

71+ --run-main

72+ Generate a call to `Main.main` after all other generated Javascript.

73+

74+## Motivation

75+

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

77+

78+- Generate simple readable Javascript

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

80+- Reasonable type system

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

82+- Provides a simple interface to existing Javascript code

83+

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

85+

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

87+

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

89+

90+## Hello, PureScript!

91+

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

93+

94+```haskell

95+module Main where

96+

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

98+

99+main = \ -> console.log "Hello, World!"

100+```

101+

102+which compiles to the following Javascript:

103+

104+```javascript

105+var Main;

106+(function (Main) {

107+ function main() {

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

109+ };

110+ Main.main = main;

111+})(Main = Main || {});

112+```

113+

114+## Another Example

115+

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

117+

118+```haskell

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

120+

121+foreign import numberToString :: Number -> String

122+

123+showPerson :: Person -> String

124+showPerson (Person o) = o.name ++ ", aged " ++ numberToString(o.age)

125+```

126+

127+Line by line, this reads as follows:

128+

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

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

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

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

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

134+

135+The generated Javascript looks like this:

136+

137+```javascript

138+var Person = function (value) {

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

140+};

141+

142+function showPerson(_1) {

143+ if (_1.ctor === "Person") {

144+ return _1.value.name + ", aged " + numberToString(_1.value.age);

145+ };

146+ throw "Failed pattern match";

147+};

148+

149+```

150+

151+## Type System

152+

153+The type system defines the following types:

154+

155+- Primitive Types

156+ - Number

157+ - String

158+ - Boolean

159+- Arrays

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

161+- Records

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

163+- Tagged Unions

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

165+- Functions

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

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

168+ - Functions can have zero or more arguments

169+- Polymorphic types

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

171+

172+## Primitive Types

173+

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

175+

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

177+

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

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

180+

181+Examples:

182+

183+```haskell

184+num = 1 + 2 * 3

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

186+bool = 1 > 2 || true

187+```

188+

189+## Arrays

190+

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

192+

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

194+

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

196+

197+## Records

198+

199+PureScript records correspond to Javascript objects.

200+

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

202+

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

204+

205+## Tagged Unions

206+

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

208+

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

210+

211+For example:

212+

213+```haskell

214+data Foo a = Foo | Bar String

215+

216+runFoo Foo = "It's a Foo"

217+runFoo (Bar s) = "It's a Bar. The string is " ++ s

218+

219+test = runFoo Foo ++ runFoo (Bar "Test")

220+```

221+

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

223+

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

225+

226+## Functions

227+

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

229+

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

231+

232+```haskell

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

234+```

235+

236+which would correspond to the Javascript

237+

238+```javascript

239+function test1(a) {

240+ return function (b) {

241+ return a + b;

242+ }

243+}

244+```

245+

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

247+

248+```haskell

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

250+```

251+

252+which generates

253+

254+```javascript

255+function test1(a, b) {

256+ return a + b;

257+}

258+```

259+

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

261+

262+```haskell

263+test2 = \ -> 100

264+```

265+

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

267+

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

269+

270+```haskell

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

272+```

273+

274+which generates

275+

276+```javascript

277+function test3(a) {

278+ return function (b, c) {

279+ return function (d) {

280+ return a + b + c + d;

281+ }

282+ }

283+}

284+```

285+

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

287+

288+```haskell

289+test1(1, 2, 3)

290+test2()

291+```

292+

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

294+

295+```haskell

296+-- has type Number -> Number -> Number -> Number

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

298+

299+-- has type Number -> Number -> Number

300+addThree 1

301+

302+-- has type Number -> Number

303+addThree 1 2

304+

305+-- has type Number

306+addThree 1 2 3

307+```

308+

309+## Polymorphic Types

310+

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

312+

313+Here is an example:

314+

315+```haskell

316+identity x = x

317+```

318+

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

320+

321+A type annotation can also be provided:

322+

323+```haskell

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

325+identity x = x

326+```

327+

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

329+

330+```haskell

331+addProps o = o.foo + o.bar

332+```

333+

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

335+

336+So, the following compiles:

337+

338+```haskell

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

340+```

341+

342+but the following does not:

343+

344+```haskell

345+addProps { foo: 1 }

346+```

347+

348+since the `bar` property is missing.

349+

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

351+

352+## Rank N Types

353+

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

355+

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

357+

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

359+

360+```haskell

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

362+poly f = (f 0 < 1) == f true

363+```

364+

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

366+

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

368+

369+```haskell

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

371+```

372+

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

374+

375+## Type Inference

376+

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

378+

379+## Kind System

380+

381+There are two primitive kinds, the kind `*` of types and the kind `!` of effects.

382+

383+For each kind `k` there is also a kind `# k` of rows, with types of kind `k`. For example `# *` is the kind of rows of types, as used to define records, and `# !` is the kind of rows of effects, used to define the monad `Eff` of extensible effects.

384+

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

386+

387+## Whitespace

388+

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

390+

391+That is, the following is valid:

392+

393+```haskell

394+foo = bar(x) +

395+ baz(x)

396+```

397+

398+But this is not:

399+

400+```haskell

401+foo = bar(x) +

402+baz(x)

403+```

404+

405+## Blocks

406+

407+Blocks are collections of statements wrapped in braces `{ ... }`. Blocks must return a value of the same type on every branch of execution.

408+

409+The following types of statement are supported:

410+

411+- Variable introduction

412+- Variable assignment

413+- For loops

414+- For-each loops

415+- While loops

416+- If-Then-Else statements

417+

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

419+

420+```haskell

421+pow n p = {

422+ var m = n;

423+ for (i <- 0 until p) {

424+ m = m * n;

425+ }

426+ return m;

427+ }

428+```

429+

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

431+

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

433+

434+```haskell

435+incr n = {

436+ n = n + 1;

437+ return n;

438+ }

439+```

440+

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

442+

443+This function can be rewritten as follows:

444+

445+```haskell

446+incr n = {

447+ var m = n;

448+ m = m + 1;

449+ return m;

450+ }

451+```

452+

453+## For Loops

454+

455+For loops look like this:

456+

457+```haskell

458+total = {

459+ var n = 0;

460+ for (i <- 0 until 10) {

461+ n = n + i;

462+ }

463+ return n;

464+ }

465+```

466+

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

468+

469+## For-Each Loops

470+

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

472+

473+```haskell

474+total arr = {

475+ var n = 0;

476+ foreach (i in arr) {

477+ n = n + i;

478+ }

479+ return n;

480+ }

481+```

482+

483+## While Loops

484+

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

486+

487+```haskell

488+log2 n = {

489+ var count = 0;

490+ var m = n;

491+ while (m > 1) {

492+ m = m / 2;

493+ count = count + 1;

494+ }

495+ return count;

496+ }

497+```

498+

499+## If-Then-Else Statements

500+

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

502+

503+```haskell

504+collatz n = {

505+ var count = 0;

506+ var m = n;

507+ while (m > 1) {

508+ if (m % 2 == 0) {

509+ m = m / 2;

510+ } else {

511+ m = m * 3 + 1;

512+ }

513+ count = count + 1;

514+ }

515+ return count;

516+ }

517+```

518+

519+## If-Then-Else Expressions

520+

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

522+

523+For example,

524+

525+```haskell

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

527+```

528+

529+## Do Notation

530+

531+The `do` keyword introduces simple syntactic sugar for monadic expressions.

532+

533+Here is an example, using the maybe monad:

534+

535+```haskell

536+data Maybe a = Nothing | Just a

537+

538+instance Monad Maybe where

539+ ret = Just

540+ (>>=) Nothing _ = Nothing

541+ (>>=) (Just a) f = f a

542+

543+isEven n | n % 2 == 0 = Just {}

544+isEven _ = Nothing

545+

546+evenSum a b = do

547+ n <- a

548+ m <- b

549+ let sum = n + m

550+ isEven sum

551+ ret sum

552+```

553+

554+`isEven` adds two values of type `Maybe Number` and returns their sum, if the sum is even. If the sum is odd, `evenSum` returns `Nothing`.

555+

556+This example illustrates the following aspects of `do` notation:

557+

558+- The corresponding type constructor must be an instance of the `Prelude.Monad` type class, which defines the `ret` and `>>=` functions.

559+- Statements can have the following form:

560+ - `a <- x` which desugars to `m.bind x (\a -> ...)`

561+ - `let a = x` which desugars to `(\a -> ...)(x)`

562+ - `x` which desugars to `m.bind x (\_ -> ...)` or just `x` if this is the last statement.

563+

564+Not illustrated here, but equally valid is the use of a binder on the left hand side of `<-` or `=`. For example:

565+

566+```haskell

567+test arr = do

568+ (x:y:_) <- arr

569+ ret (x + y)

570+```

571+

572+A pattern match failure will generate a runtime exception, just as in the case of a regular `case` statement.

573+

574+## Pattern Matching

575+

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

577+

578+Pattern matches have the following general form

579+

580+```haskell

581+case value of

582+ pattern -> result

583+ -- ...

584+ pattern -> result

585+```

586+

587+Pattern matching can also be used in the declaration of functions, as we have already seen:

588+

589+```haskell

590+fn pattern_1 ... pattern_n = result

591+```

592+

593+Any of the above types of pattern are also valid when introducing functions. In addition, patterns can also be grouped in parentheses to introduce multiple-arugument functions. For example,

594+

595+```haskell

596+example x (y, z) w = x * y + z * w

597+```

598+

599+The following pattern types are supported:

600+

601+- Wildcard pattern

602+- Literal patterns

603+- Variable pattern

604+- Array patterns

605+- Cons patterns

606+- Record patterns

607+- Named patterns

608+- Guards

609+

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

611+

612+## Wildcard Patterns

613+

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

615+

616+```haskell

617+case x of

618+ _ -> 0

619+```

620+

621+## Literal Patterns

622+

623+Literal patterns are provided to match on primitives:

624+

625+```haskell

626+case booleanValue of

627+ true -> 0

628+ false -> 1

629+

630+case stringValue of

631+ "Foo" -> 0

632+ _ -> 1

633+

634+case numericValue of

635+ 0 -> 0

636+ _ -> 1

637+```

638+

639+## Variable Pattern

640+

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

642+

643+```haskell

644+case foo(x) of

645+ result -> bar(result)

646+```

647+

648+## Array Patterns

649+

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

651+

652+For example:

653+

654+```haskell

655+f = \arr -> case arr of

656+ [x] -> x

657+ [x, y] -> x * y + f xs

658+ _ -> 0

659+```

660+

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

662+

663+The second pattern matches arrays with two elements, and brings the first and second elements into scope.

664+

665+## Cons Patterns

666+

667+The head and tail of a non-empty array can be matched by using a cons pattern:

668+

669+```haskell

670+add = \arr -> case arr of

671+ [] -> 0

672+ x : xs -> x + add xs

673+```

674+

675+`:` associates to the right:

676+

677+```haskell

678+addPairs = \arr -> case arr of

679+ x : y : xs -> x * y + addPairs xs

680+ _ -> 0

681+```

682+

683+## Record Patterns

684+

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

686+

687+```haskell

688+f = \o -> case o of

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

690+ _ -> 0

691+```

692+

693+## Nested Patterns

694+

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

696+

697+For example:

698+

699+```haskell

700+f = \o -> case o of

701+ { arr = x : _, take = "car" } -> x

702+ { arr = _ : x : _, take = "cadr" } -> x

703+ _ -> 0

704+```

705+

706+## Named Patterns

707+

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

709+

710+```haskell

711+f = \arr -> case arr of

712+ a@(_ : _ : _) -> true

713+ a -> false

714+```

715+

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

717+

718+## Guards

719+

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

721+

722+```haskell

723+evens = \arr -> case arr of

724+ [] -> 0

725+ x : xs | x % 2 == 0 -> 1 + evens xs

726+ _ : xs -> evens xs

727+```

728+

729+When defining a function, guards appear after all patterns:

730+

731+```haskell

732+greater x y | x > y = true

733+greater _ _ = false

734+```

735+

736+## Type Synonyms

737+

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

739+

740+For example:

741+

742+```haskell

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

744+

745+addFoo :: Foo -> Number

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

747+```

748+## Record Updates

749+

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

751+

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

753+

754+```haskell

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

756+```

757+

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

759+

760+```haskell

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

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

763+};

764+```

765+

766+## Operators

767+

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

769+

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

771+

772+```haskell

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

774+

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

776+```

777+

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

779+

780+```haskell

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

782+

783+test = 10 `foo` 20

784+```

785+

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

787+

788+```haskell

789+infixl 5 <>

790+infixr 7 %%

791+```

792+

793+## Modules

794+

795+Modules are introduced using the `module` keyword. All code must be placed in a module.

796+

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

798+

799+```haskell

800+module A where

801+

802+id x = x

803+```

804+

805+Names may be qualified by using a dot:

806+

807+```

808+foo = A.foo

809+bar = A.B.bar

810+```

811+

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

813+

814+```haskell

815+import A

816+```

817+

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

819+

820+```haskell

821+import A.B (bar)

822+```

823+

824+## Foreign Function Interface

825+

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

827+

828+```haskell

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

830+```

831+

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

833+

834+```haskell

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

836+

837+foreign import console :: {

838+ log :: String -> IO {}

839+}

840+```

841+

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

843+

844+```haskell

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

846+```

847+

848+## Type Classes

849+

850+PureScript has basic support for type classes via the `class` and `instance` keywords.

851+

852+```haskell

853+class Show a where

854+ show :: a -> String

855+

856+instance Show String where

857+ show s = s

858+

859+instance Show Boolean where

860+ show true = "true"

861+ show false = "false"

862+

863+instance (Show a) => Show [a] where

864+ show arr = "[" ++ showArray arr ++ "]"

865+

866+showArray :: forall a. (Show a) => [a] -> String

867+showArray [] = ""

868+showArray [x] = show x

869+showArray (x:xs) = show x ++ ", " ++ showArray xs

870+```

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

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

1+module Arrays where

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

examples/failing/Do.pursnew file+10

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

1+module Do where

3+id = { ret: \x -> x, bind: \x f -> f x }

5+test1 = id do let x = 1

7+test2 y = id do x <- y

9+test3 = id do return 1

10+ return 2

examples/failing/Import.pursnew file+3

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

1+module Module where

3+ import UndefinedModule

examples/failing/KindError.pursnew file+3

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

1+module KindError where

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

examples/failing/LocalVars.pursnew file+6

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

1+module LocalVars where

3+ bad = \x -> {

4+ x = x + 1;

5+ return x;

6+ }

examples/failing/PatternScope.pursnew file+10

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

1+module PatternScope where

3+ -- Pattern scope doesn't leak

4+ foobar = \x -> {

5+ var y = case x of

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

7+ _ -> 2;

8+ return z;

9+ }

10+

examples/failing/Rank2Types.pursnew file+5

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

1+module Rank2Types where

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

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

examples/failing/ReadShow.pursnew file+7

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

1+module ReadShow where

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

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

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

examples/failing/SkolemEscape.pursnew file+5

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

1+module SkolemEscape where

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

5+ test = \x -> foo x

examples/failing/TypeClasses.pursnew file+7

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

1+module TypeClasses where

3+class Show a where

4+ show :: a -> String

6+instance TypeClasses.Show ([[String]]) where

7+ show _ = "array"

examples/failing/TypeError.pursnew file+3

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

1+module TypeError where

3+ test = x ++ "A"

examples/passing/Arrays.pursnew file+21

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

1+module Arrays where

3+test1 = \arr -> arr !! 0 + arr !! 1

5+test2 = \arr -> case arr of

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

7+ [x] -> x

8+ [] -> 0

9+ (x : y : _) -> x + y

10+

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

12+

13+test3 = \(tree, sum) -> case tree of

14+ One n -> n

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

16+

17+test4 = \arr -> case arr of

18+ [] -> 0

19+ [_] -> 0

20+ x : y : xs -> x * y + test4 xs

21+

examples/passing/Assign.pursnew file+9

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

1+module Assign where

3+ sum = \n -> {

4+ var x = 0;

5+ for (i <- 0 until n) {

6+ x = x + i;

7+ }

8+ return x;

9+ }

examples/passing/Auto.pursnew file+11

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

1+module Auto where

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

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

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

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

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

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

examples/passing/Church.pursnew file+14

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

1+module Church where

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

5+ empty :: forall a. List a

6+ empty = \r f -> r

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

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

10+

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

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

13+

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

examples/passing/Conditional.pursnew file+7

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

1+module Conditional where

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

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

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

examples/passing/Cons.pursnew file+9

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

1+module Cons where

3+ infixr 6 :

5+ foreign import (:) :: forall a. a -> [a] -> [a]

7+ test1 = \xs -> 1 : xs

9+ test2 = 1 : 2 : 3 : []

examples/passing/Console.pursnew file+25

@@ -0,0 +1,25 @@

1+module Console where

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

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

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

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

10+

11+ foreign import putStrLn :: String -> IO {}

12+

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

14+ replicateM_ = \n -> \x ->

15+ {

16+ var io = ret {};

17+ for (i <- 0 until n)

18+ {

19+ io = x *> io;

20+ }

21+ return io;

22+ }

23+

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

25+

examples/passing/DataImport.pursnew file+12

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

1+module M1 where

3+data Test = Test

5+module M2 where

7+import M1

9+test :: Test -> M1.Test

10+test t = t

11+

12+testCtor = Test

examples/passing/Do.pursnew file+65

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

1+module Prelude where

3+class Monad m where

4+ ret :: forall a. a -> m a

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

7+module Do where

9+import Prelude

10+

11+data Maybe a = Nothing | Just a

12+

13+instance Prelude.Monad Maybe where

14+ ret = Just

15+ (>>=) Nothing _ = Nothing

16+ (>>=) (Just a) f = f a

17+

18+test1 = do Just "abc"

19+

20+test3 = do

21+ (x : _) <- Just [1, 2, 3]

22+ (y : _) <- Just [4, 5, 6]

23+ Just (x + y)

24+

25+test4 = do

26+ Just 1

27+ Nothing :: Maybe Number

28+ Just 2

29+

30+test5 mx my = do

31+ x <- mx

32+ y <- my

33+ Just (x + y)

34+

35+test6 mx my mz = do

36+ x <- mx

37+ y <- my

38+ let sum = x + y

39+ z <- mz

40+ Just (z + sum)

41+

42+test7 mx = do let Just x = mx

43+ Just x

44+

45+test8 = do Just (do Just 1)

46+

47+(<$>) :: forall a b. (a -> b) -> Maybe a -> Maybe b

48+(<$>) f m = do

49+ a <- m

50+ ret (f a)

51+

52+(<*>) :: forall a b. (Maybe (a -> b)) -> Maybe a -> Maybe b

53+(<*>) f m = do

54+ g <- f

55+ a <- m

56+ ret (g a)

57+

58+foo x y z = x + y + z

59+

60+forever :: forall m a b. (Monad m) => m a -> m b

61+forever a = do

62+ a

63+ forever a

64+

65+test9 = foo <$> Just 1 <*> Just 2 <*> Just 3

examples/passing/Dollar.pursnew file+12

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

1+module Dollar where

3+($) :: forall a b. (a -> b) -> a -> b

4+($) f x = f x

6+infixr 1000 $

8+id x = x

10+test1 x = id $ id $ id $ id $ x

11+

12+test2 x = id id $ id x

examples/passing/Eff.pursnew file+71

@@ -0,0 +1,71 @@

1+module Prelude where

3+class Monad m where

4+ ret :: forall a. a -> m a

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

7+module Eff where

9+import Prelude

10+

11+-- Eff Monad

12+

13+foreign import data Eff :: # ! -> * -> *

14+

15+foreign import retEff :: forall e a. a -> Eff e a

16+

17+foreign import bindEff :: forall e a b. Eff e a -> (a -> Eff e b) -> Eff e b

18+

19+instance Prelude.Monad (Eff e) where

20+ ret = retEff

21+ (>>=) = bindEff

22+

23+type Pure a = forall e. Eff e a

24+

25+foreign import runPure :: forall a. Pure a -> a

26+

27+-- Errors

28+

29+foreign import data Error :: * -> !

30+

31+foreign import throwError :: forall e r. e -> Eff (err :: Error e | r) {}

32+

33+foreign import catchError :: forall e r a. (e -> Eff r a) -> Eff (err :: Error e | r) a -> Eff r a

34+

35+-- State

36+

37+foreign import data State :: * -> !

38+

39+foreign import get :: forall s r. Eff (state :: State s | r) s

40+

41+foreign import set :: forall s r. s -> Eff (state :: State s | r) {}

42+

43+foreign import runState :: forall s r a. s -> Eff (state :: State s | r) a -> Eff r { value :: a, state :: s }

44+

45+-- ST

46+

47+foreign import data ST :: * -> !

48+

49+foreign import data STRef :: * -> * -> *

50+

51+foreign import newSTRef :: forall a h r. a -> Eff (st :: ST h | r) (STRef h a)

52+

53+foreign import readSTRef :: forall a h r. STRef h a -> Eff (st :: ST h | r) a

54+

55+foreign import modifySTRef :: forall a h r. (a -> a) -> STRef h a -> Eff (st :: ST h | r) {}

56+

57+foreign import runST :: forall a r. (forall h. Eff (st :: ST h | r) a) -> Eff r a

58+

59+-- Tests

60+

61+test1 = runPure (runState 0 (catchError (\s -> ret 0)

62+ (do s <- get

63+ throwError "Error!"

64+ set (s + 1)

65+ ret s)))

66+

67+test2 = runPure (runST (do

68+ ref <- newSTRef 0

69+ modifySTRef (\n -> n + 1) ref

70+ readSTRef ref))

71+

examples/passing/ExternData.pursnew file+15

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

1+module ExternData where

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

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

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

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

10+

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

12+

13+ foreign import prompt :: IO String

14+

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

examples/passing/ExternRaw.pursnew file+13

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

1+module ExternRaw where

3+foreign import first "function first(xs) { return xs[0]; }" :: forall a. [a] -> a

5+foreign import cond "function cond(b, t, f) { return b ? t : f; }" :: forall a. (Boolean, a, a) -> a

7+foreign import loop "function loop() { while (true) {} }" :: forall a. a

9+foreign import concat "function concat(xs) { \

10+ \ return function(ys) { \

11+ \ return xs.concat(ys); \

12+ \ };\

13+ \}" :: forall a. [a] -> [a] -> [a]

examples/passing/FFI.pursnew file+12

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

1+module FFI where

3+foreign import foo :: String -> String

5+bar :: String -> String

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

8+module FFIModuleTest where

10+import FFI

11+

12+baz = foo "test"

examples/passing/Functions.pursnew file+13

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

1+module Functions where

3+ test1 = \ -> 0

5+ test2 = \() -> 0

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

9+ test4 = \(a) -> a

10+

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

12+

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

examples/passing/Guards.pursnew file+10

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

1+module Guards where

3+ collatz = \x -> case x of

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

5+ y -> y * 3 + 1

7+ -- Guards have access to current scope

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

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

10+ z -> z * 3 + 1

examples/passing/IfThenElse.pursnew file+36

@@ -0,0 +1,36 @@

1+module IfThenElse where

3+ testIf =

4+ {

5+ var x = 0;

6+ if (x == 0) {

7+ x = x + 1;

8+ }

9+ return x;

10+ }

11+

12+ testIfElse =

13+ {

14+ var x = 0;

15+ if (x == 0) {

16+ x = x + 1;

17+ } else {

18+ x = x - 1;

19+ }

20+ return x;

21+ }

22+

23+ testIfElseIf = \x ->

24+ {

25+ var y = x;

26+ while (y > 1) {

27+ if (y % 3 == 0) {

28+ y = y / 3;

29+ } else if (y % 3 == 1) {

30+ y = (y - 1) % 3;

31+ } else {

32+ y = y * 4 + 1;

33+ }

34+ }

35+ return y;

36+ }

examples/passing/Import.pursnew file+12

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

1+module M1 where

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

4+ id = \x -> x

6+ foo = id

8+module M2 where

10+ import M1

11+

12+ main = \() -> foo 42

examples/passing/List.pursnew file+21

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

1+module List where

3+ data List a

4+ = Nil

5+ | Cons

6+ { head :: a

7+ , tail :: List a

8+ }

10+ isNull Nil = true

11+ isNull _ = false

12+

13+ concat Nil l2 = l2

14+ concat (Cons x) l2 = Cons

15+ { head: x.head

16+ , tail: concat x.tail l2

17+ }

18+

19+ flatten Nil = Nil

20+ flatten (Cons cons) = concat cons.head (flatten cons.tail)

21+

examples/passing/Match.pursnew file+5

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

1+module Match where

3+ data Foo a = Foo

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

examples/passing/Maybe.pursnew file+11

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

1+module Maybe where

3+ data Maybe a = Nothing | Just a

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

6+ maybe b _ Nothing = b

7+ maybe _ f (Just a) = f a

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

10+

11+ bind m f = maybe Nothing f m

examples/passing/Module.pursnew file+20

@@ -0,0 +1,20 @@

1+module M1 where

3+ data Foo = Foo String

5+ foo :: M1.Foo -> String

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

8+ bar :: Foo -> String

9+ bar = foo

10+

11+ incr :: Number -> Number

12+ incr x = x + 1

13+

14+module M2 where

15+

16+ baz :: M1.Foo -> String

17+ baz = M1.foo

18+

19+ match :: M1.Foo -> String

20+ match = \f -> case f of M1.Foo s -> s ++ "foo"

examples/passing/Monad.pursnew file+28

@@ -0,0 +1,28 @@

1+module Monad where

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

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

6+ data Id a = Id a

8+ id :: Monad Id

9+ id = { ret : Id

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

11+

12+ data Maybe a = Nothing | Just a

13+

14+ maybe :: Monad Maybe

15+ maybe = { ret : Just

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

17+ Nothing -> Nothing

18+ Just a -> f a

19+ }

20+

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

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

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

24+ m.ret n1))

25+

26+ test1 = test id

27+

28+ test2 = test maybe

examples/passing/MutRec.pursnew file+15

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

1+module MutRec where

3+ f 0 = 0

4+ f x = g x + 1

6+ g x = f (x / 2)

8+ data Even = Zero | Even Odd

10+ data Odd = Odd Even

11+

12+ evenToNumber Zero = 0

13+ evenToNumber (Even n) = oddToNumber n + 1

14+

15+ oddToNumber (Odd n) = evenToNumber n + 1

examples/passing/NamedPatterns.pursnew file+5

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

1+module NamedPatterns where

3+ foo = \x -> case x of

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

5+ y -> y

examples/passing/Nested.pursnew file+5

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

1+module Nested where

3+ data Extend r a = Extend { prev :: r a, next :: a }

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

examples/passing/ObjectUpdate.pursnew file+16

@@ -0,0 +1,16 @@

1+module ObjectUpdate where

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

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

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

8+ replace = \o -> case o of

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

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

11+ o -> o

12+

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

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

15+

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

examples/passing/Objects.pursnew file+14

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

1+module Objects where

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

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

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

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

10+

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

12+

13+ typed :: { foo :: Number }

14+ typed = { foo: 0 }

examples/passing/Operators.pursnew file+44

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

1+module Operators1 where

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

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

6+ foo :: String -> String

7+ foo = \s -> s

9+ test8 = foo @@ "Hello World"

10+

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

12+

13+module Operators2 where

14+

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

16+

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

18+

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

20+

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

22+

23+ test4 = 1 `k` 2

24+

25+ infixl 5 %%

26+

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

28+

29+ test5 = 1 %% 2 %% 3

30+

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

32+

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

34+

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

36+

37+ test9 = Operators1.foo Operators1.@@ "Hello World"

38+

39+ test10 = "Hello" `Operators1.bar` "World"

40+

41+ (...) :: forall a. [a] -> [a] -> [a]

42+ (...) = \as -> \bs -> as

43+

44+ test11 = [1, 2, 3] ... [4, 5, 6]

examples/passing/OptimizerBug.pursnew file+5

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

1+module OptimizerBug where

3+x = 1 + y

5+y = x

examples/passing/Patterns.pursnew file+25

@@ -0,0 +1,25 @@

1+module Patterns where

3+ test = \x -> case x of

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

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

6+ _ -> false

8+ f = \o -> case o of

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

10+ _ -> 0

11+

12+ g = \o -> case o of

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

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

15+ _ -> 0

16+

17+

18+ h = \o -> case o of

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

20+ _ -> []

21+

22+ isDesc = \o -> case o of

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

24+ _ -> false

25+

examples/passing/Person.pursnew file+9

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

1+module Person where

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

5+ foreign import itoa :: Number -> String

7+ showPerson :: Person -> String

8+ showPerson = \p -> case p of

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

examples/passing/Rank2Data.pursnew file+25

@@ -0,0 +1,25 @@

1+module Rank2Data where

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

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

6+ Id f -> f a

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

10+ runNat = \nat -> case nat of

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

12+

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

14+

15+ succ = \n -> case n of

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

17+

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

19+ Nat f -> case m of

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

21+

22+ one = succ zero

23+ two = succ zero

24+ four = add two two

25+ fourNumber = runNat four

examples/passing/Rank2Types.pursnew file+19

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

1+module Rank2Types where

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

4+ test1 = \f -> f 0

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

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

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

11+

12+ testST = runST exampleST

13+

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

15+

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

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

18+ 0 -> ret []

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

examples/passing/Recursion.pursnew file+6

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

1+module Recursion where

3+ fib = \n -> case n of

4+ 0 -> 1

5+ 1 -> 1

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

examples/passing/TailCall.pursnew file+10

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

1+module TailCall where

3+test n [] = n

4+test n (x:xs) = test (n + x) xs

6+loop x = loop (x + 1)

8+notATailCall = \x ->

9+ (\notATailCall -> notATailCall x) (\x -> x)

10+

examples/passing/TopLevelCase.pursnew file+14

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

1+module TopLevelCase where

3+ gcd :: (Number, Number) -> Number

4+ gcd (0, x) = x

5+ gcd (x, 0) = x

6+ gcd (x, y) | x > y = gcd (x % y, y)

7+ gcd (x, y) = gcd (y % x, x)

9+ guardsTest (x:xs) | x > 0 = guardsTest xs

10+ guardsTest xs = xs

11+

12+ data A = A

13+

14+ parseTest A 0 = 0

examples/passing/TypeClasses.pursnew file+48

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

1+module TypeClasses where

3+class Show a where

4+ show :: a -> String

6+instance Show String where

7+ show s = s

9+test1 = show "testing"

10+

11+f :: forall a. (TypeClasses.Show a) => a -> String

12+f x = show x

13+

14+test2 = f "testing"

15+

16+data Data a = Data a

17+

18+instance (TypeClasses.Show a) => TypeClasses.Show (Data a) where

19+ show (Data a) = "Data (" ++ show a ++ ")"

20+

21+test3 = show (Data "testing")

22+

23+class Monad m where

24+ ret :: forall a. a -> m a

25+ (>>=) :: forall a b. m a -> (a -> m b) -> m b

26+

27+instance TypeClasses.Monad Data where

28+ ret = Data

29+ (>>=) (Data a) f = f a

30+

31+data Maybe a = Nothing | Just a

32+

33+instance TypeClasses.Monad Maybe where

34+ ret = Just

35+ (>>=) Nothing _ = Nothing

36+ (>>=) (Just a) f = f a

37+

38+test4 :: forall m. (Monad m) => m Number

39+test4 = ret 1

40+

41+test5 = Just 1 >>= \n -> ret (n + 1)

42+

43+module TypeClasses2 where

44+

45+instance (TypeClasses.Show a) => TypeClasses.Show [a] where

46+ show [] = "[]"

47+ show (x:xs) = TypeClasses.show x ++ ", " ++ TypeClasses.show xs

48+

examples/passing/TypeDecl.pursnew file+16

@@ -0,0 +1,16 @@

1+module TypeDecl where

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

4+ id = \x -> x

6+ k :: String -> Number -> String

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

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

10+ iterate = \n -> \f -> \a -> {

11+ var result = a;

12+ for (i <- 0 until n) {

13+ result = f result;

14+ }

15+ return result;

16+ }

examples/passing/TypeSynonyms.pursnew file+33

@@ -0,0 +1,33 @@

1+module TypeSynonyms where

3+ type Lens a b =

4+ { get :: a -> b

5+ , set :: a -> b -> a

6+ }

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

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

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

11+ , set: \a -> \c ->

12+ {

13+ var b = l1.get a;

14+ var b1 = l2.set b c;

15+ return l1.set a b1;

16+ }

17+ }

18+

19+ type Pair a b = { fst :: a, snd :: b }

20+

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

22+ fst =

23+ { get: \p -> p.fst

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

25+ }

26+

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

28+ test1 = composeLenses fst fst

29+

30+ foreign import head :: forall a. Lens [a] a

31+

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

33+ test2 = composeLenses fst (composeLenses head fst)

examples/passing/iota.pursnew file+7

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

1+module Iota where

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

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

7+ iota = \x -> x s k

examples/passing/s.pursnew file+3

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

1+module S where

3+ 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/List.jsnew file+7

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

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

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

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

4+var flat = List.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(Maybe.bind(Maybe.Just("a"))(function(a) {

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

3+ return Maybe.Just(a + b);

4+ });

5+}));

examples/shelltest/runAll.testnew file+16

@@ -0,0 +1,16 @@

1+# Maybe

2+mkdir -p tests && ../../dist/build/psc/psc --no-prelude ../passing/Maybe.purs -o tests/Maybe.js && cat tests/Maybe.js Maybe.js | nodejs

3+<<<

4+>>>

5+{ ctor: 'Maybe.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+

examples/shelltest/runMain.jsnew file+1

@@ -0,0 +1 @@

1+main();

libraries/.gitignorenew file+1

@@ -0,0 +1 @@

1+*/all.js

libraries/jquery/jquery.pursnew file+45

@@ -0,0 +1,45 @@

1+module JQuery where

3+ import Eff

5+ -- An effect type which indicates DOM manipulation

6+ foreign import data DOM :: !

8+ -- The jQuery wrapper type

9+ foreign import data JQuery :: *

10+

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

12+ foreign import select "function select(selector) { return function () { return jQuery(selector); }; }" :: forall eff. String -> Eff (dom :: DOM | eff) JQuery

13+

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

15+ foreign import create "function create(html) { return function () { return jQuery(html); }; }" :: forall eff. String -> Eff (dom :: DOM | eff) JQuery

16+

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

18+ foreign import attr "function attr(attrs) { return function(ob) { return function () { return ob.attr(attrs); }; }; }" :: forall eff attr. { | attr } -> JQuery -> Eff (dom :: DOM | eff) JQuery

19+

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

21+ foreign import css "function css(props) { return function(ob) { return function () { return ob.css(props); }; }; }" :: forall eff css. { | css } -> JQuery -> Eff (dom :: DOM | eff) JQuery

22+

23+ -- .append(...)

24+ foreign import append "function append(ob1) { return function(ob) { return function () { return ob.append(ob1); }; }; }" :: forall eff. JQuery -> JQuery -> Eff (dom :: DOM | eff) JQuery

25+

26+ -- .append(...)

27+ foreign import appendText "function appendText(s) { return function(ob) { return function () { return ob.append(s); }; }; }" :: forall eff. String -> JQuery -> Eff (dom :: DOM | eff) JQuery

28+

29+ -- Get the document body

30+ foreign import body "function body() { return jQuery(document.body); }" :: forall eff. Eff (dom :: DOM | eff) JQuery

31+

32+ -- Get the text content of an element

33+ foreign import getText "function getText(ob) { return function() { return ob.text(); }; }" :: forall eff. JQuery -> Eff (dom :: DOM | eff) String

34+

35+ -- Set the text content of an element

36+ foreign import setText "function setText(text) { return function(ob) { return function() { ob.text(text); }; }; }" :: forall eff. String -> JQuery -> Eff (dom :: DOM | eff) JQuery

37+

38+ -- Get the value of a text field

39+ foreign import getValue "function getValue(ob) { return function() { return ob.val(); }; }" :: forall eff. JQuery -> Eff (dom :: DOM | eff) String

40+

41+ -- Set the value of a text field

42+ foreign import setValue "function setValue(val) { return function(ob) { return function() { return ob.val(val); }; }; }" :: forall eff. String -> JQuery -> Eff (dom :: DOM | eff) JQuery

43+

44+ -- Register an event handler

45+ foreign import on "function on(evt) { return function(act) { return function(ob) { return function() { return ob.on(evt, function() { act(); } ); }; }; }; }" :: forall eff a. String -> Eff eff a -> JQuery -> Eff (dom :: DOM | eff) JQuery

libraries/jquery/tests/.gitignorenew file+1

@@ -0,0 +1 @@

1+jquery.js

libraries/jquery/tests/build.shnew file+2

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

1+psc ../jquery.purs jquery.purs --magic-do --run-main -o jquery.js

libraries/jquery/tests/index.htmlnew file+10

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

1+<!DOCTYPE html>

2+<html>

3+<head>

4+<title>JQuery Example</title>

5+<script src="http://cdnjs.cloudflare.com/ajax/libs/jquery/1.10.2/jquery.js"></script>

6+</head>

7+<body>

8+<script src="jquery.js"></script>

9+</body>

10+</html>

libraries/jquery/tests/jquery.pursnew file+28

@@ -0,0 +1,28 @@

1+module Main where

3+import Prelude

4+import Eff

5+import Trace

6+import JQuery

8+main = do

9+ -- Get the document body

10+ b <- body

11+

12+ -- Create a text box

13+ div <- create "<div>"

14+ input <- create "<input>"

15+ "Your Name: " `appendText` div

16+ input `append` div

17+ div `append` b

18+

19+ -- Create a paragraph to display a greeting

20+ greeting <- create "<p>"

21+ { color: "red" } `css` greeting

22+ greeting `append` b

23+

24+ -- Listen for change events on the text box

25+ flip (on "change") input $ do

26+ name <- getValue input

27+ trace $ "Name changed to " ++ name

28+ setText ("Hello, " ++ name) greeting

libraries/prelude/Makefilenew file+3

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

1+all:

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

3+ cat prelude.js >> all.js

libraries/prelude/prelude.jsnew file+42

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

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+

libraries/prelude/prelude.pursnew file+347

@@ -0,0 +1,347 @@

1+module Prelude where

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

4+ id = \x -> x

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

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

9+ konst :: forall a b. a -> b -> a

10+ konst = \a -> \b -> a

11+

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

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

14+

15+ infixr 5 |>

16+

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

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

19+

20+ infixr 5 <|

21+

22+ ($) :: forall a b. (a -> b) -> a -> b

23+ ($) f x = f x

24+

25+ infixr 1000 $

26+

27+ class Show a where

28+ show :: a -> String

29+

30+ instance Show String where

31+ show s = s

32+

33+ instance Show Boolean where

34+ show true = "true"

35+ show false = "false"

36+

37+ class Monad m where

38+ ret :: forall a. a -> m a

39+ (>>=) :: forall a b. m a -> (a -> m b) -> m b

40+

41+module Maybe where

42+

43+ data Maybe a = Nothing | Just a

44+

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

46+ maybe b _ Nothing = b

47+ maybe _ f (Just a) = f a

48+

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

50+ fromMaybe a = maybe a Prelude.id

51+

52+ bindMaybe :: forall a b. Maybe a -> (a -> Maybe b) -> Maybe b

53+ bindMaybe m f = maybe Nothing f m

54+

55+module Either where

56+

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

58+

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

60+ either f _ (Left a) = f a

61+ either _ g (Right b) = g b

62+

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

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

65+

66+module Arrays where

67+

68+ import Maybe

69+

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

71+ head (x : _) = x

72+

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

74+ headSafe (x : _) = Just x

75+ headSafe _ = Nothing

76+

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

78+ tail (_ : xs) = xs

79+

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

81+ tailSafe (_ : xs) = Just xs

82+ tailSafe _ = Nothing

83+

84+ map :: forall a b. (a -> b) -> [a] -> [b]

85+ map _ [] = []

86+ map f (x:xs) = f x : map f xs

87+

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

89+ foldr f a (b : bs) = f (foldr f a bs) b

90+ foldr _ a [] = a

91+

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

93+ foldl _ b [] = b

94+ foldl f b (a:as) = foldl f (f a b) as

95+

96+ foreign import length "function length(xs) { \

97+ \ return xs.length; \

98+ \}" :: forall a. [a] -> Number

99+

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

101+

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

103+

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

105+

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

107+

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

109+

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

111+

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

113+

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

115+

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

117+

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

119+

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

121+

122+ infixr 6 :

123+

124+ (:) :: forall a. a -> [a] -> [a]

125+ (:) a = concat [a]

126+

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

128+ concatMap [] f = []

129+ concatMap (a:as) f = f a `concat` concatMap as f

130+

131+ filter :: forall a. (a -> Boolean) -> [a] -> [a]

132+ filter _ [] = []

133+ filter p (x:xs) | p x = x : filter p xs

134+ filter p (_:xs) = filter p xs

135+

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

137+ empty [] = true

138+ empty _ = false

139+

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

141+ range lo hi = {

142+ var ns = [];

143+ for (n <- lo until hi) {

144+ ns = push ns n;

145+ }

146+ return ns;

147+ }

148+

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

150+ zipWith f (a:as) (b:bs) = f a b : zipWith f as bs

151+ zipWith _ _ _ = []

152+

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

154+ any _ [] = false

155+ any p (a:as) = p a || any p as

156+

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

158+ all _ [] = true

159+ all p (a:as) = p a && all p as

160+

161+module Tuple where

162+

163+ import Arrays

164+

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

166+

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

168+ curry f a b = f { fst: a, snd: b }

169+

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

171+ uncurry f t = f t.fst t.snd

172+

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

174+ tuple = curry Prelude.id

175+

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

177+ zip = zipWith tuple

178+

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

180+ unzip (t:ts) = case unzip ts of

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

182+ unzip [] = tuple [] []

183+

184+module String where

185+

186+ foreign import lengthS "function lengthS(s) {\

187+ \ return s.length;\

188+ \}" :: String -> Number

189+

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

191+

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

193+

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

195+

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

197+

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

199+

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

201+

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

203+

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

205+

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

207+

208+ foreign import toLower :: String -> String

209+

210+ foreign import toUpper :: String -> String

211+

212+ foreign import trim :: String -> String

213+

214+module Regex where

215+

216+ foreign import data Regex :: *

217+

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

219+

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

221+

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

223+

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

225+

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

227+

228+module Global where

229+

230+ foreign import nan :: Number

231+

232+ foreign import infinity :: Number

233+

234+ foreign import toExponential :: Number -> String

235+

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

237+

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

239+

240+ foreign import numberToString :: Number -> String

241+

242+ foreign import isNaN :: Number -> Boolean

243+

244+ foreign import isFinite :: Number -> Boolean

245+

246+ foreign import parseFloat :: String -> Number

247+

248+ foreign import parseInt :: String -> Number

249+

250+ foreign import encodeURIComponent :: String -> String

251+

252+ foreign import decodeURIComponent :: String -> String

253+

254+ foreign import encodeURI :: String -> String

255+

256+ foreign import decodeURI :: String -> String

257+

258+module Math where

259+

260+ type Math =

261+ { abs :: Number -> Number

262+ , acos :: Number -> Number

263+ , asin :: Number -> Number

264+ , atan :: Number -> Number

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

266+ , aceil :: Number -> Number

267+ , cos :: Number -> Number

268+ , exp :: Number -> Number

269+ , floor :: Number -> Number

270+ , log :: Number -> Number

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

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

273+ , random :: () -> Number

274+ , round :: Number -> Number

275+ , sin :: Number -> Number

276+ , sqrt :: Number -> Number

277+ , tan :: Number -> Number

278+ }

279+

280+ foreign import math :: Math

281+

282+module Eff where

283+

284+ foreign import data Eff :: # ! -> * -> *

285+

286+ foreign import retEff "function retEff(a) { return function() { return a; }; }" :: forall e a. a -> Eff e a

287+

288+ foreign import bindEff "function bindEff(a) { return function(f) { return function() { return f(a())(); }; }; }" :: forall e a b. Eff e a -> (a -> Eff e b) -> Eff e b

289+

290+ type Pure a = forall e. Eff e a

291+

292+ foreign import runPure "function runPure(f) { return f(); }" :: forall a. Pure a -> a

293+

294+ instance Prelude.Monad (Eff e) where

295+ ret = retEff

296+ (>>=) = bindEff

297+

298+module Errors where

299+

300+ import Eff

301+

302+ foreign import data Error :: * -> !

303+

304+ foreign import throwError "function throwError(e) { return function() { throw e; }; }" :: forall a e r. e -> Eff (err :: Error e | r) a

305+

306+ foreign import catchError "function catchError(c) { return function(t) { return function() { try { return t(); } catch(e) { return c(e)(); } }; }; }" :: forall e r a. (e -> Eff r a) -> Eff (err :: Error e | r) a -> Eff r a

307+

308+module IORef where

309+

310+ import Eff

311+

312+ foreign import data Ref :: !

313+

314+ foreign import data IORef :: * -> *

315+

316+ foreign import newIORef :: forall s r. s -> Eff (ref :: Ref | r) (IORef s)

317+

318+ foreign import readIORef :: forall s r. IORef s -> Eff (ref :: Ref | r) s

319+

320+ foreign import writeIORef :: forall s r. IORef s -> s -> Eff (ref :: Ref | r) {}

321+

322+module Trace where

323+

324+ import Eff

325+

326+ foreign import data Trace :: !

327+

328+ foreign import trace "function trace(s) { return function() { console.log(s); return {}; }; }" :: forall r. String -> Eff (trace :: Trace | r) {}

329+

330+ foreign import print "function print(dict) { return function (o) { return function() { console.log(Prelude.show(dict)(o)); return {}; }; }; }" :: forall a r. (Prelude.Show a) => a -> Eff (trace :: Trace | r) {}

331+

332+module ST where

333+

334+ import Eff

335+

336+ foreign import data ST :: * -> !

337+

338+ foreign import data STRef :: * -> * -> *

339+

340+ foreign import newSTRef :: forall a h r. a -> Eff (st :: ST h | r) (STRef h a)

341+

342+ foreign import readSTRef :: forall a h r. STRef h a -> Eff (st :: ST h | r) a

343+

344+ foreign import modifySTRef :: forall a h r. (a -> a) -> STRef h a -> Eff (st :: ST h | r) {}

345+

346+ foreign import runST :: forall a r. (forall h. Eff (st :: ST h | r) a) -> Eff r a

347+

libraries/prelude/tests/Eff.pursnew file+41

@@ -0,0 +1,41 @@

1+module Tests where

3+import Prelude

4+import Eff

5+import Errors

6+import Trace

8+test1 n = runPure $ catchError (\s -> eff do return 0) $ eff do

9+ case {} of

10+ _ | n > 10 -> eff do

11+ throwError "Error!"

12+ _ -> eff do return n

13+

14+test2 = eff do

15+ trace "Hello World"

16+ throwError "Error!"

17+

18+test3 n = catchError (\s -> eff do return 0) $ eff do

19+ case {} of

20+ _ | n > 10 -> eff do

21+ trace "n > 10"

22+ throwError "Error!"

23+ _ -> eff do return n

24+

25+test4 = eff do

26+ trace "Hello World!"

27+ return 0

28+

29+test5 = eff do

30+ trace "Hello World!"

31+ test5

32+

33+test6 s = eff do

34+ trace s

35+ test6 (s ++ " test")

36+

37+module Main where

38+

39+import Tests

40+

41+main = test6 ""

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

psc/Main.hsnew file+116

@@ -0,0 +1,116 @@

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 System.Console.CmdTheLine

19+import Control.Applicative

20+import Control.Monad (forM)

21+import System.Exit (exitSuccess, exitFailure)

22+import qualified System.IO.UTF8 as U

23+import Text.Parsec (ParseError)

24+import qualified Paths_purescript as Paths

25+import Data.Version (showVersion)

26+

27+preludeFilename :: IO FilePath

28+preludeFilename = Paths.getDataFileName "libraries/prelude/prelude.purs"

29+

30+readInput :: Maybe [FilePath] -> IO (Either ParseError [P.Module])

31+readInput Nothing = getContents >>= return . P.runIndentParser P.parseModules

32+readInput (Just input) = fmap (fmap concat . sequence) $ forM input $ \inputFile -> do

33+ text <- U.readFile inputFile

34+ return $ P.runIndentParser P.parseModules text

35+

36+compile :: P.Options -> Maybe [FilePath] -> Maybe FilePath -> Maybe FilePath -> IO ()

37+compile opts input output externs = do

38+ modules <- readInput input

39+ case modules of

40+ Left err -> do

41+ U.print err

42+ exitFailure

43+ Right ms ->

44+ case P.compile opts ms of

45+ Left err -> do

46+ U.putStrLn err

47+ exitFailure

48+ Right (js, exts, _) -> do

49+ case output of

50+ Just path -> U.writeFile path js

51+ Nothing -> U.putStrLn js

52+ case externs of

53+ Nothing -> return ()

54+ Just filePath -> U.writeFile filePath exts

55+ exitSuccess

56+

57+useStdIn :: Term Bool

58+useStdIn = value . flag $ (optInfo [ "s", "stdin" ])

59+ { optDoc = "Read from standard input" }

60+

61+inputFiles :: Term [FilePath]

62+inputFiles = value $ posAny [] $ posInfo

63+ { posDoc = "The input .ps files" }

64+

65+outputFile :: Term (Maybe FilePath)

66+outputFile = value $ opt Nothing $ (optInfo [ "o", "output" ])

67+ { optDoc = "The output .js file" }

68+

69+externsFile :: Term (Maybe FilePath)

70+externsFile = value $ opt Nothing $ (optInfo [ "e", "externs" ])

71+ { optDoc = "The output .e.ps file" }

72+

73+tco :: Term Bool

74+tco = value $ flag $ (optInfo [ "tco" ])

75+ { optDoc = "Perform tail call optimizations" }

76+

77+performRuntimeTypeChecks :: Term Bool

78+performRuntimeTypeChecks = value $ flag $ (optInfo [ "runtime-type-checks" ])

79+ { optDoc = "Generate runtime type checks" }

80+

81+noPrelude :: Term Bool

82+noPrelude = value $ flag $ (optInfo [ "no-prelude" ])

83+ { optDoc = "Omit the Prelude" }

84+

85+magicDo :: Term Bool

86+magicDo = value $ flag $ (optInfo [ "magic-do" ])

87+ { optDoc = "Overload the do keyword to generate efficient code specifically for the Eff monad." }

88+

89+runMain :: Term Bool

90+runMain = value $ flag $ (optInfo [ "run-main" ])

91+ { optDoc = "Generate code to run the main method in the Main module." }

92+

93+options :: Term P.Options

94+options = P.Options <$> tco <*> performRuntimeTypeChecks <*> magicDo <*> runMain

95+

96+stdInOrInputFiles :: FilePath -> Term (Maybe [FilePath])

97+stdInOrInputFiles prelude = combine <$> useStdIn <*> (not <$> noPrelude) <*> inputFiles

98+ where

99+ combine False True input = Just (prelude : input)

100+ combine False False input = Just input

101+ combine True _ _ = Nothing

102+

103+term :: FilePath -> Term (IO ())

104+term prelude = compile <$> options <*> stdInOrInputFiles prelude <*> outputFile <*> externsFile

105+

106+termInfo :: TermInfo

107+termInfo = defTI

108+ { termName = "psc"

109+ , version = showVersion $ Paths.version

110+ , termDoc = "Compiles PureScript to Javascript"

111+ }

112+

113+main :: IO ()

114+main = do

115+ prelude <- preludeFilename

116+ run (term prelude, termInfo)

psci/Main.hsnew file+146

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

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

16+

17+module Main where

18+

19+import Control.Monad.IO.Class

20+import Control.Applicative

21+import Control.Monad.Trans.Class

22+

23+import Data.List (nub, isPrefixOf)

24+import Data.Maybe (mapMaybe)

25+

26+import System.Process

27+import System.Console.Haskeline

28+

29+import qualified Language.PureScript as P

30+import qualified Paths_purescript as Paths

31+import qualified System.IO.UTF8 as U (readFile)

32+import qualified Text.Parsec as Parsec (eof)

33+

34+getPreludeFilename :: IO FilePath

35+getPreludeFilename = Paths.getDataFileName "libraries/prelude/prelude.purs"

36+

37+options :: P.Options

38+options = P.Options True False True True

39+

40+completion :: [P.Module] -> CompletionFunc IO

41+completion ms = completeWord Nothing " \t\n\r" findCompletions

42+ where

43+ findCompletions :: String -> IO [Completion]

44+ findCompletions str = do

45+ files <- listFiles str

46+ let names = nub $ [ show qual

47+ | P.Module moduleName ds <- ms

48+ , ident <- mapMaybe getDeclName ds

49+ , qual <- [ P.Qualified Nothing ident

50+ , P.Qualified (Just (P.ModuleName moduleName)) ident]

51+ ]

52+ let matches = filter (isPrefixOf str) names

53+ return $ map simpleCompletion matches ++ files

54+ getDeclName :: P.Declaration -> Maybe P.Ident

55+ getDeclName (P.ValueDeclaration ident _ _ _) = Just ident

56+ getDeclName _ = Nothing

57+

58+createTemporaryModule :: [P.ProperName] -> P.Value -> P.Module

59+createTemporaryModule imports value =

60+ let

61+ moduleName = P.ProperName "Main"

62+ importDecl m = P.ImportDeclaration m Nothing

63+ traceModule = P.ModuleName (P.ProperName "Trace")

64+ trace = P.Var (P.Qualified (Just traceModule) (P.Ident "print"))

65+ mainDecl = P.ValueDeclaration (P.Ident "main") [] Nothing

66+ (P.Do [ P.DoNotationBind (P.VarBinder (P.Ident "it")) value

67+ , P.DoNotationValue (P.App trace [ P.Var (P.Qualified Nothing (P.Ident "it")) ] )

68+ ])

69+ in

70+ P.Module moduleName $ map (importDecl . P.ModuleName) imports ++ [mainDecl]

71+

72+handleDeclaration :: [P.Module] -> [P.ProperName] -> P.Value -> InputT IO ()

73+handleDeclaration loadedModules imports value = do

74+ let m = createTemporaryModule imports value

75+ case P.compile options (loadedModules ++ [m]) of

76+ Left err -> outputStrLn err

77+ Right (js, _, _) -> do

78+ output <- liftIO $ readProcess "nodejs" [] js

79+ outputStrLn output

80+

81+data Command

82+ = Empty

83+ | Expression [String]

84+ | Import String

85+ | LoadModule FilePath

86+ | Reload deriving (Show, Eq)

87+

88+getCommand :: InputT IO Command

89+getCommand = do

90+ firstLine <- getInputLine "> "

91+ case firstLine of

92+ Nothing -> return Empty

93+ Just (':':'i':' ':moduleName) -> return $ Import moduleName

94+ Just (':':'m':' ':modulePath) -> return $ LoadModule modulePath

95+ Just ":r" -> return Reload

96+ Just (':':_) -> outputStrLn "Unknown command" >> getCommand

97+ Just other -> Expression <$> go [other]

98+ where

99+ go ls = do

100+ l <- getInputLine " "

101+ case l of

102+ Nothing -> return $ reverse ls

103+ Just l' -> go (l' : ls)

104+

105+loadModule :: FilePath -> IO (Either String [P.Module])

106+loadModule moduleFile = do

107+ print moduleFile

108+ moduleText <- U.readFile moduleFile

109+ return . either (Left . show) Right $ P.runIndentParser P.parseModules moduleText

110+

111+main :: IO ()

112+main = do

113+ preludeFilename <- getPreludeFilename

114+ (Right prelude) <- loadModule preludeFilename

115+ runInputT (setComplete (completion prelude) defaultSettings) $ do

116+ outputStrLn " ____ ____ _ _ "

117+ outputStrLn "| _ \\ _ _ _ __ ___/ ___| ___ _ __(_)_ __ | |_ "

118+ outputStrLn "| |_) | | | | '__/ _ \\___ \\ / __| '__| | '_ \\| __|"

119+ outputStrLn "| __/| |_| | | | __/___) | (__| | | | |_) | |_ "

120+ outputStrLn "|_| \\__,_|_| \\___|____/ \\___|_| |_| .__/ \\__|"

121+ outputStrLn " |_| "

122+ outputStrLn ""

123+ outputStrLn "Expressions are terminated using Ctrl+D"

124+ go [P.ProperName "Prelude"] prelude

125+ where

126+ go imports loadedModules = do

127+ cmd <- getCommand

128+ case cmd of

129+ Empty -> go imports loadedModules

130+ Expression ls -> do

131+ case P.runIndentParser (P.whiteSpace *> P.parseValue <* Parsec.eof) (unlines ls) of

132+ Left err -> outputStrLn (show err)

133+ Right decl -> handleDeclaration loadedModules imports decl

134+ go imports loadedModules

135+ Import moduleName -> go (imports ++ [P.ProperName moduleName]) loadedModules

136+ LoadModule moduleFile -> do

137+ ms <- lift $ loadModule moduleFile

138+ case ms of

139+ Left err -> outputStrLn err

140+ Right ms' -> go imports (loadedModules ++ ms')

141+ Reload -> do

142+ preludeFilename <- lift getPreludeFilename

143+ (Right prelude) <- lift $ loadModule preludeFilename

144+ go [P.ProperName "Prelude"] prelude

145+

146+

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

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

1+name: purescript

2+version: 0.2.15.1

3+cabal-version: >=1.8

4+build-type: Simple

5+license: MIT

6+license-file: LICENSE

7+copyright: (c) Phil Freeman 2013

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

9+stability: experimental

10+synopsis: PureScript Programming Language Compiler

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

12+category: Language

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

14+data-dir: ""

15+data-files: libraries/prelude/prelude.purs

16+

17+library

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

19+ directory -any, filepath -any, mtl -any, parsec -any, syb -any,

20+ transformers -any, utf8-string -any

21+ exposed-modules: Data.Generics.Extras

22+ Language.PureScript

23+ Language.PureScript.Options

24+ Language.PureScript.Declarations

25+ Language.PureScript.Kinds

26+ Language.PureScript.Names

27+ Language.PureScript.Types

28+ Language.PureScript.Unknown

29+ Language.PureScript.Values

30+ Language.PureScript.Scope

31+ Language.PureScript.Sugar

32+ Language.PureScript.Sugar.CaseDeclarations

33+ Language.PureScript.Sugar.DoNotation

34+ Language.PureScript.Sugar.TypeDeclarations

35+ Language.PureScript.Sugar.BindingGroups

36+ Language.PureScript.Sugar.Operators

37+ Language.PureScript.Sugar.TypeClasses

38+ Language.PureScript.CodeGen

39+ Language.PureScript.CodeGen.Externs

40+ Language.PureScript.CodeGen.JS

41+ Language.PureScript.CodeGen.JS.AST

42+ Language.PureScript.CodeGen.Monad

43+ Language.PureScript.CodeGen.Optimize

44+ Language.PureScript.Parser

45+ Language.PureScript.Parser.Common

46+ Language.PureScript.Parser.Declarations

47+ Language.PureScript.Parser.Kinds

48+ Language.PureScript.Parser.State

49+ Language.PureScript.Parser.Types

50+ Language.PureScript.Parser.Values

51+ Language.PureScript.Parser.JS

52+ Language.PureScript.Pretty

53+ Language.PureScript.Pretty.Common

54+ Language.PureScript.Pretty.JS

55+ Language.PureScript.Pretty.Kinds

56+ Language.PureScript.Pretty.Types

57+ Language.PureScript.Pretty.Values

58+ Language.PureScript.TypeChecker

59+ Language.PureScript.TypeChecker.Kinds

60+ Language.PureScript.TypeChecker.Monad

61+ Language.PureScript.TypeChecker.Synonyms

62+ Language.PureScript.TypeChecker.Types

63+ exposed: True

64+ buildable: True

65+ hs-source-dirs: src

66+

67+executable psc

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

69+ directory -any, filepath -any, mtl -any, parsec -any,

70+ purescript -any, syb -any, transformers -any, utf8-string -any

71+ main-is: Main.hs

72+ hs-source-dirs: psc

73+ buildable: True

74+ other-modules:

75+ ghc-options: -Wall -O2 -fno-warn-unused-do-bind

76+

77+executable psci

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

79+ mtl -any, parsec -any, haskeline <= 0.7.1.1,

80+ purescript -any, syb -any, transformers -any, utf8-string -any,

81+ process -any

82+ main-is: Main.hs

83+ hs-source-dirs: psci

84+ buildable: True

85+ other-modules:

86+ ghc-options: -Wall -O2

87+

88+test-suite tests

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

90+ directory -any, filepath -any, mtl -any, parsec -any,

91+ purescript -any, syb -any, transformers -any, utf8-string -any

92+ type: exitcode-stdio-1.0

93+ main-is: Main.hs

94+ buildable: True

95+ hs-source-dirs: tests

release.mdnew file+86

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

1+## 0.2.0 Changes

3+Many thanks to the [contributors](https://github.com/paf31/purescript/graphs/contributors) who helped with this release.

5+- Full language guide can be found [here](http://functorial.com/purescript).

6+- Try out the latest features [here](http://tryps.functorial.com).

8+### New Features

10+- RankNTypes

11+

12+ This experimental feature allows polymorphic types (introduced with `forall`) to appear on the left of a function arrow, or as the type of a record field, etc. For example:

13+

14+ rank2 :: (forall a. a -> a) -> Number

15+ rank2 = \f -> if f true then f 1 else f 2

16+

17+- Modules

18+- Polymorphic Object Update

19+

20+ Records now support member update in which the type of the field changes during the update. For example:

21+

22+ data Wrap a = Wrap a

23+

24+ update = \o -> o { prop = Wrap o.prop }

25+

26+### Enhancements

27+

28+- Naked expressions as statements

29+

30+ Naked expressions of type `{}` can now be used as statements.

31+

32+- Split code generation into `AST -> JS` and `JS -> String`

33+

34+ JavaScript generation is now split into the generation of a JavaScript AST, and the pretty-printing of that AST. This enables some optimizations, and a better JavaScript pretty-printer.

35+

36+- Syntactic sugar for introducing curried functions

37+

38+ Single-argument functions and multiple-argument functions can now be introduced in the same way:

39+

40+ test = \a (b, c) d -> a + b + c + d

41+

42+- JavaScript optimizations

43+

44+ Some basic dead-variable elimination, inlining and eta-conversion are now performed on the generated JavaScript.

45+

46+- Generate formatted Javascript

47+

48+ The generated JavaScript is now formatted to be more readable. In particular, newlines get generated, and the correct indentation is used.

49+

50+- More valid infix operators

51+

52+ The colon and period characters are now valid in infix operator names.

53+

54+### Syntax Changes

55+

56+- Avoid 'do' keyword for blocks

57+

58+ `do` will be used later for Haskell-like monad comprehensions, so its previous use in introducing blocks of statements is now invalid. The `do` keyword is still reserved.

59+

60+- Member foreign import syntax

61+

62+ A small syntactic addition to the FFI, to support a common use case.

63+

64+- Make FFI syntax match Haskell

65+

66+ Use `foreign import` instead of `extern`.

67+

68+- Make record declaration syntax match Haskell

69+- Simplify array binders

70+

71+ There are now two types of array binders: cons binders `x : xs -> ...` and array binders `[x, y, z] -> ...` instead of the previously confusing `[x:xs]`.

72+

73+- Array indexing syntax is ambiguous

74+

75+ Array elements are now accessed using the `!!` operator: `arr !! 0` etc.

76+

77+### Bug Fixes

78+

79+- Allow guards access to current scope

80+

81+### Libraries

82+

83+- Prelude

84+

85+ There is now a basic prelude in the `libraries/prelude` folder.

86+

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 d1. (Data d1) => d1 -> m d1) -> d -> m d

22+everywhereM' f x = do

23+ y <- f x

24+ gmapM (everywhereM' f) y

src/Language/PureScript.hsnew file+47

@@ -0,0 +1,47 @@

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.Sugar as P

27+import Language.PureScript.Options as P

28+

29+import Data.List (intercalate)

30+import Control.Monad (when, forM)

31+import Control.Applicative ((<$>))

32+import qualified Data.Map as M

33+

34+compile :: Options -> [Module] -> Either String (String, String, Environment)

35+compile opts ms = do

36+ desugared <- desugar ms

37+ (elaborated, env) <- runCheck $ forM desugared $ \(Module moduleName decls) -> Module moduleName <$> typeCheckAll (ModuleName moduleName) decls

38+ let regrouped = createBindingGroupsModule . collapseBindingGroupsModule $ elaborated

39+ let js = concatMap (flip (moduleToJs opts) env) $ regrouped

40+ let exts = intercalate "\n" . map (flip moduleToPs env) $ regrouped

41+ js' <- case () of

42+ _ | optionsRunMain opts -> do

43+ when ((ModuleName (ProperName "Main"), Ident "main") `M.notMember` (names env)) $

44+ Left "Main.main is undefined"

45+ return $ js ++ [JSApp (JSAccessor "main" (JSVar (Ident "Main"))) []]

46+ | otherwise -> return js

47+ return (prettyPrintJS js', exts, env)

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

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

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

19+import Language.PureScript.CodeGen.Optimize as C

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

@@ -0,0 +1,47 @@

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

17+) where

18+

19+import Data.Maybe (maybeToList, mapMaybe)

20+import qualified Data.Map as M

21+import Language.PureScript.Declarations

22+import Language.PureScript.TypeChecker.Monad

23+import Language.PureScript.Pretty

24+import Language.PureScript.Names

25+import Data.List (intercalate)

26+

27+moduleToPs :: Module -> Environment -> String

28+moduleToPs (Module pname@(ProperName moduleName) decls) env =

29+ "module " ++ moduleName ++ " where\n" ++

30+ (intercalate "\n" . map (" " ++) . concatMap (declToPs (ModuleName pname) env) $ decls)

31+

32+declToPs :: ModuleName -> Environment -> Declaration -> [String]

33+declToPs path env (ValueDeclaration name _ _ _) = maybeToList $ do

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

35+ return $ "foreign import " ++ show name ++ " :: " ++ prettyPrintType ty

36+declToPs path env (BindingGroupDeclaration vals) = do

37+ flip mapMaybe vals $ \(name, _) -> do

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

39+ return $ "foreign import " ++ show name ++ " :: " ++ prettyPrintType ty

40+declToPs path env (DataDeclaration name _ _) = maybeToList $ do

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

42+ return $ "foreign import data " ++ show name ++ " :: " ++ prettyPrintKind kind

43+declToPs _ _ (ExternDataDeclaration name kind) =

44+ return $ "foreign import data " ++ show name ++ " :: " ++ prettyPrintKind kind

45+declToPs _ _ (TypeSynonymDeclaration name args ty) =

46+ return $ "type " ++ show name ++ " " ++ unwords args ++ " = " ++ prettyPrintType ty

47+declToPs _ _ _ = []

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

@@ -0,0 +1,237 @@

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

19+) where

20+

21+import Data.Maybe (mapMaybe)

22+import Data.List (sortBy)

23+

24+import Control.Arrow (second)

25+import Control.Monad (replicateM, forM)

26+

27+import qualified Data.Map as M

28+

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

30+import Language.PureScript.Values

31+import Language.PureScript.Names

32+import Language.PureScript.Scope

33+import Language.PureScript.Declarations

34+import Language.PureScript.Pretty.Common

35+import Language.PureScript.CodeGen.Monad

36+import Language.PureScript.Options

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

38+import Language.PureScript.Types

39+import Language.PureScript.CodeGen.Optimize

40+

41+moduleToJs :: Options -> Module -> Environment -> [JS]

42+moduleToJs opts (Module pname@(ProperName name) decls) env =

43+ mapMaybe filterRawDecls decls ++

44+ [ JSVariableIntroduction (Ident name) Nothing

45+ , JSApp (JSFunction Nothing [Ident name]

46+ (JSBlock (concat $ mapMaybe (\decl -> fmap (map $ optimize opts) $ declToJs opts (ModuleName pname) decl env) (sortBy typeClassesLast decls))))

47+ [JSAssignment (JSAssignVariable (Ident name))

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

49+ ]

50+ where

51+ filterRawDecls (ExternDeclaration ForeignImport _ (Just js) _) = Just js

52+ filterRawDecls _ = Nothing

53+ typeClassesLast (ExternDeclaration TypeClassDictionaryImport _ _ _) (ExternDeclaration TypeClassDictionaryImport _ _ _) = EQ

54+ typeClassesLast (ExternDeclaration TypeClassDictionaryImport _ _ _) _ = GT

55+ typeClassesLast _ (ExternDeclaration TypeClassDictionaryImport _ _ _) = LT

56+ typeClassesLast _ _ = EQ

57+

58+declToJs :: Options -> ModuleName -> Declaration -> Environment -> Maybe [JS]

59+declToJs opts mp (ValueDeclaration ident _ _ val) e =

60+ Just [ JSVariableIntroduction ident (Just (valueToJs opts mp e val)),

61+ setProperty (identToJs ident) (JSVar ident) mp ]

62+declToJs opts mp (BindingGroupDeclaration vals) e =

63+ Just $ concatMap (\(ident, val) ->

64+ [ JSVariableIntroduction ident (Just (valueToJs opts mp e val)),

65+ setProperty (identToJs ident) (JSVar ident) mp ]

66+ ) vals

67+declToJs _ mp (DataDeclaration _ _ ctors) _ =

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

69+ let

70+ ctorJs =

71+ case maybeTy of

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

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

74+ (JSBlock [JSReturn

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

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

77+ in [ ctorJs, setProperty ctor (JSVar (Ident ctor)) mp ]

78+declToJs _ mp (ExternDeclaration importTy ident (Just js) _) _ | importTy /= ForeignImport =

79+ Just [ js

80+ , setProperty (identToJs ident) (JSVar ident) mp ]

81+declToJs _ _ _ _ = Nothing

82+

83+setProperty :: String -> JS -> ModuleName -> JS

84+setProperty prop val (ModuleName (ProperName moduleName)) = JSAssignment (JSAssignProperty prop (JSAssignVariable (Ident moduleName))) val

85+

86+valueToJs :: Options -> ModuleName -> Environment -> Value -> JS

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

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

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

90+valueToJs opts m e (ArrayLiteral xs) = JSArrayLiteral (map (valueToJs opts m e) xs)

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

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

93+valueToJs _ m e (Constructor (Qualified Nothing name)) =

94+ case M.lookup (m, name) (dataConstructors e) of

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

96+ _ -> JSVar . Ident . runProperName $ name

97+valueToJs _ _ _ (Constructor name) = qualifiedToJS runProperName name

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

99+valueToJs opts m e (Case values binders) = bindersToJs opts m e binders (map (valueToJs opts m e) values)

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

101+valueToJs opts m e (Accessor prop val) = JSAccessor prop (valueToJs opts m e val)

102+valueToJs opts m e (Indexer index val) = JSIndexer (valueToJs opts m e index) (valueToJs opts m e val)

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

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

105+valueToJs opts m e (TypedValue _ (Abs args val) ty) | optionsPerformRuntimeTypeChecks opts = JSFunction Nothing args (JSBlock $ runtimeTypeChecks args ty ++ [JSReturn (valueToJs opts m e val)])

106+valueToJs opts m e (Unary op val) = JSUnary op (valueToJs opts m e val)

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

108+valueToJs _ m e (Var ident) = varToJs m e ident

109+valueToJs opts m e (TypedValue _ val _) = valueToJs opts m e val

110+valueToJs _ _ _ (TypeClassDictionary _ _) = error "Type class dictionary was not replaced"

111+valueToJs _ _ _ _ = error "Invalid argument to valueToJs"

112+

113+runtimeTypeChecks :: [Ident] -> Type -> [JS]

114+runtimeTypeChecks args ty =

115+ let

116+ argTys = getFunctionArgumentTypes ty

117+ in

118+ concat $ zipWith argumentCheck (map JSVar args) argTys

119+ where

120+ getFunctionArgumentTypes :: Type -> [Type]

121+ getFunctionArgumentTypes (Function funArgs _) = funArgs

122+ getFunctionArgumentTypes (ForAll _ ty') = getFunctionArgumentTypes ty'

123+ getFunctionArgumentTypes _ = []

124+ argumentCheck :: JS -> Type -> [JS]

125+ argumentCheck val Number = [typeCheck val "number"]

126+ argumentCheck val String = [typeCheck val "string"]

127+ argumentCheck val Boolean = [typeCheck val "boolean"]

128+ argumentCheck val (Array _) = [arrayCheck val]

129+ argumentCheck val (Object row) =

130+ let

131+ (pairs, _) = rowToList row

132+ in

133+ typeCheck val "object" : concatMap (\(prop, ty') -> argumentCheck (JSAccessor prop val) ty') pairs

134+ argumentCheck val (Function _ _) = [typeCheck val "function"]

135+ argumentCheck val (ForAll _ ty') = argumentCheck val ty'

136+ argumentCheck _ _ = []

137+ typeCheck :: JS -> String -> JS

138+ typeCheck js ty' = JSIfElse (JSBinary NotEqualTo (JSTypeOf js) (JSStringLiteral ty')) (JSBlock [JSThrow (JSStringLiteral $ ty' ++ " expected")]) Nothing

139+ arrayCheck :: JS -> JS

140+ arrayCheck js = JSIfElse (JSUnary Not (JSApp (JSAccessor "isArray" (JSVar (Ident "Array"))) [js])) (JSBlock [JSThrow (JSStringLiteral "Array expected")]) Nothing

141+

142+varToJs :: ModuleName -> Environment -> Qualified Ident -> JS

143+varToJs m e qual@(Qualified _ ident) = case M.lookup (qualify m qual) (names e) of

144+ Just (_, ty) | isExtern ty -> JSVar ident

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

146+ _ -> qualifiedToJS identToJs qual

147+ where

148+ isExtern (Extern ForeignImport) = True

149+ isExtern (Alias m' ident') = case M.lookup (m', ident') (names e) of

150+ Just (_, ty') -> isExtern ty'

151+ Nothing -> error "Undefined alias in varToJs"

152+ isExtern _ = False

153+

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

155+qualifiedToJS f (Qualified (Just (ModuleName (ProperName m))) a) = JSAccessor (f a) (JSVar (Ident m))

156+qualifiedToJS f (Qualified Nothing a) = JSVar (Ident (f a))

157+

158+bindersToJs :: Options -> ModuleName -> Environment -> [([Binder], Maybe Guard, Value)] -> [JS] -> JS

159+bindersToJs opts m e binders vals = runGen (unusedNames (binders, vals)) $ do

160+ valNames <- replicateM (length vals) fresh

161+ jss <- forM binders $ \(bs, grd, result) -> go valNames [JSReturn (valueToJs opts m e result)] bs grd

162+ return $ JSApp (JSFunction Nothing valNames (JSBlock (concat jss ++ [JSThrow (JSStringLiteral "Failed pattern match")])))

163+ vals

164+ where

165+ go :: [Ident] -> [JS] -> [Binder] -> Maybe Guard -> Gen [JS]

166+ go _ done [] Nothing = return done

167+ go _ done [] (Just cond) = return [JSIfElse (valueToJs opts m e cond) (JSBlock done) Nothing]

168+ go (v:vs) done' (b:bs) grd = do

169+ done'' <- go vs done' bs grd

170+ binderToJs m e v done'' b

171+ go _ _ _ _ = error "Invalid arguments to bindersToJs"

172+

173+binderToJs :: ModuleName -> Environment -> Ident -> [JS] -> Binder -> Gen [JS]

174+binderToJs _ _ _ done NullBinder = return done

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

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

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

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

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

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

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

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

183+binderToJs _ _ varName done (VarBinder ident) =

184+ return (JSVariableIntroduction ident (Just (JSVar varName)) : done)

185+binderToJs m _ varName done (NullaryBinder ctor) =

186+ return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar varName)) (JSStringLiteral (show ((\(mp, nm) -> Qualified (Just mp) nm) $ qualify m ctor)))) (JSBlock done) Nothing]

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

188+ value <- fresh

189+ js <- binderToJs m e value done b

190+ return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar varName)) (JSStringLiteral (show ((\(mp, nm) -> Qualified (Just mp) nm) $ qualify m ctor)))) (JSBlock (JSVariableIntroduction value (Just (JSAccessor "value" (JSVar varName))) : js)) Nothing]

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

192+ where

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

194+ go done' [] = return done'

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

196+ propVar <- fresh

197+ done'' <- go done' bs'

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

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

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

201+ js <- go done 0 bs

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

203+ where

204+ go :: [JS] -> Integer -> [Binder] -> Gen [JS]

205+ go done' _ [] = return done'

206+ go done' index (binder:bs') = do

207+ elVar <- fresh

208+ done'' <- go done' (index + 1) bs'

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

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

211+binderToJs m e varName done (ConsBinder headBinder tailBinder) = do

212+ headVar <- fresh

213+ tailVar <- fresh

214+ js1 <- binderToJs m e headVar done headBinder

215+ js2 <- binderToJs m e tailVar js1 tailBinder

216+ return [JSIfElse (JSBinary GreaterThan (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (Left 0))) (JSBlock

217+ ( JSVariableIntroduction headVar (Just (JSIndexer (JSNumericLiteral (Left 0)) (JSVar varName))) :

218+ JSVariableIntroduction tailVar (Just (JSApp (JSAccessor "slice" (JSVar varName)) [JSNumericLiteral (Left 1)])) :

219+ js2

220+ )) Nothing]

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

222+ js <- binderToJs m e varName done binder

223+ return (JSVariableIntroduction ident (Just (JSVar varName)) : js)

224+

225+statementToJs :: Options -> ModuleName -> Environment -> Statement -> JS

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

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

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

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

230+statementToJs opts m e (If ifst) = ifToJs ifst

231+ where

232+ ifToJs :: IfStatement -> JS

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

234+ elseToJs :: ElseStatement -> JS

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

236+ elseToJs (ElseIf elif) = ifToJs elif

237+statementToJs opts m e (Return value) = JSReturn (valueToJs opts m e value)

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

@@ -0,0 +1,56 @@

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

46+ | JSTypeOf JS

47+ | JSLabel String JS

48+ | JSBreak String

49+ | JSContinue String

50+ | JSRaw String deriving (Show, Data, Typeable)

51+

52+data JSAssignment

53+ = JSAssignVariable Ident

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

55+

56+

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

@@ -0,0 +1,32 @@

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+import Language.PureScript.Names

22+

23+newtype Gen a = Gen { unGen :: State [Ident] a } deriving (Functor, Applicative, Monad, MonadState [Ident])

24+

25+runGen :: [Ident] -> Gen a -> a

26+runGen names = flip evalState names . unGen

27+

28+fresh :: Gen Ident

29+fresh = do

30+ (s:ss) <- get

31+ put ss

32+ return s

src/Language/PureScript/CodeGen/Optimize.hsnew file+232

@@ -0,0 +1,232 @@

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.CodeGen.Optimize (

16+ optimize

17+) where

18+

19+import Data.Data

20+import Data.Maybe (fromMaybe)

21+import Data.Generics

22+

23+import Language.PureScript.Names

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

25+import Language.PureScript.Options

26+

27+optimize :: Options -> JS -> JS

28+optimize opts =

29+ collapseNestedBlocks

30+ . tco opts

31+ . magicDo opts

32+ . removeUnusedVariables

33+ . unThunk

34+ . etaConvert

35+ . inlineVariables

36+

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

38+replaceIdent var1 js = everywhere (mkT replace)

39+ where

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

41+ replace other = other

42+

43+replaceIdents :: (Data d) => [(Ident, JS)] -> d -> d

44+replaceIdents vars = everywhere (mkT replace)

45+ where

46+ replace v@(JSVar var) = fromMaybe v $ lookup var vars

47+ replace other = other

48+

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

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

51+ where

52+ check :: JS -> Bool

53+ check (JSFunction _ args _) | var1 `elem` args = True

54+ check _ = False

55+

56+isRebound :: (Data d) => JS -> d -> Bool

57+isRebound (JSVar var1) = everything (||) (mkQ False check)

58+ where

59+ check :: JS -> Bool

60+ check (JSFunction _ args _) | var1 `elem` args = True

61+ check _ = False

62+isRebound _ = const False

63+

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

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

66+ where

67+ check :: JS -> Bool

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

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

70+ check _ = False

71+ targetVariable :: JSAssignment -> Ident

72+ targetVariable (JSAssignVariable var) = var

73+ targetVariable (JSAssignProperty _ tgt) = targetVariable tgt

74+

75+shouldInline :: JS -> Bool

76+shouldInline (JSVar _) = True

77+shouldInline (JSNumericLiteral _) = True

78+shouldInline (JSStringLiteral _) = True

79+shouldInline (JSBooleanLiteral _) = True

80+shouldInline (JSAccessor _ val) = shouldInline val

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

82+shouldInline _ = False

83+

84+inlineVariables :: JS -> JS

85+inlineVariables = everywhere (mkT removeFromBlock)

86+ where

87+ removeFromBlock :: JS -> JS

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

89+ removeFromBlock js = js

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

91+ go [] = []

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

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

94+

95+removeUnusedVariables :: JS -> JS

96+removeUnusedVariables = everywhere (mkT removeFromBlock)

97+ where

98+ removeFromBlock :: JS -> JS

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

100+ removeFromBlock js = js

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

102+ go [] = []

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

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

105+

106+etaConvert :: JS -> JS

107+etaConvert = everywhere (mkT convert)

108+ where

109+ convert :: JS -> JS

110+ convert (JSBlock [JSReturn (JSApp (JSFunction Nothing idents block@(JSBlock body)) args)])

111+ | all shouldInline args && not (or (map (flip isRebound block) args)) = JSBlock (replaceIdents (zip idents args) body)

112+ convert js = js

113+

114+unThunk :: JS -> JS

115+unThunk = everywhere (mkT convert)

116+ where

117+ convert :: JS -> JS

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

119+ convert js = js

120+

121+tco :: Options -> JS -> JS

122+tco opts | optionsTco opts = tco'

123+ | otherwise = id

124+

125+tco' :: JS -> JS

126+tco' = everywhere (mkT convert)

127+ where

128+ tcoLabel :: String

129+ tcoLabel = "tco"

130+ tcoVar :: Ident -> Ident

131+ tcoVar (Ident arg) = Ident $ "__tco_" ++ arg

132+ tcoVar _ = error "Invalid name in tcoVar"

133+ copyVar :: Ident -> Ident

134+ copyVar (Ident arg) = Ident $ "__copy_" ++ arg

135+ copyVar _ = error "Invalid name in copyVar"

136+ convert :: JS -> JS

137+ convert js@(JSVariableIntroduction name (Just fn@(JSFunction _ _ _))) =

138+ let

139+ (argss, body', replace) = collectAllFunctionArgs [] id fn

140+ in case () of

141+ _ | isTailCall name body' ->

142+ let

143+ allArgs = reverse $ concat argss

144+ in

145+ JSVariableIntroduction name (Just (replace (toLoop name allArgs body')))

146+ | otherwise -> js

147+ convert js = js

148+ collectAllFunctionArgs :: [[Ident]] -> (JS -> JS) -> JS -> ([[Ident]], JS, JS -> JS)

149+ collectAllFunctionArgs allArgs f (JSFunction ident args (JSBlock (body@(JSReturn _):_))) =

150+ collectAllFunctionArgs (args : allArgs) (\b -> f (JSFunction ident (map copyVar args) (JSBlock [b]))) body

151+ collectAllFunctionArgs allArgs f (JSFunction ident args body@(JSBlock _)) =

152+ (args : allArgs, body, \b -> f (JSFunction ident (map copyVar args) b))

153+ collectAllFunctionArgs allArgs f (JSReturn (JSFunction ident args (JSBlock [body]))) =

154+ collectAllFunctionArgs (args : allArgs) (\b -> f (JSReturn (JSFunction ident (map copyVar args) (JSBlock [b])))) body

155+ collectAllFunctionArgs allArgs f (JSReturn (JSFunction ident args body@(JSBlock _))) =

156+ (args : allArgs, body, \b -> f (JSReturn (JSFunction ident (map copyVar args) b)))

157+ collectAllFunctionArgs allArgs f body = (allArgs, body, f)

158+ isTailCall :: Ident -> JS -> Bool

159+ isTailCall ident js =

160+ let

161+ numSelfCalls = everything (+) (mkQ 0 countSelfCalls) js

162+ numSelfCallsInTailPosition = everything (+) (mkQ 0 countSelfCallsInTailPosition) js

163+ numSelfCallsUnderFunctions = everything (+) (mkQ 0 countSelfCallsUnderFunctions) js

164+ in

165+ numSelfCalls > 0

166+ && numSelfCalls == numSelfCallsInTailPosition

167+ && numSelfCallsUnderFunctions == 0

168+ where

169+ countSelfCalls :: JS -> Int

170+ countSelfCalls (JSApp (JSVar ident') _) | ident == ident' = 1

171+ countSelfCalls _ = 0

172+ countSelfCallsInTailPosition :: JS -> Int

173+ countSelfCallsInTailPosition (JSReturn ret) | isSelfCall ident ret = 1

174+ countSelfCallsInTailPosition _ = 0

175+ countSelfCallsUnderFunctions (JSFunction _ _ js') = everything (+) (mkQ 0 countSelfCalls) js'

176+ countSelfCallsUnderFunctions _ = 0

177+ toLoop :: Ident -> [Ident] -> JS -> JS

178+ toLoop ident allArgs js = JSBlock $

179+ map (\arg -> JSVariableIntroduction arg (Just (JSVar (copyVar arg)))) allArgs ++

180+ [ JSLabel tcoLabel $ JSWhile (JSBooleanLiteral True) (JSBlock [ everywhere (mkT loopify) js ]) ]

181+ where

182+ loopify :: JS -> JS

183+ loopify (JSReturn ret) | isSelfCall ident ret =

184+ let

185+ allArgumentValues = concat $ collectSelfCallArgs [] ret

186+ in

187+ JSBlock $ zipWith (\val arg ->

188+ JSVariableIntroduction (tcoVar arg) (Just val)) allArgumentValues allArgs

189+ ++ map (\arg ->

190+ JSAssignment (JSAssignVariable arg) (JSVar (tcoVar arg))) allArgs

191+ ++ [ JSContinue tcoLabel ]

192+ loopify other = other

193+ collectSelfCallArgs :: [[JS]] -> JS -> [[JS]]

194+ collectSelfCallArgs allArgumentValues (JSApp fn args') = collectSelfCallArgs (args' : allArgumentValues) fn

195+ collectSelfCallArgs allArgumentValues _ = allArgumentValues

196+ isSelfCall :: Ident -> JS -> Bool

197+ isSelfCall ident (JSApp (JSVar ident') _) | ident == ident' = True

198+ isSelfCall ident (JSApp fn _) = isSelfCall ident fn

199+ isSelfCall _ _ = False

200+

201+magicDo :: Options -> JS -> JS

202+magicDo opts | optionsMagicDo opts = magicDo'

203+ | otherwise = id

204+

205+magicDo' :: JS -> JS

206+magicDo' = everywhere (mkT undo) . everywhere' (mkT convert)

207+ where

208+ fnName = Ident "__do"

209+ convert :: JS -> JS

210+ convert (JSApp (JSApp ret [val]) []) | isReturn ret = val

211+ convert (JSApp (JSApp bind [m]) [JSFunction Nothing [Ident "_"] (JSBlock [JSReturn ret])]) | isBind bind =

212+ JSFunction (Just fnName) [] $ JSBlock [ JSApp m [], JSReturn (JSApp ret []) ]

213+ convert (JSApp (JSApp bind [m]) [JSFunction Nothing [arg] (JSBlock [JSReturn ret])]) | isBind bind =

214+ JSFunction (Just fnName) [] $ JSBlock [ JSVariableIntroduction arg (Just (JSApp m [])), JSReturn (JSApp ret []) ]

215+ convert other = other

216+ isBind (JSAccessor "bind" (JSAccessor "eff" (JSVar (Ident "Eff")))) = True

217+ isBind _ = False

218+ isReturn (JSAccessor "ret" (JSAccessor "eff" (JSVar (Ident "Eff")))) = True

219+ isReturn _ = False

220+ undo :: JS -> JS

221+ undo (JSReturn (JSApp (JSFunction (Just ident) [] body) [])) | ident == fnName = body

222+ undo other = other

223+

224+collapseNestedBlocks :: JS -> JS

225+collapseNestedBlocks = everywhere (mkT collapse)

226+ where

227+ collapse :: JS -> JS

228+ collapse (JSBlock sts) = JSBlock (concatMap go sts)

229+ collapse js = js

230+ go :: JS -> [JS]

231+ go (JSBlock sts) = sts

232+ go s = [s]

src/Language/PureScript/Declarations.hsnew file+53

@@ -0,0 +1,53 @@

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

24+

25+import qualified Data.Data as D

26+

27+type Precedence = Integer

28+

29+data Associativity = Infixl | Infixr deriving (Show, D.Data, D.Typeable)

30+

31+data Fixity = Fixity Associativity Precedence deriving (Show, D.Data, D.Typeable)

32+

33+data Module = Module ProperName [Declaration] deriving (Show, D.Data, D.Typeable)

34+

35+data ForeignImportType

36+ = ForeignImport

37+ | TypeClassDictionaryImport

38+ | TypeClassAccessorImport deriving (Show, Eq, D.Data, D.Typeable)

39+

40+data Declaration

41+ = DataDeclaration ProperName [String] [(ProperName, Maybe Type)]

42+ | DataBindingGroupDeclaration [(ProperName, [String], [(ProperName, Maybe Type)])]

43+ | TypeSynonymDeclaration ProperName [String] Type

44+ | TypeDeclaration Ident Type

45+ | ValueDeclaration Ident [[Binder]] (Maybe Guard) Value

46+ | BindingGroupDeclaration [(Ident, Value)]

47+ | ExternDeclaration ForeignImportType Ident (Maybe JS) Type

48+ | ExternDataDeclaration ProperName Kind

49+ | FixityDeclaration Fixity String

50+ | ImportDeclaration ModuleName (Maybe [Either Ident ProperName])

51+ | TypeClassDeclaration ProperName String [Declaration]

52+ | TypeInstanceDeclaration [(Qualified ProperName, Type)] (Qualified ProperName) Type [Declaration]

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

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

@@ -0,0 +1,27 @@

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

26+ | Row Kind

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

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

@@ -0,0 +1,45 @@

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+

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

22+

23+instance Show Ident where

24+ show (Ident s) = s

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

26+

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

28+

29+instance Show ProperName where

30+ show = runProperName

31+

32+data ModuleName = ModuleName ProperName deriving (Eq, Ord, Data, Typeable)

33+

34+instance Show ModuleName where

35+ show (ModuleName name) = show name

36+

37+data Qualified a = Qualified (Maybe ModuleName) a deriving (Eq, Ord, Data, Typeable)

38+

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

40+ show (Qualified Nothing a) = show a

41+ show (Qualified (Just (ModuleName name)) a) = show name ++ "." ++ show a

42+

43+qualify :: ModuleName -> Qualified a -> (ModuleName, a)

44+qualify m (Qualified Nothing a) = (m, a)

45+qualify _ (Qualified (Just m) a) = (m, a)

src/Language/PureScript/Options.hsnew file+25

@@ -0,0 +1,25 @@

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

2+--

3+-- Module : Language.PureScript.Options

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.Options where

16+

17+data Options = Options

18+ { optionsTco :: Bool

19+ , optionsPerformRuntimeTypeChecks :: Bool

20+ , optionsMagicDo :: Bool

21+ , optionsRunMain :: Bool

22+ } deriving Show

23+

24+defaultOptions :: Options

25+defaultOptions = Options False False False False

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

@@ -0,0 +1,256 @@

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.Functor.Identity

20+import Control.Applicative

21+import Control.Monad

22+import Language.PureScript.Parser.State

23+import qualified Text.Parsec as P

24+import qualified Text.Parsec.Token as PT

25+

26+import Language.PureScript.Names

27+

28+reservedNames :: [String]

29+reservedNames = [ "case"

30+ , "of"

31+ , "data"

32+ , "type"

33+ , "var"

34+ , "val"

35+ , "while"

36+ , "for"

37+ , "foreach"

38+ , "if"

39+ , "then"

40+ , "else"

41+ , "return"

42+ , "true"

43+ , "false"

44+ , "foreign"

45+ , "import"

46+ , "member"

47+ , "forall"

48+ , "do"

49+ , "until"

50+ , "in"

51+ , "break"

52+ , "catch"

53+ , "continue"

54+ , "debugger"

55+ , "default"

56+ , "delete"

57+ , "finally"

58+ , "function"

59+ , "instanceof"

60+ , "new"

61+ , "switch"

62+ , "this"

63+ , "throw"

64+ , "try"

65+ , "typeof"

66+ , "void"

67+ , "with"

68+ , "Number"

69+ , "String"

70+ , "Boolean"

71+ , "infixl"

72+ , "infixr"

73+ , "module"

74+ , "let"

75+ , "class"

76+ , "instance"

77+ , "where" ]

78+

79+builtInOperators :: [String]

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

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

82+

83+reservedOpNames :: [String]

84+reservedOpNames = builtInOperators ++ [ "=>", "->", "=", ".", "\\" ]

85+

86+identStart :: P.Parsec String u Char

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

88+

89+properNameStart :: P.Parsec String u Char

90+properNameStart = P.upper

91+

92+identLetter :: P.Parsec String u Char

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

94+

95+opStart :: P.Parsec String u Char

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

97+

98+opLetter :: P.Parsec String u Char

99+opLetter = P.oneOf ":!#$%&*+./<=>?@\\^|-~"

100+

101+langDef :: PT.GenLanguageDef String u Identity

102+langDef = PT.LanguageDef

103+ { PT.reservedNames = reservedNames

104+ , PT.reservedOpNames = reservedOpNames

105+ , PT.commentStart = "{-"

106+ , PT.commentEnd = "-}"

107+ , PT.commentLine = "--"

108+ , PT.nestedComments = True

109+ , PT.identStart = identStart

110+ , PT.identLetter = identLetter

111+ , PT.opStart = opStart

112+ , PT.opLetter = opLetter

113+ , PT.caseSensitive = True

114+ }

115+

116+tokenParser :: PT.GenTokenParser String u Identity

117+tokenParser = PT.makeTokenParser langDef

118+

119+lexeme :: P.Parsec String u a -> P.Parsec String u a

120+lexeme = PT.lexeme tokenParser

121+

122+identifier :: P.Parsec String u String

123+identifier = PT.identifier tokenParser

124+

125+reserved :: String -> P.Parsec String u ()

126+reserved = PT.reserved tokenParser

127+

128+reservedOp :: String -> P.Parsec String u ()

129+reservedOp = PT.reservedOp tokenParser

130+

131+operator :: P.Parsec String u String

132+operator = PT.operator tokenParser

133+

134+stringLiteral :: P.Parsec String u String

135+stringLiteral = PT.stringLiteral tokenParser

136+

137+whiteSpace :: P.Parsec String u ()

138+whiteSpace = PT.whiteSpace tokenParser

139+

140+semi :: P.Parsec String u String

141+semi = PT.semi tokenParser

142+

143+colon :: P.Parsec String u String

144+colon = PT.colon tokenParser

145+

146+dot :: P.Parsec String u String

147+dot = PT.dot tokenParser

148+

149+comma :: P.Parsec String u String

150+comma = PT.comma tokenParser

151+

152+tick :: P.Parsec String u Char

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

154+

155+pipe :: P.Parsec String u Char

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

157+

158+natural :: P.Parsec String u Integer

159+natural = PT.natural tokenParser

160+

161+squares :: P.Parsec String ParseState a -> P.Parsec String ParseState a

162+squares = P.between (lexeme $ P.char '[') (lexeme $ indented *> P.char ']') . (indented *>)

163+

164+parens :: P.Parsec String ParseState a -> P.Parsec String ParseState a

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

166+

167+braces :: P.Parsec String ParseState a -> P.Parsec String ParseState a

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

169+

170+angles :: P.Parsec String ParseState a -> P.Parsec String ParseState a

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

172+

173+sepBy :: P.Parsec String ParseState a -> P.Parsec String ParseState sep -> P.Parsec String ParseState [a]

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

175+

176+sepBy1 :: P.Parsec String ParseState a -> P.Parsec String ParseState sep -> P.Parsec String ParseState [a]

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

178+

179+semiSep :: P.Parsec String ParseState a -> P.Parsec String ParseState [a]

180+semiSep = flip sepBy semi

181+

182+semiSep1 :: P.Parsec String ParseState a -> P.Parsec String ParseState [a]

183+semiSep1 = flip sepBy1 semi

184+

185+commaSep :: P.Parsec String ParseState a -> P.Parsec String ParseState [a]

186+commaSep = flip sepBy comma

187+

188+commaSep1 :: P.Parsec String ParseState a -> P.Parsec String ParseState [a]

189+commaSep1 = flip sepBy1 comma

190+

191+properName :: P.Parsec String u ProperName

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

193+

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

195+parseQualified parser = qual

196+ where

197+ qual = (Qualified <$> (Just . ModuleName <$> P.try (properName <* delimiter)) <*> parser)

198+ <|> (Qualified Nothing <$> P.try parser)

199+ delimiter = indented *> dot

200+

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

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

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

204+

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

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

207+

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

209+fold first more combine = do

210+ a <- first

211+ bs <- P.many more

212+ return $ foldl combine a bs

213+

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

215+buildPostfixParser fs first = do

216+ a <- first

217+ go a

218+ where

219+ go a = do

220+ maybeA <- P.optionMaybe $ P.choice (map ($ a) fs)

221+ case maybeA of

222+ Nothing -> return a

223+ Just a' -> go a'

224+

225+operatorOrBuiltIn :: P.Parsec String u String

226+operatorOrBuiltIn = P.try operator <|> P.choice (map (\s -> P.try (reservedOp s) >> return s) builtInOperators)

227+

228+parseIdent :: P.Parsec String ParseState Ident

229+parseIdent = (Ident <$> identifier) <|> (Op <$> parens operatorOrBuiltIn)

230+

231+parseIdentInfix :: P.Parsec String ParseState (Qualified Ident)

232+parseIdentInfix = (P.between tick tick (parseQualified (Ident <$> identifier))) <|> parseQualified (Op <$> operatorOrBuiltIn)

233+

234+mark :: P.Parsec String ParseState a -> P.Parsec String ParseState a

235+mark p = do

236+ current <- indentationLevel <$> P.getState

237+ pos <- P.sourceColumn <$> P.getPosition

238+ P.modifyState $ \st -> st { indentationLevel = pos }

239+ a <- p

240+ P.modifyState $ \st -> st { indentationLevel = current }

241+ return a

242+

243+checkIndentation :: (P.Column -> P.Column -> Bool) -> P.Parsec String ParseState ()

244+checkIndentation rel = do

245+ col <- P.sourceColumn <$> P.getPosition

246+ current <- indentationLevel <$> P.getState

247+ guard (col `rel` current)

248+

249+indented :: P.Parsec String ParseState ()

250+indented = checkIndentation (>) P.<?> "indentation"

251+

252+same :: P.Parsec String ParseState ()

253+same = checkIndentation (==) P.<?> "no indentation"

254+

255+runIndentParser :: P.Parsec String ParseState a -> String -> Either P.ParseError a

256+runIndentParser p = P.runParser p (ParseState 0) ""

src/Language/PureScript/Parser/Declarations.hsnew file+145

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

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+ parseModule,

18+ parseModules

19+) where

20+

21+import Data.Maybe (fromMaybe)

22+import Control.Applicative

23+import qualified Text.Parsec as P

24+

25+import Language.PureScript.Names

26+import Language.PureScript.Parser.State

27+import Language.PureScript.Parser.Common

28+import Language.PureScript.Declarations

29+import Language.PureScript.Parser.Values

30+import Language.PureScript.Parser.Types

31+import Language.PureScript.Parser.Kinds

32+import Language.PureScript.Parser.JS

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

34+import Language.PureScript.Values

35+

36+parseDataDeclaration :: P.Parsec String ParseState Declaration

37+parseDataDeclaration = do

38+ reserved "data"

39+ name <- indented *> properName

40+ tyArgs <- many (indented *> identifier)

41+ _ <- lexeme $ indented *> P.char '='

42+ ctors <- sepBy1 ((,) <$> properName <*> P.optionMaybe (indented *> parsePolyType)) pipe

43+ return $ DataDeclaration name tyArgs ctors

44+

45+parseTypeDeclaration :: P.Parsec String ParseState Declaration

46+parseTypeDeclaration =

47+ TypeDeclaration <$> P.try (parseIdent <* lexeme (indented *> P.string "::"))

48+ <*> parsePolyType

49+

50+parseTypeSynonymDeclaration :: P.Parsec String ParseState Declaration

51+parseTypeSynonymDeclaration =

52+ TypeSynonymDeclaration <$> (P.try (reserved "type") *> indented *> properName)

53+ <*> many (indented *> identifier)

54+ <*> (lexeme (indented *> P.char '=') *> parsePolyType)

55+

56+parseValueDeclaration :: P.Parsec String ParseState Declaration

57+parseValueDeclaration =

58+ ValueDeclaration <$> parseIdent

59+ <*> P.many parseTopLevelBinder

60+ <*> P.optionMaybe parseGuard

61+ <*> ((lexeme (indented *> P.char '=')) *> parseValue)

62+

63+parseTopLevelBinder :: P.Parsec String ParseState [Binder]

64+parseTopLevelBinder = return <$> P.try parseBinderNoParens <|> parens (commaSep parseBinder)

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 ForeignImport <$> parseIdent

71+ <*> P.optionMaybe (parseJSLiteral <$> stringLiteral)

72+ <*> (lexeme (indented *> P.string "::") *> parsePolyType))

73+

74+parseJSLiteral :: String -> JS

75+parseJSLiteral s = either (const $ JSRaw s) id $ P.runParser parseJS () "Javascript" s

76+

77+parseAssociativity :: P.Parsec String ParseState Associativity

78+parseAssociativity =

79+ (P.try (reserved "infixl") >> return Infixl) <|>

80+ (P.try (reserved "infixr") >> return Infixr)

81+

82+parseFixity :: P.Parsec String ParseState Fixity

83+parseFixity = Fixity <$> parseAssociativity <*> (indented *> natural)

84+

85+parseFixityDeclaration :: P.Parsec String ParseState Declaration

86+parseFixityDeclaration = do

87+ fixity <- parseFixity

88+ indented

89+ name <- operator

90+ return $ FixityDeclaration fixity name

91+

92+parseImportDeclaration :: P.Parsec String ParseState Declaration

93+parseImportDeclaration = do

94+ reserved "import"

95+ indented

96+ moduleName <- ModuleName <$> properName

97+ idents <- P.optionMaybe $ parens $ commaSep1 (Left <$> parseIdent <|> Right <$> properName)

98+ return $ ImportDeclaration moduleName idents

99+

100+parseTypeClassDeclaration :: P.Parsec String ParseState Declaration

101+parseTypeClassDeclaration = do

102+ reserved "class"

103+ className <- indented *> properName

104+ ident <- indented *> identifier

105+ indented *> reserved "where"

106+ members <- mark (P.many (same *> parseTypeDeclaration))

107+ return $ TypeClassDeclaration className ident members

108+

109+parseTypeInstanceDeclaration :: P.Parsec String ParseState Declaration

110+parseTypeInstanceDeclaration = do

111+ reserved "instance"

112+ deps <- P.optionMaybe $ do

113+ deps <- parens (commaSep1 ((,) <$> parseQualified properName <*> parseType))

114+ indented

115+ reservedOp "=>"

116+ return deps

117+ className <- indented *> parseQualified properName

118+ ty <- indented *> parseType

119+ indented *> reserved "where"

120+ members <- mark (P.many (same *> parseValueDeclaration))

121+ return $ TypeInstanceDeclaration (fromMaybe [] deps) className ty members

122+

123+parseDeclaration :: P.Parsec String ParseState Declaration

124+parseDeclaration = P.choice

125+ [ parseDataDeclaration

126+ , parseTypeDeclaration

127+ , parseTypeSynonymDeclaration

128+ , parseValueDeclaration

129+ , parseExternDeclaration

130+ , parseFixityDeclaration

131+ , parseImportDeclaration

132+ , parseTypeClassDeclaration

133+ , parseTypeInstanceDeclaration ] P.<?> "declaration"

134+

135+parseModule :: P.Parsec String ParseState Module

136+parseModule = do

137+ reserved "module"

138+ indented

139+ name <- properName

140+ _ <- lexeme $ P.string "where"

141+ decls <- mark (P.many (same *> parseDeclaration))

142+ return $ Module name decls

143+

144+parseModules :: P.Parsec String ParseState [Module]

145+parseModules = whiteSpace *> mark (P.many (same *> parseModule)) <* P.eof

src/Language/PureScript/Parser/JS.hsnew file+169

@@ -0,0 +1,169 @@

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

2+--

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

16+ parseJS

17+) where

18+

19+import Language.PureScript.Values

20+import Language.PureScript.Names

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

22+import qualified Language.PureScript.Parser.Common as C

23+import Control.Applicative

24+import Data.Functor.Identity

25+import qualified Text.Parsec as P

26+import qualified Text.Parsec.Token as P

27+import qualified Text.Parsec.Expr as P

28+

29+booleanLiteral :: P.Parsec String u Bool

30+booleanLiteral = (C.reserved "true" >> return True) P.<|> (C.reserved "false" >> return False)

31+

32+parseNumericLiteral :: P.Parsec String u JS

33+parseNumericLiteral = JSNumericLiteral <$> C.integerOrFloat

34+

35+parseStringLiteral :: P.Parsec String u JS

36+parseStringLiteral = JSStringLiteral <$> C.stringLiteral

37+

38+parseBooleanLiteral :: P.Parsec String u JS

39+parseBooleanLiteral = JSBooleanLiteral <$> booleanLiteral

40+

41+parseArrayLiteral :: P.Parsec String u JS

42+parseArrayLiteral = JSArrayLiteral <$> P.squares C.tokenParser (P.commaSep C.tokenParser parseJS)

43+

44+parseObjectLiteral :: P.Parsec String u JS

45+parseObjectLiteral = JSObjectLiteral <$> P.braces C.tokenParser (P.commaSep C.tokenParser parseIdentifierAndValue)

46+

47+parseIdentifierAndValue :: P.Parsec String u (String, JS)

48+parseIdentifierAndValue = (,) <$> (C.identifier <* C.colon)

49+ <*> parseJS

50+

51+parseFunction :: P.Parsec String u JS

52+parseFunction = do

53+ C.reserved "function"

54+ name <- P.optionMaybe (Ident <$> C.identifier)

55+ args <- P.parens C.tokenParser $ P.commaSep C.tokenParser (Ident <$> C.identifier)

56+ body <- parseJS

57+ return $ JSFunction name args body

58+

59+parseBlock :: P.Parsec String u JS

60+parseBlock = JSBlock <$> P.braces C.tokenParser (P.many parseJS)

61+

62+parseVar :: P.Parsec String u JS

63+parseVar = JSVar <$> Ident <$> C.identifier

64+

65+parseJSAtom :: P.Parsec String u JS

66+parseJSAtom = P.choice

67+ [ P.try parseNumericLiteral

68+ , P.try parseStringLiteral

69+ , P.try parseBooleanLiteral

70+ , parseArrayLiteral

71+ , P.try parseObjectLiteral

72+ , parseFunction

73+ , parseBlock

74+ , P.try parseVar

75+ , parseVariableIntroduction

76+ , P.try parseAssignment

77+ , parseWhile

78+ , parseIf

79+ , parseReturn

80+ , P.parens C.tokenParser parseJS ]

81+

82+parseAccessor :: JS -> P.Parsec String u JS

83+parseAccessor js = P.try $ flip JSAccessor js <$> (C.dot *> P.notFollowedBy C.opLetter *> C.identifier)

84+

85+parseIndexer :: JS -> P.Parsec String u JS

86+parseIndexer js = P.try $ flip JSIndexer js <$> (P.squares C.tokenParser parseJS)

87+

88+parseConditional :: JS -> P.Parsec String u JS

89+parseConditional js = P.try $ do

90+ _ <- C.lexeme $ P.char '?'

91+ tr <- parseJS

92+ _ <- C.lexeme $ P.char ':'

93+ fa <- parseJS

94+ return $ JSConditional js tr fa

95+

96+binary :: BinaryOperator -> String -> P.Assoc -> P.Operator String u Identity JS

97+binary op s f = P.Infix (P.try $ C.reservedOp s >> return (JSBinary op)) f

98+

99+unary :: UnaryOperator -> String -> P.Operator String u Identity JS

100+unary op s = P.Prefix (P.try $ C.reservedOp s >> return (JSUnary op))

101+

102+parseJS :: P.Parsec String u JS

103+parseJS =

104+ (P.buildExpressionParser operators

105+ . C.buildPostfixParser postfixTable2

106+ $ indexersAndAccessors) P.<?> "javascript"

107+ where

108+ indexersAndAccessors = C.buildPostfixParser postfixTable1 parseJSAtom

109+ postfixTable1 = [ parseAccessor, parseIndexer, parseConditional ]

110+ postfixTable2 = [ \v -> P.try $ JSApp v <$> (P.parens C.tokenParser (P.commaSep C.tokenParser parseJS)) ]

111+ operators = [ [ binary LessThan "<" P.AssocLeft]

112+ , [ binary LessThanOrEqualTo "<=" P.AssocLeft]

113+ , [ binary GreaterThan ">" P.AssocLeft]

114+ , [ binary GreaterThanOrEqualTo ">=" P.AssocLeft]

115+ , [ unary Not "!" ]

116+ , [ unary BitwiseNot "~" ]

117+ , [ unary Negate "-" ]

118+ , [ unary Positive "+" ]

119+ , [ binary Multiply "*" P.AssocLeft]

120+ , [ binary Divide "/" P.AssocLeft]

121+ , [ binary Modulus "%" P.AssocLeft]

122+ , [ binary Concat "+" P.AssocLeft]

123+ , [ binary Add "+" P.AssocLeft]

124+ , [ binary Subtract "-" P.AssocLeft]

125+ , [ binary ShiftLeft "<<" P.AssocLeft]

126+ , [ binary ShiftRight ">>" P.AssocLeft]

127+ , [ binary ZeroFillShiftRight ">>>" P.AssocLeft]

128+ , [ binary EqualTo "===" P.AssocLeft]

129+ , [ binary NotEqualTo "!==" P.AssocLeft]

130+ , [ binary BitwiseAnd "&" P.AssocLeft]

131+ , [ binary BitwiseXor "^" P.AssocLeft]

132+ , [ binary BitwiseOr "|" P.AssocLeft]

133+ , [ binary And "&&" P.AssocRight]

134+ , [ binary Or "||" P.AssocRight]

135+ ]

136+

137+parseVariableIntroduction :: P.Parsec String u JS

138+parseVariableIntroduction = do

139+ C.reserved "var"

140+ name <- Ident <$> P.identifier C.tokenParser

141+ value <- P.optionMaybe $ do

142+ _ <- C.lexeme $ P.char '='

143+ value <- parseJS

144+ _ <- C.semi

145+ return value

146+ return $ JSVariableIntroduction name value

147+

148+parseAssignment :: P.Parsec String u JS

149+parseAssignment = do

150+ tgt <- parseAssignmentTarget

151+ _ <- C.lexeme $ P.char '='

152+ value <- parseJS

153+ _ <- C.semi

154+ return $ JSAssignment tgt value

155+

156+parseAssignmentTarget :: P.Parsec String u JSAssignment

157+parseAssignmentTarget = C.buildPostfixParser [] (JSAssignVariable <$> Ident <$> P.identifier C.tokenParser)

158+

159+parseWhile :: P.Parsec String u JS

160+parseWhile = JSWhile <$> (C.reserved "while" *> P.parens C.tokenParser parseJS)

161+ <*> parseJS

162+

163+parseIf :: P.Parsec String u JS

164+parseIf = JSIfElse <$> (C.reserved "if" *> P.parens C.tokenParser parseJS)

165+ <*> parseJS

166+ <*> P.optionMaybe (C.reserved "else" >> parseJS)

167+

168+parseReturn :: P.Parsec String u JS

169+parseReturn = JSReturn <$> (C.reserved "return" *> parseJS <* C.semi)

src/Language/PureScript/Parser/Kinds.hsnew file+42

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

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+parseBang :: P.Parsec String ParseState Kind

30+parseBang = const Bang <$> lexeme (P.char '!')

31+

32+parseTypeAtom :: P.Parsec String ParseState Kind

33+parseTypeAtom = indented *> P.choice (map P.try

34+ [ parseStar

35+ , parseBang

36+ , parens parseKind ])

37+

38+parseKind :: P.Parsec String ParseState Kind

39+parseKind = P.buildExpressionParser operators parseTypeAtom P.<?> "kind"

40+ where

41+ operators = [ [ P.Prefix (lexeme (P.char '#') >> return Row) ]

42+ , [ P.Infix (lexeme (P.try (P.string "->")) >> return FunKind) P.AssocRight ] ]

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

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

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 qualified Text.Parsec as P

18+

19+data ParseState = ParseState

20+ { indentationLevel :: P.Column } deriving Show

21+

22+

src/Language/PureScript/Parser/Types.hsnew file+119

@@ -0,0 +1,119 @@

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.Monad (unless)

28+

29+parseNumber :: P.Parsec String ParseState Type

30+parseNumber = const Number <$> reserved "Number"

31+

32+parseString :: P.Parsec String ParseState Type

33+parseString = const String <$> reserved "String"

34+

35+parseBoolean :: P.Parsec String ParseState Type

36+parseBoolean = const Boolean <$> reserved "Boolean"

37+

38+parseArray :: P.Parsec String ParseState Type

39+parseArray = squares $ Array <$> parseType

40+

41+parseObject :: P.Parsec String ParseState Type

42+parseObject = braces $ Object <$> parseRow

43+

44+parseFunction :: P.Parsec String ParseState Type

45+parseFunction = do

46+ args <- lexeme $ parens $ commaSep parsePolyType

47+ _ <- lexeme $ P.string "->"

48+ resultType <- parseType

49+ return $ Function args resultType

50+

51+parseTypeVariable :: P.Parsec String ParseState Type

52+parseTypeVariable = TypeVar <$> identifier

53+

54+parseTypeConstructor :: P.Parsec String ParseState Type

55+parseTypeConstructor = TypeConstructor <$> parseQualified properName

56+

57+parseForAll :: P.Parsec String ParseState Type

58+parseForAll = (mkForAll <$> (P.try (reserved "forall") *> P.many1 (indented *> identifier) <* indented <* dot)

59+ <*> parseConstrainedType)

60+

61+parseTypeAtom :: P.Parsec String ParseState Type

62+parseTypeAtom = indented *> P.choice (map P.try

63+ [ parseNumber

64+ , parseString

65+ , parseBoolean

66+ , parseArray

67+ , parseObject

68+ , parseFunction

69+ , parseTypeVariable

70+ , parseTypeConstructor

71+ , parseForAll

72+ , parens parseRow

73+ , parens parseType ])

74+

75+parseConstrainedType :: P.Parsec String ParseState Type

76+parseConstrainedType = do

77+ constraints <- P.optionMaybe . P.try $ do

78+ constraints <- parens . commaSep1 $ do

79+ className <- parseQualified properName

80+ indented

81+ ty <- parseType

82+ return (className, ty)

83+ _ <- lexeme $ P.string "=>"

84+ return constraints

85+ indented

86+ ty <- parseType

87+ return $ maybe ty (flip ConstrainedType ty) constraints

88+

89+parseAnyType :: P.Parsec String ParseState Type

90+parseAnyType = (P.buildExpressionParser operators . buildPostfixParser postfixTable $ parseTypeAtom) P.<?> "type"

91+ where

92+ postfixTable :: [Type -> P.Parsec String ParseState Type]

93+ postfixTable = [ \x -> TypeApp x <$> P.try (indented *> parseTypeAtom) ]

94+ operators = [ [ P.Infix (lexeme (P.try (P.string "->")) >> return (\t1 t2 -> Function [t1] t2)) P.AssocRight ] ]

95+

96+parseType :: P.Parsec String ParseState Type

97+parseType = do

98+ ty <- parseAnyType

99+ unless (isMonoType ty) $ P.unexpected "polymorphic type"

100+ return ty

101+

102+parsePolyType :: P.Parsec String ParseState Type

103+parsePolyType = do

104+ ty <- parseAnyType

105+ unless (isPolyType ty) $ P.unexpected "polymorphic type"

106+ return ty

107+

108+parseNameAndType :: P.Parsec String ParseState t -> P.Parsec String ParseState (String, t)

109+parseNameAndType p = (,) <$> (indented *> identifier <* indented <* lexeme (P.string "::")) <*> p

110+

111+parseRowEnding :: P.Parsec String ParseState Type

112+parseRowEnding = P.option REmpty (TypeVar <$> (lexeme (indented *> P.char '|') *> indented *> identifier))

113+

114+parseRow :: P.Parsec String ParseState Type

115+parseRow = (fromList <$> (commaSep $ parseNameAndType parsePolyType) <*> parseRowEnding) P.<?> "row"

116+ where

117+ fromList :: [(String, Type)] -> Type -> Type

118+ fromList [] r = r

119+ fromList ((name, t):ts) r = RCons name t (fromList ts r)

src/Language/PureScript/Parser/Values.hsnew file+296

@@ -0,0 +1,296 @@

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+ parseGuard,

18+ parseBinder,

19+ parseBinderNoParens,

20+ parseDoNotationElement

21+) where

22+

23+import Language.PureScript.Values

24+import Language.PureScript.Parser.State

25+import qualified Language.PureScript.Parser.Common as C

26+import Control.Applicative

27+import qualified Text.Parsec as P

28+import Text.Parsec.Expr

29+import Language.PureScript.Parser.Types

30+

31+booleanLiteral :: P.Parsec String ParseState Bool

32+booleanLiteral = (C.reserved "true" >> return True) P.<|> (C.reserved "false" >> return False)

33+

34+parseNumericLiteral :: P.Parsec String ParseState Value

35+parseNumericLiteral = NumericLiteral <$> C.integerOrFloat

36+

37+parseStringLiteral :: P.Parsec String ParseState Value

38+parseStringLiteral = StringLiteral <$> C.stringLiteral

39+

40+parseBooleanLiteral :: P.Parsec String ParseState Value

41+parseBooleanLiteral = BooleanLiteral <$> booleanLiteral

42+

43+parseArrayLiteral :: P.Parsec String ParseState Value

44+parseArrayLiteral = ArrayLiteral <$> C.squares (C.commaSep parseValue)

45+

46+parseObjectLiteral :: P.Parsec String ParseState Value

47+parseObjectLiteral = ObjectLiteral <$> C.braces (C.commaSep parseIdentifierAndValue)

48+

49+parseIdentifierAndValue :: P.Parsec String ParseState (String, Value)

50+parseIdentifierAndValue = (,) <$> (C.indented *> C.identifier <* C.indented <* C.colon)

51+ <*> (C.indented *> parseValue)

52+

53+parseAbs :: P.Parsec String ParseState Value

54+parseAbs = do

55+ C.reservedOp "\\"

56+ args <- P.many (C.indented *> (P.try singleArg <|> manyArgs))

57+ C.indented *> C.reservedOp "->"

58+ value <- parseValue

59+ return $ toFunction args value

60+ where

61+ manyArgs :: P.Parsec String ParseState (Value -> Value)

62+ manyArgs = do

63+ args <- C.parens (C.commaSep C.parseIdent)

64+ return $ Abs args

65+ singleArg :: P.Parsec String ParseState (Value -> Value)

66+ singleArg = Abs . return <$> C.parseIdent

67+ toFunction :: [Value -> Value] -> Value -> Value

68+ toFunction [] value = Abs [] value

69+ toFunction args value = foldr (($)) value args

70+

71+parseVar :: P.Parsec String ParseState Value

72+parseVar = Var <$> C.parseQualified C.parseIdent

73+

74+parseConstructor :: P.Parsec String ParseState Value

75+parseConstructor = Constructor <$> C.parseQualified C.properName

76+

77+parseCase :: P.Parsec String ParseState Value

78+parseCase = Case <$> P.between (P.try (C.reserved "case")) (C.indented *> C.reserved "of") (return <$> parseValue)

79+ <*> (C.indented *> C.mark (P.many (C.same *> C.mark parseCaseAlternative)))

80+

81+parseCaseAlternative :: P.Parsec String ParseState ([Binder], Maybe Guard, Value)

82+parseCaseAlternative = (,,) <$> (return <$> parseBinder)

83+ <*> P.optionMaybe parseGuard

84+ <*> (C.indented *> C.reservedOp "->" *> parseValue)

85+ P.<?> "case alternative"

86+

87+parseIfThenElse :: P.Parsec String ParseState Value

88+parseIfThenElse = IfThenElse <$> (P.try (C.reserved "if") *> C.indented *> parseValue)

89+ <*> (C.indented *> C.reserved "then" *> C.indented *> parseValue)

90+ <*> (C.indented *> C.reserved "else" *> C.indented *> parseValue)

91+

92+parseBlock :: P.Parsec String ParseState Value

93+parseBlock = Block <$> parseManyStatements

94+

95+parseManyStatements :: P.Parsec String ParseState [Statement]

96+parseManyStatements = (do

97+ _ <- C.lexeme $ P.char '{'

98+ C.indented

99+ sts <- C.mark (P.many (C.same *> C.mark parseStatement))

100+ _ <- C.lexeme (P.char '}')

101+ return sts) P.<?> "block"

102+

103+parseValueAtom :: P.Parsec String ParseState Value

104+parseValueAtom = P.choice

105+ [ P.try parseNumericLiteral

106+ , P.try parseStringLiteral

107+ , P.try parseBooleanLiteral

108+ , parseArrayLiteral

109+ , P.try parseObjectLiteral

110+ , parseAbs

111+ , P.try parseConstructor

112+ , P.try parseVar

113+ , parseBlock

114+ , parseCase

115+ , parseIfThenElse

116+ , parseDo

117+ , Parens <$> C.parens parseValue ]

118+

119+parsePropertyUpdate :: P.Parsec String ParseState (String, Value)

120+parsePropertyUpdate = do

121+ name <- C.lexeme C.identifier

122+ _ <- C.lexeme $ C.indented *> P.char '='

123+ value <- C.indented *> parseValue

124+ return (name, value)

125+

126+parseAccessor :: Value -> P.Parsec String ParseState Value

127+parseAccessor (Constructor _) = P.unexpected "constructor"

128+parseAccessor obj = P.try $ Accessor <$> (C.indented *> C.dot *> P.notFollowedBy C.opLetter *> C.indented *> C.identifier) <*> pure obj

129+

130+parseDo :: P.Parsec String ParseState Value

131+parseDo = do

132+ C.reserved "do"

133+ C.indented

134+ Do <$> C.mark (P.many (C.same *> C.mark parseDoNotationElement))

135+

136+parseDoNotationLet :: P.Parsec String ParseState DoNotationElement

137+parseDoNotationLet = DoNotationLet <$> (C.reserved "let" *> C.indented *> parseBinder)

138+ <*> (C.indented *> C.reservedOp "=" *> parseValue)

139+

140+parseDoNotationBind :: P.Parsec String ParseState DoNotationElement

141+parseDoNotationBind = DoNotationBind <$> parseBinder <*> (C.indented *> C.reservedOp "<-" *> parseValue)

142+

143+parseDoNotationElement :: P.Parsec String ParseState DoNotationElement

144+parseDoNotationElement = P.choice

145+ [ P.try parseDoNotationBind

146+ , parseDoNotationLet

147+ , P.try (DoNotationValue <$> parseValue) ]

148+

149+parseValue :: P.Parsec String ParseState Value

150+parseValue =

151+ (buildExpressionParser operators

152+ . C.buildPostfixParser postfixTable2

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

154+ where

155+ indexersAndAccessors = C.buildPostfixParser postfixTable1 parseValueAtom

156+ postfixTable1 = [ parseAccessor

157+ , \v -> P.try $ flip ObjectUpdate <$> (C.indented *> C.braces (C.commaSep1 (C.indented *> parsePropertyUpdate))) <*> pure v ]

158+ postfixTable2 = [ \v -> P.try (C.indented *> indexersAndAccessors >>= \t2 -> return (\t1 -> App t1 [t2])) <*> pure v

159+ , \v -> P.try $ flip App <$> (C.indented *> C.parens (C.commaSep parseValue)) <*> pure v

160+ , \v -> flip (TypedValue True) <$> (P.try (C.lexeme (C.indented *> P.string "::")) *> parsePolyType) <*> pure v

161+ ]

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

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

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

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

166+ , [ Infix (C.lexeme (P.try (C.indented *> C.parseIdentInfix P.<?> "operator") >>= \ident ->

167+ return (BinaryNoParens ident))) AssocRight ]

168+ ]

169+

170+parseVariableIntroduction :: P.Parsec String ParseState Statement

171+parseVariableIntroduction = do

172+ C.reserved "var"

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

174+ _ <- C.lexeme $ C.indented *> P.char '='

175+ value <- parseValue

176+ _ <- C.indented *> C.semi

177+ return $ VariableIntroduction name value

178+

179+parseAssignment :: P.Parsec String ParseState Statement

180+parseAssignment = do

181+ tgt <- P.try $ do

182+ tgt <- C.parseIdent

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

184+ return tgt

185+ value <- parseValue

186+ _ <- C.indented *> C.semi

187+ return $ Assignment tgt value

188+

189+parseWhile :: P.Parsec String ParseState Statement

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

191+ <*> (C.indented *> parseManyStatements)

192+

193+parseFor :: P.Parsec String ParseState Statement

194+parseFor = For <$> (C.reserved "for" *> C.indented *> C.lexeme (P.char '(') *> C.indented *> C.parseIdent)

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

196+ <*> (C.indented *> C.reserved "until" *> parseValue <* C.indented <* C.lexeme (P.char ')'))

197+ <*> parseManyStatements

198+

199+parseIf :: P.Parsec String ParseState Statement

200+parseIf = If <$> parseIfStatement

201+

202+parseIfStatement :: P.Parsec String ParseState IfStatement

203+parseIfStatement =

204+ IfStatement <$> (C.reserved "if" *> C.indented *> C.parens parseValue)

205+ <*> parseManyStatements

206+ <*> P.optionMaybe parseElseStatement

207+

208+parseElseStatement :: P.Parsec String ParseState ElseStatement

209+parseElseStatement = C.reserved "else" >> (ElseIf <$> parseIfStatement

210+ <|> Else <$> parseManyStatements)

211+

212+parseReturn :: P.Parsec String ParseState Statement

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

214+

215+parseStatement :: P.Parsec String ParseState Statement

216+parseStatement = P.choice

217+ [ parseVariableIntroduction

218+ , parseAssignment

219+ , parseWhile

220+ , parseFor

221+ , parseIf

222+ , parseReturn ] P.<?> "statement"

223+

224+parseStringBinder :: P.Parsec String ParseState Binder

225+parseStringBinder = StringBinder <$> C.stringLiteral

226+

227+parseBooleanBinder :: P.Parsec String ParseState Binder

228+parseBooleanBinder = BooleanBinder <$> booleanLiteral

229+

230+parseNumberBinder :: P.Parsec String ParseState Binder

231+parseNumberBinder = NumberBinder <$> C.integerOrFloat

232+

233+parseVarBinder :: P.Parsec String ParseState Binder

234+parseVarBinder = VarBinder <$> C.parseIdent

235+

236+parseNullaryBinder :: P.Parsec String ParseState Binder

237+parseNullaryBinder = NullaryBinder <$> C.lexeme (C.parseQualified C.properName)

238+

239+parseUnaryBinder :: P.Parsec String ParseState Binder

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

241+

242+parseObjectBinder :: P.Parsec String ParseState Binder

243+parseObjectBinder = ObjectBinder <$> C.braces (C.commaSep (C.indented *> parseIdentifierAndBinder))

244+

245+parseArrayBinder :: P.Parsec String ParseState Binder

246+parseArrayBinder = C.squares $ ArrayBinder <$> (C.commaSep (C.indented *> parseBinder))

247+

248+parseNamedBinder :: P.Parsec String ParseState Binder

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

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

251+

252+parseNullBinder :: P.Parsec String ParseState Binder

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

254+

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

256+parseIdentifierAndBinder = do

257+ name <- C.lexeme C.identifier

258+ _ <- C.lexeme $ C.indented *> P.char '='

259+ binder <- C.indented *> parseBinder

260+ return (name, binder)

261+

262+parseBinderAtom :: P.Parsec String ParseState Binder

263+parseBinderAtom = P.choice (map P.try

264+ [ parseNullBinder

265+ , parseStringBinder

266+ , parseBooleanBinder

267+ , parseNumberBinder

268+ , parseNamedBinder

269+ , parseVarBinder

270+ , parseUnaryBinder

271+ , parseNullaryBinder

272+ , parseObjectBinder

273+ , parseArrayBinder

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

275+

276+parseBinder :: P.Parsec String ParseState Binder

277+parseBinder = (buildExpressionParser operators parseBinderAtom) P.<?> "expression"

278+ where

279+ operators = [ [ Infix ( C.lexeme (P.try $ C.indented *> C.reservedOp ":") >> return ConsBinder) AssocRight ] ]

280+

281+parseBinderNoParens :: P.Parsec String ParseState Binder

282+parseBinderNoParens = P.choice (map P.try

283+ [ parseNullBinder

284+ , parseStringBinder

285+ , parseBooleanBinder

286+ , parseNumberBinder

287+ , parseNamedBinder

288+ , parseVarBinder

289+ , parseNullaryBinder

290+ , parseObjectBinder

291+ , parseArrayBinder

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

293+

294+parseGuard :: P.Parsec String ParseState Guard

295+parseGuard = C.indented *> C.pipe *> C.indented *> parseValue

296+

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

@@ -0,0 +1,79 @@

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 Control.Monad.State

21+import qualified Control.Category as C

22+import Control.Category ((>>>))

23+import qualified Control.Arrow as A

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

25+

26+import Language.PureScript.Names

27+

28+identToJs :: Ident -> String

29+identToJs (Ident name) = name

30+identToJs (Op op) = concatMap opCharToString op

31+ where

32+ opCharToString :: Char -> String

33+ opCharToString = (:) '$'. show . ord

34+

35+newtype Pattern u a b = Pattern { runPattern :: A.Kleisli (StateT u Maybe) a b } deriving (C.Category, A.Arrow, A.ArrowZero, A.ArrowPlus)

36+

37+instance Functor (Pattern u a) where

38+ fmap f (Pattern p) = Pattern $ A.Kleisli $ fmap f . A.runKleisli p

39+

40+pattern :: Pattern u a b -> u -> a -> Maybe b

41+pattern p u = flip evalStateT u . A.runKleisli (runPattern p)

42+

43+mkPattern :: (a -> Maybe b) -> Pattern u a b

44+mkPattern f = Pattern $ A.Kleisli (lift . f)

45+

46+mkPattern' :: (a -> StateT u Maybe b) -> Pattern u a b

47+mkPattern' = Pattern . A.Kleisli

48+

49+parens :: String -> String

50+parens s = ('(':s) ++ ")"

51+

52+chainl :: Pattern u a (a, a) -> (r -> r -> r) -> Pattern u a r -> Pattern u a r

53+chainl g f p = fix $ \c -> g >>> ((c <+> p) *** p) >>> A.arr (uncurry f)

54+

55+chainr :: Pattern u a (a, a) -> (r -> r -> r) -> Pattern u a r -> Pattern u a r

56+chainr g f p = fix $ \c -> g >>> (p *** (c <+> p)) >>> A.arr (uncurry f)

57+

58+wrap :: Pattern u a (s, a) -> (s -> r -> r) -> Pattern u a r -> Pattern u a r

59+wrap g f p = fix $ \c -> g >>> (C.id *** (c <+> p)) >>> A.arr (uncurry f)

60+

61+split :: Pattern u a (s, t) -> (s -> t -> r) -> Pattern u a r

62+split s f = s >>> A.arr (uncurry f)

63+

64+data OperatorTable u a r = OperatorTable { runOperatorTable :: [ [Operator u a r] ] }

65+

66+data Operator u a r where

67+ AssocL :: Pattern u a (a, a) -> (r -> r -> r) -> Operator u a r

68+ AssocR :: Pattern u a (a, a) -> (r -> r -> r) -> Operator u a r

69+ Wrap :: Pattern u a (s, a) -> (s -> r -> r) -> Operator u a r

70+ Split :: Pattern u a (s, t) -> (s -> t -> r) -> Operator u a r

71+

72+buildPrettyPrinter :: OperatorTable u a r -> Pattern u a r -> Pattern u a r

73+buildPrettyPrinter table p = foldl (\p' ops -> foldl1 (<+>) (flip map ops $ \op ->

74+ case op of

75+ AssocL pat g -> chainl pat g p'

76+ AssocR pat g -> chainr pat g p'

77+ Wrap pat g -> wrap pat g p'

78+ Split pat g -> split pat g

79+ ) <+> p') p $ runOperatorTable table

src/Language/PureScript/Pretty/JS.hsnew file+239

@@ -0,0 +1,239 @@

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

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 action = do

38+ modify $ \st -> st { indent = indent st + blockIndent }

39+ result <- action

40+ modify $ \st -> st { indent = indent st - blockIndent }

41+ return result

42+

43+currentIndent :: StateT PrinterState Maybe String

44+currentIndent = do

45+ current <- get

46+ return $ replicate (indent current) ' '

47+

48+literals :: Pattern PrinterState JS String

49+literals = mkPattern' match

50+ where

51+ match :: JS -> StateT PrinterState Maybe String

52+ match (JSNumericLiteral n) = return $ either show show n

53+ match (JSStringLiteral s) = return $ show s

54+ match (JSBooleanLiteral True) = return "true"

55+ match (JSBooleanLiteral False) = return "false"

56+ match (JSArrayLiteral xs) = fmap concat $ sequence

57+ [ return "[ "

58+ , fmap (intercalate ", ") $ forM xs prettyPrintJS'

59+ , return " ]"

60+ ]

61+ match (JSObjectLiteral ps) = fmap concat $ sequence

62+ [ return "{\n"

63+ , withIndent $ do

64+ jss <- forM ps $ \(key, value) -> fmap ((key ++ ": ") ++) . prettyPrintJS' $ value

65+ indentString <- currentIndent

66+ return $ intercalate ", \n" $ map (indentString ++) jss

67+ , return "\n"

68+ , currentIndent

69+ , return "}"

70+ ]

71+ match (JSBlock sts) = fmap concat $ sequence

72+ [ return "{\n"

73+ , withIndent $ do

74+ jss <- forM sts prettyPrintJS'

75+ indentString <- currentIndent

76+ return $ intercalate "\n" $ map (++ ";") $ map (indentString ++) jss

77+ , return "\n"

78+ , currentIndent

79+ , return "}"

80+ ]

81+ match (JSVar ident) = return (identToJs ident)

82+ match (JSVariableIntroduction ident value) = fmap concat $ sequence

83+ [ return "var "

84+ , return $ identToJs ident

85+ , maybe (return "") (fmap (" = " ++) . prettyPrintJS') value

86+ ]

87+ match (JSAssignment target value) = fmap concat $ sequence

88+ [ return $ targetToJs target

89+ , return " = "

90+ , prettyPrintJS' value

91+ ]

92+ match (JSWhile cond sts) = fmap concat $ sequence

93+ [ return "while ("

94+ , prettyPrintJS' cond

95+ , return ") "

96+ , prettyPrintJS' sts

97+ ]

98+ match (JSFor ident start end sts) = fmap concat $ sequence

99+ [ return $ "for (" ++ identToJs ident ++ " = "

100+ , prettyPrintJS' start

101+ , return $ "; " ++ identToJs ident ++ " < "

102+ , prettyPrintJS' end

103+ , return $ "; " ++ identToJs ident ++ "++) "

104+ , prettyPrintJS' sts

105+ ]

106+ match (JSIfElse cond thens elses) = fmap concat $ sequence

107+ [ return "if ("

108+ , prettyPrintJS' cond

109+ , return ") "

110+ , prettyPrintJS' thens

111+ , maybe (return "") (fmap (" else " ++) . prettyPrintJS') elses

112+ ]

113+ match (JSReturn value) = fmap concat $ sequence

114+ [ return "return "

115+ , prettyPrintJS' value

116+ ]

117+ match (JSThrow value) = fmap concat $ sequence

118+ [ return "throw "

119+ , prettyPrintJS' value

120+ ]

121+ match (JSBreak lbl) = return $ "break " ++ lbl

122+ match (JSContinue lbl) = return $ "continue " ++ lbl

123+ match (JSLabel lbl js) = fmap concat $ sequence

124+ [ return $ lbl ++ ": "

125+ , prettyPrintJS' js

126+ ]

127+ match (JSRaw js) = return js

128+ match _ = mzero

129+

130+targetToJs :: JSAssignment -> String

131+targetToJs (JSAssignVariable ident) = identToJs ident

132+targetToJs (JSAssignProperty prop target) = targetToJs target ++ "." ++ prop

133+

134+conditional :: Pattern PrinterState JS ((JS, JS), JS)

135+conditional = mkPattern match

136+ where

137+ match (JSConditional cond th el) = Just ((th, el), cond)

138+ match _ = Nothing

139+

140+accessor :: Pattern PrinterState JS (String, JS)

141+accessor = mkPattern match

142+ where

143+ match (JSAccessor prop val) = Just (prop, val)

144+ match _ = Nothing

145+

146+indexer :: Pattern PrinterState JS (String, JS)

147+indexer = mkPattern' match

148+ where

149+ match (JSIndexer index val) = (,) <$> prettyPrintJS' index <*> pure val

150+ match _ = mzero

151+

152+lam :: Pattern PrinterState JS ((Maybe Ident, [Ident]), JS)

153+lam = mkPattern match

154+ where

155+ match (JSFunction name args ret) = Just ((name, args), ret)

156+ match _ = Nothing

157+

158+app :: Pattern PrinterState JS (String, JS)

159+app = mkPattern' match

160+ where

161+ match (JSApp val args) = do

162+ jss <- mapM prettyPrintJS' args

163+ return (intercalate ", " jss, val)

164+ match _ = mzero

165+

166+typeOf :: Pattern PrinterState JS ((), JS)

167+typeOf = mkPattern match

168+ where

169+ match (JSTypeOf val) = Just ((), val)

170+ match _ = Nothing

171+

172+unary :: UnaryOperator -> String -> Operator PrinterState JS String

173+unary op str = Wrap match (++)

174+ where

175+ match :: Pattern PrinterState JS (String, JS)

176+ match = mkPattern match'

177+ where

178+ match' (JSUnary op' val) | op' == op = Just (str, val)

179+ match' _ = Nothing

180+

181+binary :: BinaryOperator -> String -> Operator PrinterState JS String

182+binary op str = AssocR match (\v1 v2 -> v1 ++ " " ++ str ++ " " ++ v2)

183+ where

184+ match :: Pattern PrinterState JS (JS, JS)

185+ match = mkPattern match'

186+ where

187+ match' (JSBinary op' v1 v2) | op' == op = Just (v1, v2)

188+ match' _ = Nothing

189+

190+prettyPrintJS1 :: JS -> String

191+prettyPrintJS1 = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyPrintJS'

192+

193+prettyPrintJS :: [JS] -> String

194+prettyPrintJS sts = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) $ do

195+ jss <- forM sts prettyPrintJS'

196+ indentString <- currentIndent

197+ return $ intercalate "\n" $ map (++ ";") $ map (indentString ++) jss

198+

199+prettyPrintJS' :: JS -> StateT PrinterState Maybe String

200+prettyPrintJS' = A.runKleisli $ runPattern matchValue

201+ where

202+ matchValue :: Pattern PrinterState JS String

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

204+ operators :: OperatorTable PrinterState JS String

205+ operators =

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

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

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

209+ , [ Wrap lam $ \(name, args) ret -> "function "

210+ ++ maybe "" identToJs name

211+ ++ "(" ++ intercalate ", " (map identToJs args) ++ ") "

212+ ++ ret ]

213+ , [ Wrap conditional $ \(th, el) cond -> cond ++ " ? " ++ prettyPrintJS1 th ++ " : " ++ prettyPrintJS1 el ]

214+ , [ binary LessThan "<" ]

215+ , [ binary LessThanOrEqualTo "<=" ]

216+ , [ binary GreaterThan ">" ]

217+ , [ binary GreaterThanOrEqualTo ">=" ]

218+ , [ Wrap typeOf $ \_ s -> "typeof " ++ s ]

219+ , [ unary Not "!" ]

220+ , [ unary BitwiseNot "~" ]

221+ , [ unary Negate "-" ]

222+ , [ unary Positive "+" ]

223+ , [ binary Multiply "*" ]

224+ , [ binary Divide "/" ]

225+ , [ binary Modulus "%" ]

226+ , [ binary Concat "+" ]

227+ , [ binary Add "+" ]

228+ , [ binary Subtract "-" ]

229+ , [ binary ShiftLeft "<<" ]

230+ , [ binary ShiftRight ">>" ]

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

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

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

234+ , [ binary BitwiseAnd "&" ]

235+ , [ binary BitwiseXor "^" ]

236+ , [ binary BitwiseOr "|" ]

237+ , [ binary And "&&" ]

238+ , [ binary Or "||" ]

239+ ]

src/Language/PureScript/Pretty/Kinds.hsnew file+54

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

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+

21+import Language.PureScript.Kinds

22+import Language.PureScript.Pretty.Common

23+import Language.PureScript.Unknown

24+import Control.Arrow (ArrowPlus(..))

25+

26+typeLiterals :: Pattern () Kind String

27+typeLiterals = mkPattern match

28+ where

29+ match Star = Just "*"

30+ match Bang = Just "!"

31+ match (KUnknown (Unknown u)) = Just $ 'u' : show u

32+ match _ = Nothing

33+

34+matchRow :: Pattern () Kind ((), Kind)

35+matchRow = mkPattern match

36+ where

37+ match (Row k) = Just ((), k)

38+ match _ = Nothing

39+

40+funKind :: Pattern () Kind (Kind, Kind)

41+funKind = mkPattern match

42+ where

43+ match (FunKind arg ret) = Just (arg, ret)

44+ match _ = Nothing

45+

46+prettyPrintKind :: Kind -> String

47+prettyPrintKind = fromMaybe (error "Incomplete pattern") . pattern matchKind ()

48+ where

49+ matchKind :: Pattern () Kind String

50+ matchKind = buildPrettyPrinter operators (typeLiterals <+> fmap parens matchKind)

51+ operators :: OperatorTable () Kind String

52+ operators =

53+ OperatorTable [ [ Wrap matchRow $ \_ k -> "# " ++ k]

54+ , [ AssocR funKind $ \arg ret -> arg ++ " -> " ++ ret ] ]

src/Language/PureScript/Pretty/Types.hsnew file+91

@@ -0,0 +1,91 @@

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

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

23+

24+import Language.PureScript.Types

25+import Language.PureScript.Pretty.Common

26+import Language.PureScript.Unknown

27+

28+typeLiterals :: Pattern () Type String

29+typeLiterals = mkPattern match

30+ where

31+ match Number = Just "Number"

32+ match String = Just "String"

33+ match Boolean = Just "Boolean"

34+ match (Array ty) = Just $ "[" ++ prettyPrintType ty ++ "]"

35+ match (Object row) = Just $ "{ " ++ prettyPrintType row ++ " }"

36+ match (TypeVar var) = Just var

37+ match (TypeConstructor ctor) = Just $ show ctor

38+ match (TUnknown (Unknown u)) = Just $ 'u' : show u

39+ match (Skolem s) = Just $ 's' : show s

40+ match (ConstrainedType deps ty) = Just $ "(" ++ intercalate "," (map (\(pn, ty') -> show pn ++ " (" ++ prettyPrintType ty' ++ ")") deps) ++ ") => " ++ prettyPrintType ty

41+ match (SaturatedTypeSynonym name args) = Just $ show name ++ "<" ++ intercalate "," (map prettyPrintType args) ++ ">"

42+ match (ForAll ident ty) = Just $ "forall " ++ ident ++ ". " ++ prettyPrintType ty

43+ match REmpty = Just $ prettyPrintRow REmpty

44+ match row@(RCons _ _ _) = Just $ prettyPrintRow row

45+ match _ = Nothing

46+

47+prettyPrintRow :: Type -> String

48+prettyPrintRow = (\(tys, rest) -> intercalate ", " (map (uncurry nameAndTypeToPs) tys) ++ tailToPs rest) . toList []

49+ where

50+ nameAndTypeToPs :: String -> Type -> String

51+ nameAndTypeToPs name ty = name ++ " :: " ++ prettyPrintType ty

52+ tailToPs :: Type -> String

53+ tailToPs REmpty = ""

54+ tailToPs (TUnknown (Unknown u)) = " | u" ++ show u

55+ tailToPs (TypeVar var) = " | " ++ var

56+ tailToPs (Skolem s) = " | s" ++ show s

57+ tailToPs _ = error "Invalid row tail"

58+ toList :: [(String, Type)] -> Type -> ([(String, Type)], Type)

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

60+ toList tys r = (tys, r)

61+

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

63+typeApp = mkPattern match

64+ where

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

66+ match _ = Nothing

67+

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

69+singleArgumentFunction = mkPattern match

70+ where

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

72+ match _ = Nothing

73+

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

75+function = mkPattern match

76+ where

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

78+ match _ = Nothing

79+

80+prettyPrintType :: Type -> String

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

82+ where

83+ matchType :: Pattern () Type String

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

85+ operators :: OperatorTable () Type String

86+ operators =

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

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

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

90+ ]

91+ ]

src/Language/PureScript/Pretty/Values.hsnew file+214

@@ -0,0 +1,214 @@

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.Maybe (fromMaybe)

21+import Data.List (intercalate)

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

23+

24+import Language.PureScript.Types

25+import Language.PureScript.Values

26+import Language.PureScript.Pretty.Common

27+import Language.PureScript.Pretty.Types

28+

29+literals :: Pattern () Value String

30+literals = mkPattern match

31+ where

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

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

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

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

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

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

38+ match (Constructor name) = Just $ show name

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

40+ match (Case values binders) = Just $ "case " ++ intercalate " " (map prettyPrintValue values) ++

41+ " of { " ++ intercalate " ; " (map prettyPrintCaseAlternative binders) ++ " }"

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

43+ match (Do els) = Just $ " do { " ++ intercalate "; " (map prettyPrintDoNotationElement els) ++ " }"

44+ match (TypeClassDictionary _ _) = error "Type class dictionary was not replaced"

45+ match _ = Nothing

46+

47+prettyPrintCaseAlternative :: ([Binder], Maybe Guard, Value) -> String

48+prettyPrintCaseAlternative (binders, grd, val) = "(" ++ intercalate ", " (map prettyPrintBinder binders) ++ ") " ++

49+ (maybe "" (("| " ++) . prettyPrintValue) grd) ++ " -> " ++ 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 (Type, 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 match (++)

95+ where

96+ match :: Pattern () Value (String, Value)

97+ match = 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 match (\v1 v2 -> v1 ++ " " ++ str ++ " " ++ v2)

104+ where

105+ match :: Pattern () Value (Value, Value)

106+ match = mkPattern match'

107+ where

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

109+ match' _ = Nothing

110+

111+prettyPrintDoNotationElement :: DoNotationElement -> String

112+prettyPrintDoNotationElement (DoNotationValue val) = prettyPrintValue val

113+prettyPrintDoNotationElement (DoNotationBind binder val) = prettyPrintBinder binder ++ " <- " ++ prettyPrintValue val

114+prettyPrintDoNotationElement (DoNotationLet binder val) = "let " ++ prettyPrintBinder binder ++ " = " ++ prettyPrintValue val

115+

116+prettyPrintValue :: Value -> String

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

118+ where

119+ matchValue :: Pattern () Value String

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

121+ operators :: OperatorTable () Value String

122+ operators =

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

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

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

126+ , [ Split lam $ \args val -> "\\" ++ intercalate ", " args ++ " -> " ++ prettyPrintValue val ]

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

128+ , [ Wrap typed $ \ty val -> val ++ " :: " ++ prettyPrintType ty ]

129+ , [ AssocR indexer (\index val -> val ++ " !! " ++ index) ]

130+ , [ binary LessThan "<" ]

131+ , [ binary LessThanOrEqualTo "<=" ]

132+ , [ binary GreaterThan ">" ]

133+ , [ binary GreaterThanOrEqualTo ">=" ]

134+ , [ unary Not "!" ]

135+ , [ unary BitwiseNot "~" ]

136+ , [ unary Negate "-" ]

137+ , [ unary Positive "+" ]

138+ , [ binary Multiply "*" ]

139+ , [ binary Divide "/" ]

140+ , [ binary Modulus "%" ]

141+ , [ binary Concat "++" ]

142+ , [ binary Add "+" ]

143+ , [ binary Subtract "-" ]

144+ , [ binary ShiftLeft "<<" ]

145+ , [ binary ShiftRight ">>" ]

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

147+ , [ binary EqualTo "==" ]

148+ , [ binary NotEqualTo "!=" ]

149+ , [ binary BitwiseAnd "&" ]

150+ , [ binary BitwiseXor "^" ]

151+ , [ binary BitwiseOr "|" ]

152+ , [ binary And "&&" ]

153+ , [ binary Or "||" ]

154+ ]

155+

156+prettyPrintBinderAtom :: Pattern () Binder String

157+prettyPrintBinderAtom = mkPattern match

158+ where

159+ match :: Binder -> Maybe String

160+ match NullBinder = Just "_"

161+ match (StringBinder str) = Just $ show str

162+ match (NumberBinder num) = Just $ either show show num

163+ match (BooleanBinder True) = Just "true"

164+ match (BooleanBinder False) = Just "false"

165+ match (VarBinder ident) = Just $ show ident

166+ match (NullaryBinder ctor) = Just $ show ctor

167+ match (UnaryBinder ctor b) = Just $ show ctor ++ " " ++ prettyPrintBinder b

168+ match (ObjectBinder bs) = Just $ "{ " ++ intercalate ", " (map (uncurry prettyPrintObjectPropertyBinder) bs) ++ " }"

169+ match (ArrayBinder bs) = Just $ "[ " ++ intercalate ", " (map prettyPrintBinder bs) ++ " ]"

170+ match (NamedBinder ident binder) = Just $ show ident ++ "@" ++ prettyPrintBinder binder

171+ match _ = Nothing

172+

173+prettyPrintBinder :: Binder -> String

174+prettyPrintBinder = fromMaybe (error "Incomplete pattern") . pattern matchBinder ()

175+ where

176+ matchBinder :: Pattern () Binder String

177+ matchBinder = buildPrettyPrinter operators (prettyPrintBinderAtom <+> fmap parens matchBinder)

178+ operators :: OperatorTable () Binder String

179+ operators =

180+ OperatorTable [ [ AssocR matchConsBinder (\b1 b2 -> b1 ++ " : " ++ b2) ] ]

181+

182+matchConsBinder :: Pattern () Binder (Binder, Binder)

183+matchConsBinder = mkPattern match'

184+ where

185+ match' (ConsBinder b1 b2) = Just (b1, b2)

186+ match' _ = Nothing

187+

188+prettyPrintObjectPropertyBinder :: String -> Binder -> String

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

190+

191+prettyPrintObjectProperty :: String -> Value -> String

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

193+

194+prettyPrintStatement :: Statement -> String

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

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

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

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

199+ ++ " <- " ++ prettyPrintValue start

200+ ++ " until " ++ prettyPrintValue end ++ ": {"

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

202+prettyPrintStatement (If ifst) = prettyPrintIfStatement ifst

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

204+

205+prettyPrintIfStatement :: IfStatement -> String

206+prettyPrintIfStatement (IfStatement cond thens elst) =

207+ "if "

208+ ++ prettyPrintValue cond ++ ": {"

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

210+ ++ maybe "" prettyPrintElseStatement elst

211+

212+prettyPrintElseStatement :: ElseStatement -> String

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

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

src/Language/PureScript/Scope.hsnew file+56

@@ -0,0 +1,56 @@

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

2+--

3+-- Module : Language.PureScript.Scope

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

16+ usedNames,

17+ unusedNames

18+) where

19+

20+import Data.Data

21+import Data.List ((\\), nub)

22+import Data.Generics (extQ, mkQ, everything)

23+

24+import Language.PureScript.Values

25+import Language.PureScript.Names

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

27+

28+usedNames :: (Data d) => d -> [Ident]

29+usedNames val = nub $ everything (++) (mkQ [] namesV `extQ` namesS `extQ` namesB `extQ` namesJS) val

30+ where

31+ namesV :: Value -> [Ident]

32+ namesV (Abs args _) = args

33+ namesV (Var (Qualified Nothing name)) = [name]

34+ namesV _ = []

35+ namesS :: Statement -> [Ident]

36+ namesS (VariableIntroduction name _) = [name]

37+ namesS (For name _ _ _) = [name]

38+ namesS _ = []

39+ namesB :: Binder -> [Ident]

40+ namesB (VarBinder name) = [name]

41+ namesB _ = []

42+ namesJS :: JS -> [Ident]

43+ namesJS (JSVar name) = [name]

44+ namesJS (JSFunction (Just name) args _) = name : args

45+ namesJS (JSFunction Nothing args _) = args

46+ namesJS (JSVariableIntroduction name _) = [name]

47+ namesJS (JSFor name _ _ _) = [name]

48+ namesJS _ = []

49+

50+unusedNames :: (Data d) => d -> [Ident]

51+unusedNames val =

52+ let

53+ allNames = usedNames val

54+ varNames = map (Ident . ('_' :) . show) ([1..] :: [Int])

55+ in

56+ varNames \\ allNames

src/Language/PureScript/Sugar.hsnew file+34

@@ -0,0 +1,34 @@

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

2+--

3+-- Module : Language.PureScript.Sugar

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.Sugar (desugar, module S) where

16+

17+import Control.Monad

18+

19+import Language.PureScript.Declarations

20+

21+import Language.PureScript.Sugar.Operators as S

22+import Language.PureScript.Sugar.DoNotation as S

23+import Language.PureScript.Sugar.CaseDeclarations as S

24+import Language.PureScript.Sugar.TypeDeclarations as S

25+import Language.PureScript.Sugar.BindingGroups as S

26+import Language.PureScript.Sugar.TypeClasses as S

27+

28+desugar :: [Module] -> Either String [Module]

29+desugar = desugarTypeClasses

30+ >=> rebracket

31+ >=> desugarDo

32+ >=> desugarCasesModule

33+ >=> desugarTypeDeclarationsModule

34+ >=> return . createBindingGroupsModule

src/Language/PureScript/Sugar/BindingGroups.hsnew file+110

@@ -0,0 +1,110 @@

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

2+--

3+-- Module : Language.PureScript.BindingGroups

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.Sugar.BindingGroups (

16+ createBindingGroups,

17+ createBindingGroupsModule,

18+ collapseBindingGroups,

19+ collapseBindingGroupsModule

20+) where

21+

22+import Data.Data

23+import Data.Graph

24+import Data.Generics

25+import Data.List (nub, intersect)

26+

27+import Language.PureScript.Declarations

28+import Language.PureScript.Names

29+import Language.PureScript.Values

30+import Language.PureScript.Types

31+

32+createBindingGroupsModule :: [Module] -> [Module]

33+createBindingGroupsModule = map $ \(Module name ds) -> Module name (createBindingGroups ds)

34+

35+collapseBindingGroupsModule :: [Module] -> [Module]

36+collapseBindingGroupsModule = map $ \(Module name ds) -> Module name (collapseBindingGroups ds)

37+

38+createBindingGroups :: [Declaration] -> [Declaration]

39+createBindingGroups ds =

40+ let

41+ values = filter isValueDecl ds

42+ dataDecls = filter isDataDecl ds

43+ nonValues = filter (\d -> not (isValueDecl d) && not (isDataDecl d)) ds

44+ allProperNames = map getProperName dataDecls

45+ dataVerts = map (\d -> (d, getProperName d, usedProperNames d `intersect` allProperNames)) dataDecls

46+ dataBindingGroupDecls = map toDataBindingGroup $ stronglyConnComp dataVerts

47+ allIdents = map getIdent values

48+ valueVerts = map (\d -> (d, getIdent d, usedIdents d `intersect` allIdents)) values

49+ bindingGroupDecls = map toBindingGroup $ stronglyConnComp valueVerts

50+ in

51+ dataBindingGroupDecls ++ nonValues ++ bindingGroupDecls

52+

53+collapseBindingGroups :: [Declaration] -> [Declaration]

54+collapseBindingGroups ds = concatMap go ds

55+ where

56+ go (DataBindingGroupDeclaration ds) = map (\(name, args, dctors) -> DataDeclaration name args dctors) ds

57+ go (BindingGroupDeclaration ds) = map (\(ident, val) -> ValueDeclaration ident [] Nothing val) ds

58+ go other = [other]

59+

60+usedIdents :: (Data d) => d -> [Ident]

61+usedIdents = nub . everything (++) (mkQ [] namesV `extQ` namesS)

62+ where

63+ namesV :: Value -> [Ident]

64+ namesV (Var (Qualified Nothing name)) = [name]

65+ namesV _ = []

66+ namesS :: Statement -> [Ident]

67+ namesS (VariableIntroduction name _) = [name]

68+ namesS _ = []

69+

70+usedProperNames :: (Data d) => d -> [ProperName]

71+usedProperNames = nub . everything (++) (mkQ [] names)

72+ where

73+ names :: Type -> [ProperName]

74+ names (TypeConstructor (Qualified Nothing name)) = [name]

75+ names _ = []

76+

77+isValueDecl :: Declaration -> Bool

78+isValueDecl (ValueDeclaration _ _ _ _) = True

79+isValueDecl _ = False

80+

81+isDataDecl :: Declaration -> Bool

82+isDataDecl (DataDeclaration _ _ _) = True

83+isDataDecl _ = False

84+

85+getIdent :: Declaration -> Ident

86+getIdent (ValueDeclaration ident _ _ _) = ident

87+getIdent _ = error "Expected ValueDeclaration"

88+

89+getProperName :: Declaration -> ProperName

90+getProperName (DataDeclaration pn _ _) = pn

91+getProperName _ = error "Expected DataDeclaration"

92+

93+toBindingGroup :: SCC Declaration -> Declaration

94+toBindingGroup (AcyclicSCC d) = d

95+toBindingGroup (CyclicSCC [d]) = d

96+toBindingGroup (CyclicSCC ds') = BindingGroupDeclaration $ map fromValueDecl ds'

97+

98+toDataBindingGroup :: SCC Declaration -> Declaration

99+toDataBindingGroup (AcyclicSCC d) = d

100+toDataBindingGroup (CyclicSCC [d]) = d

101+toDataBindingGroup (CyclicSCC ds') = DataBindingGroupDeclaration $ map fromDataDecl ds'

102+

103+fromValueDecl :: Declaration -> (Ident, Value)

104+fromValueDecl (ValueDeclaration ident [] Nothing val) = (ident, val)

105+fromValueDecl (ValueDeclaration _ _ _ _) = error "Binders should have been desugared"

106+fromValueDecl _ = error "Expected ValueDeclaration"

107+

108+fromDataDecl :: Declaration -> (ProperName, [String], [(ProperName, Maybe Type)])

109+fromDataDecl (DataDeclaration pn args ctors) = (pn, args, ctors)

110+fromDataDecl _ = error "Expected DataDeclaration"

src/Language/PureScript/Sugar/CaseDeclarations.hsnew file+67

@@ -0,0 +1,67 @@

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

2+--

3+-- Module : Language.PureScript.CaseDeclarations

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.Sugar.CaseDeclarations (

16+ desugarCases,

17+ desugarCasesModule

18+) where

19+

20+import Data.List (groupBy)

21+import Control.Applicative ((<$>))

22+import Control.Monad (forM, join, unless)

23+import Control.Monad.Error.Class

24+

25+import Language.PureScript.Names

26+import Language.PureScript.Values

27+import Language.PureScript.Declarations

28+import Language.PureScript.Scope

29+

30+desugarCasesModule :: [Module] -> Either String [Module]

31+desugarCasesModule ms = forM ms $ \(Module name ds) -> Module name <$> desugarCases ds

32+

33+desugarCases :: [Declaration] -> Either String [Declaration]

34+desugarCases = fmap join . mapM toDecls . groupBy inSameGroup

35+

36+inSameGroup :: Declaration -> Declaration -> Bool

37+inSameGroup (ValueDeclaration ident1 _ _ _) (ValueDeclaration ident2 _ _ _) = ident1 == ident2

38+inSameGroup _ _ = False

39+

40+toDecls :: [Declaration] -> Either String [Declaration]

41+toDecls d@[ValueDeclaration _ [] Nothing _] = return d

42+toDecls ds@(ValueDeclaration ident bs _ _ : _) = do

43+ let tuples = map toTuple ds

44+ unless (all ((== map length bs) . map length . fst) tuples) $

45+ throwError $ "Argument list lengths differ in declaration " ++ show ident

46+ return [makeCaseDeclaration ident tuples]

47+toDecls ds = return ds

48+

49+toTuple :: Declaration -> ([[Binder]], (Maybe Guard, Value))

50+toTuple (ValueDeclaration _ bs g val) = (bs, (g, val))

51+toTuple _ = error "Not a value declaration"

52+

53+makeCaseDeclaration :: Ident -> [([[Binder]], (Maybe Guard, Value))] -> Declaration

54+makeCaseDeclaration ident alternatives =

55+ let

56+ argPattern = map length . fst . head $ alternatives

57+ args = take (sum argPattern) $ unusedNames (ident, alternatives)

58+ vars = map (\arg -> Var (Qualified Nothing arg)) args

59+ binders = [ (join bs, g, val) | (bs, (g, val)) <- alternatives ]

60+ value = foldr (\args' ret -> Abs args' ret) (Case vars binders) (rearrange argPattern args)

61+ in

62+ ValueDeclaration ident [] Nothing value

63+

64+rearrange :: [Int] -> [a] -> [[a]]

65+rearrange [] _ = []

66+rearrange (n:ns) xs = take n xs : rearrange ns (drop n xs)

67+

src/Language/PureScript/Sugar/DoNotation.hsnew file+56

@@ -0,0 +1,56 @@

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

2+--

3+-- Module : Language.PureScript.Sugar.DoNotation

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.Sugar.DoNotation (

16+ desugarDo

17+) where

18+

19+import Data.Data

20+import Data.Generics

21+

22+import Language.PureScript.Values

23+import Language.PureScript.Names

24+import Language.PureScript.Scope

25+

26+desugarDo :: (Data d) => d -> Either String d

27+desugarDo = everywhereM (mkM replace)

28+ where

29+ prelude :: ModuleName

30+ prelude = ModuleName (ProperName "Prelude")

31+ ret :: Value

32+ ret = Var (Qualified (Just prelude) (Ident "ret"))

33+ bind :: Value

34+ bind = Var (Qualified (Just prelude) (Op ">>="))

35+ replace :: Value -> Either String Value

36+ replace (Do els) = go els

37+ replace other = return other

38+ go :: [DoNotationElement] -> Either String Value

39+ go [] = error "The impossible happened in desugarDo"

40+ go [DoNotationValue val] = return val

41+ go (DoNotationValue val : rest) = do

42+ rest' <- go rest

43+ return $ App (App bind [val]) [Abs [Ident "_"] rest']

44+ go [DoNotationBind _ _] = Left "Bind statement cannot be the last statement in a do block"

45+ go (DoNotationBind NullBinder val : rest) = go (DoNotationValue val : rest)

46+ go (DoNotationBind (VarBinder ident) val : rest) = do

47+ rest' <- go rest

48+ return $ App (App bind [val]) [Abs [ident] rest']

49+ go (DoNotationBind binder val : rest) = do

50+ rest' <- go rest

51+ let ident = head $ unusedNames rest'

52+ return $ App (App bind [val]) [Abs [ident] (Case [Var (Qualified Nothing ident)] [([binder], Nothing, rest')])]

53+ go [DoNotationLet _ _] = Left "Let statement cannot be the last statement in a do block"

54+ go (DoNotationLet binder val : rest) = do

55+ rest' <- go rest

56+ return $ Case [val] [([binder], Nothing, rest')]

src/Language/PureScript/Sugar/Operators.hsnew file+132

@@ -0,0 +1,132 @@

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

2+--

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

18+ rebracket

19+) where

20+

21+import Language.PureScript.Names

22+import Language.PureScript.Declarations

23+import Language.PureScript.Values

24+

25+import Data.Function (on)

26+import Data.List (groupBy, sortBy)

27+import qualified Data.Map as M

28+import qualified Data.Generics as G

29+import qualified Data.Generics.Extras as G

30+import Control.Monad.State

31+import Control.Applicative

32+import qualified Text.Parsec as P

33+import qualified Text.Parsec.Pos as P

34+import qualified Text.Parsec.Expr as P

35+

36+rebracket :: [Module] -> Either String [Module]

37+rebracket = go M.empty []

38+ where

39+ go _ rb [] = return . reverse $ rb

40+ go m rb (Module name ds : ms) = do

41+ m' <- M.union m <$> collectFixities m (ModuleName name) ds

42+ let opTable = customOperatorTable m'

43+ ds' <- G.everywhereM' (G.mkM (matchOperators (ModuleName name) opTable)) ds

44+ go m' (Module name (G.everywhere (G.mkT removeParens) ds') : rb) ms

45+

46+removeParens :: Value -> Value

47+removeParens (Parens val) = val

48+removeParens val = val

49+

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

51+customOperatorTable fixities =

52+ let

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

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

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

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

57+ in

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

59+

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

61+

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

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

64+ where

65+ parseChains :: Value -> Either String Value

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

67+ parseChains other = return other

68+ extendChain :: Value -> Chain

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

70+ extendChain other = [Left other]

71+ bracketChain :: Chain -> Either String Value

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

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

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

75+

76+toAssoc :: Associativity -> P.Assoc

77+toAssoc Infixl = P.AssocLeft

78+toAssoc Infixr = P.AssocRight

79+

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

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

82+

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

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

85+

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

87+matchOp moduleName op = do

88+ ident <- parseOp

89+ guard (qualify moduleName ident == qualify moduleName op)

90+

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

92+collectFixities m _ [] = return m

93+collectFixities m moduleName (FixityDeclaration fixity name : rest) = do

94+ let qual = Qualified (Just moduleName) (Op name)

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

96+ collectFixities (M.insert qual fixity m) moduleName rest

97+collectFixities m moduleName (ImportDeclaration importedModule _ : rest) = do

98+ let fs = [ (i, fixity) | (Qualified mn i, fixity) <- M.toList m, mn == Just importedModule ]

99+ forM_ fs $ \(name, _) -> do

100+ let qual = Qualified (Just moduleName) name

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

102+ let m' = M.fromList (map (\(i, fixity) -> (Qualified (Just moduleName) i, fixity)) fs)

103+ collectFixities (M.union m' m) moduleName rest

104+collectFixities m moduleName (_:ds) = collectFixities m moduleName ds

105+

106+globalOp :: String -> Qualified Ident

107+globalOp = Qualified Nothing . Op

108+

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

131+ ]

132+

src/Language/PureScript/Sugar/TypeClasses.hsnew file+133

@@ -0,0 +1,133 @@

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

2+--

3+-- Module : Language.PureScript.Sugar.TypeClasses

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.Sugar.TypeClasses (

16+ desugarTypeClasses,

17+ mkDictionaryValueName,

18+ mkDictionaryEntryName

19+) where

20+

21+import Language.PureScript.Declarations

22+import Language.PureScript.Names

23+import Language.PureScript.Types

24+import Language.PureScript.Values

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

26+import Language.PureScript.Sugar.CaseDeclarations

27+

28+import qualified Data.Map as M

29+

30+import Control.Applicative

31+import Control.Monad.State

32+import Data.Maybe (fromMaybe)

33+import Data.List (nub)

34+import Data.Generics (mkQ, everything)

35+import Language.PureScript.Pretty.Common (identToJs)

36+

37+type MemberMap = M.Map (ModuleName, ProperName) (String, [(String, Type)])

38+

39+type Desugar = StateT MemberMap (Either String)

40+

41+desugarTypeClasses :: [Module] -> Either String [Module]

42+desugarTypeClasses = flip evalStateT M.empty . mapM desugarModule

43+

44+desugarModule :: Module -> Desugar Module

45+desugarModule (Module name decls) = Module name <$> concat <$> mapM (desugarDecl (ModuleName name)) decls

46+

47+desugarDecl :: ModuleName -> Declaration -> Desugar [Declaration]

48+desugarDecl mn d@(TypeClassDeclaration name arg members) = do

49+ let tys = map memberToNameAndType members

50+ modify (M.insert (mn, name) (arg, tys))

51+ return $ d : typeClassDictionaryDeclaration name arg members : map (typeClassMemberToDictionaryAccessor name arg) members

52+desugarDecl mn d@(TypeInstanceDeclaration deps name ty members) = do

53+ desugared <- lift $ desugarCases members

54+ entries <- mapM (typeInstanceDictionaryEntryDeclaration mn deps name ty) desugared

55+ dictDecl <- typeInstanceDictionaryDeclaration mn deps name ty desugared

56+ return $ d : entries ++ [dictDecl]

57+desugarDecl _ other = return [other]

58+

59+memberToNameAndType :: Declaration -> (String, Type)

60+memberToNameAndType (TypeDeclaration ident ty) = (identToJs ident, ty)

61+memberToNameAndType _ = error "Invalid declaration in type class definition"

62+

63+typeClassDictionaryDeclaration :: ProperName -> String -> [Declaration] -> Declaration

64+typeClassDictionaryDeclaration name arg members =

65+ TypeSynonymDeclaration name [arg] (Object $ rowFromList (map memberToNameAndType members, REmpty))

66+

67+typeClassMemberToDictionaryAccessor :: ProperName -> String -> Declaration -> Declaration

68+typeClassMemberToDictionaryAccessor name arg (TypeDeclaration ident ty) =

69+ ExternDeclaration TypeClassAccessorImport ident

70+ (Just (JSFunction (Just ident) [Ident "dict"] (JSBlock [JSReturn (JSAccessor (identToJs ident) (JSVar (Ident "dict")))])))

71+ (ForAll arg (ConstrainedType [(Qualified Nothing name, TypeVar arg)] ty))

72+typeClassMemberToDictionaryAccessor _ _ _ = error "Invalid declaration in type class definition"

73+

74+typeInstanceDictionaryDeclaration :: ModuleName -> [(Qualified ProperName, Type)] -> Qualified ProperName -> Type -> [Declaration] -> Desugar Declaration

75+typeInstanceDictionaryDeclaration mn deps name ty decls = do

76+ entryName <- lift $ mkDictionaryValueName mn name ty

77+ memberNames <- mapM memberToNameAndValue decls

78+ return $ ValueDeclaration entryName [] Nothing

79+ (TypedValue False

80+ (Abs

81+ (map (\n -> Ident ('_' : show n)) [1..length deps])

82+ (ObjectLiteral memberNames))

83+ (quantify (Function (map (\(pn, ty') -> TypeApp (TypeConstructor pn) ty') deps) (TypeApp (TypeConstructor name) ty)))

84+ )

85+ where

86+ memberToNameAndValue :: Declaration -> Desugar (String, Value)

87+ memberToNameAndValue (ValueDeclaration ident _ _ _) = do

88+ memberName <- mkDictionaryEntryName mn name ty ident

89+ return (identToJs ident, if null deps then Var (Qualified Nothing memberName)

90+ else App (Var (Qualified Nothing memberName)) (map (\n -> Var (Qualified Nothing (Ident ('_' : show n)))) [1..length deps]))

91+ memberToNameAndValue _ = error "Invalid declaration in type instance definition"

92+

93+typeInstanceDictionaryEntryDeclaration :: ModuleName -> [(Qualified ProperName, Type)] -> Qualified ProperName -> Type -> Declaration -> Desugar Declaration

94+typeInstanceDictionaryEntryDeclaration mn deps name ty (ValueDeclaration ident [] _ val) = do

95+ m <- get

96+ valTy <- lift $ maybe (Left $ "Type class " ++ show name ++ " is undefined. Type class names must be qualified.") Right $

97+ do (arg, members) <- M.lookup (qualify mn name) m

98+ ty' <- lookup (identToJs ident) members

99+ return $ replaceTypeVars arg ty ty'

100+ entryName <- mkDictionaryEntryName mn name ty ident

101+ return $ ValueDeclaration entryName [] Nothing

102+ (TypedValue True val (quantify (if null deps then valTy else ConstrainedType deps valTy)))

103+typeInstanceDictionaryEntryDeclaration _ _ _ _ _ = error "Invalid declaration in type instance definition"

104+

105+qualifiedToString :: ModuleName -> Qualified ProperName -> String

106+qualifiedToString mn (Qualified Nothing pn) = qualifiedToString mn (Qualified (Just mn) pn)

107+qualifiedToString _ (Qualified (Just (ModuleName mn)) pn) = runProperName mn ++ "_" ++ runProperName pn

108+

109+quantify :: Type -> Type

110+quantify ty' = foldr ForAll ty' tyVars

111+ where

112+ tyVars = nub $ everything (++) (mkQ [] collect) ty'

113+ collect (TypeVar v) = [v]

114+ collect _ = []

115+

116+mkDictionaryValueName :: ModuleName -> Qualified ProperName -> Type -> Either String Ident

117+mkDictionaryValueName mn cl ty = do

118+ tyStr <- typeToString mn ty

119+ return $ Ident $ "__" ++ qualifiedToString mn cl ++ "_" ++ tyStr

120+

121+typeToString :: ModuleName -> Type -> Either String String

122+typeToString _ String = return "string"

123+typeToString _ Number = return "number"

124+typeToString _ Boolean = return "boolean"

125+typeToString _ (Array (TypeVar _)) = return "array"

126+typeToString mn (TypeConstructor ty') = return $ qualifiedToString mn ty'

127+typeToString mn (TypeApp ty' (TypeVar _)) = typeToString mn ty'

128+typeToString _ _ = Left "Type class instance must be of the form T a1 ... an"

129+

130+mkDictionaryEntryName :: ModuleName -> Qualified ProperName -> Type -> Ident -> Desugar Ident

131+mkDictionaryEntryName mn name ty ident = do

132+ Ident dictName <- lift $ mkDictionaryValueName mn name ty

133+ return $ Ident $ dictName ++ "_" ++ identToJs ident

src/Language/PureScript/Sugar/TypeDeclarations.hsnew file+35

@@ -0,0 +1,35 @@

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

2+--

3+-- Module : Language.PureScript.Sugar.TypeDeclarations

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.Sugar.TypeDeclarations (

16+ desugarTypeDeclarations,

17+ desugarTypeDeclarationsModule

18+) where

19+

20+import Control.Applicative

21+import Control.Monad.Error.Class

22+import Control.Monad (forM)

23+

24+import Language.PureScript.Declarations

25+import Language.PureScript.Values

26+

27+desugarTypeDeclarationsModule :: [Module] -> Either String [Module]

28+desugarTypeDeclarationsModule ms = forM ms $ \(Module name ds) -> Module name <$> desugarTypeDeclarations ds

29+

30+desugarTypeDeclarations :: [Declaration] -> Either String [Declaration]

31+desugarTypeDeclarations (TypeDeclaration name ty : ValueDeclaration name' [] Nothing val : rest) | name == name' =

32+ desugarTypeDeclarations (ValueDeclaration name [] Nothing (TypedValue True val ty) : rest)

33+desugarTypeDeclarations (TypeDeclaration name _ : _) = throwError $ "Orphan type declaration for " ++ show name

34+desugarTypeDeclarations (d:ds) = (:) d <$> desugarTypeDeclarations ds

35+desugarTypeDeclarations [] = return []

src/Language/PureScript/TypeChecker.hsnew file+213

@@ -0,0 +1,213 @@

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

28+import qualified Data.Map as M

29+import Control.Monad.State

30+import Control.Monad.Error

31+import Data.Either (rights, lefts)

32+

33+import Language.PureScript.Types

34+import Language.PureScript.Names

35+import Language.PureScript.Values

36+import Language.PureScript.Kinds

37+import Language.PureScript.Declarations

38+import Language.PureScript.Sugar.TypeClasses

39+

40+addDataType :: ModuleName -> ProperName -> [String] -> [(ProperName, Maybe Type)] -> Kind -> Check ()

41+addDataType moduleName name args dctors ctorKind = do

42+ env <- getEnv

43+ putEnv $ env { types = M.insert (moduleName, name) (ctorKind, Data) (types env) }

44+ forM_ dctors $ \(dctor, maybeTy) ->

45+ rethrow (("Error in data constructor " ++ show name ++ ":\n") ++) $

46+ addDataConstructor moduleName name args dctor maybeTy

47+

48+addDataConstructor :: ModuleName -> ProperName -> [String] -> ProperName -> Maybe Type -> Check ()

49+addDataConstructor moduleName name args dctor maybeTy = do

50+ env <- getEnv

51+ dataConstructorIsNotDefined moduleName dctor

52+ let retTy = foldl TypeApp (TypeConstructor (Qualified (Just moduleName) name)) (map TypeVar args)

53+ let dctorTy = maybe retTy (\ty -> Function [ty] retTy) maybeTy

54+ let polyType = mkForAll args dctorTy

55+ putEnv $ env { dataConstructors = M.insert (moduleName, dctor) (qualifyAllUnqualifiedNames moduleName env polyType, DataConstructor) (dataConstructors env) }

56+

57+addTypeSynonym :: ModuleName -> ProperName -> [String] -> Type -> Kind -> Check ()

58+addTypeSynonym moduleName name args ty kind = do

59+ env <- getEnv

60+ putEnv $ env { types = M.insert (moduleName, name) (kind, TypeSynonym) (types env)

61+ , typeSynonyms = M.insert (moduleName, name) (args, qualifyAllUnqualifiedNames moduleName env ty) (typeSynonyms env) }

62+

63+typeIsNotDefined :: ModuleName -> ProperName -> Check ()

64+typeIsNotDefined moduleName name = do

65+ env <- getEnv

66+ guardWith (show name ++ " is already defined") $

67+ not $ M.member (moduleName, name) (types env)

68+

69+dataConstructorIsNotDefined :: ModuleName -> ProperName -> Check ()

70+dataConstructorIsNotDefined moduleName dctor = do

71+ env <- getEnv

72+ guardWith (show dctor ++ " is already defined") $

73+ not $ M.member (moduleName, dctor) (dataConstructors env)

74+

75+valueIsNotDefined :: ModuleName -> Ident -> Check ()

76+valueIsNotDefined moduleName name = do

77+ env <- getEnv

78+ case M.lookup (moduleName, name) (names env) of

79+ Just _ -> throwError $ show name ++ " is already defined"

80+ Nothing -> return ()

81+

82+addValue :: ModuleName -> Ident -> Type -> Check ()

83+addValue moduleName name ty = do

84+ env <- getEnv

85+ putEnv (env { names = M.insert (moduleName, name) (qualifyAllUnqualifiedNames moduleName env ty, Value) (names env) })

86+

87+addTypeClassDictionaries :: [TypeClassDictionaryInScope] -> Check ()

88+addTypeClassDictionaries entries = do

89+ modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = entries ++ (typeClassDictionaries . checkEnv $ st) } }

90+

91+typeCheckAll :: ModuleName -> [Declaration] -> Check [Declaration]

92+typeCheckAll _ [] = return []

93+typeCheckAll moduleName (d@(DataDeclaration name args dctors) : rest) = do

94+ rethrow (("Error in type constructor " ++ show name ++ ":\n") ++) $ do

95+ typeIsNotDefined moduleName name

96+ ctorKind <- kindsOf moduleName name args (mapMaybe snd dctors)

97+ addDataType moduleName name args dctors ctorKind

98+ ds <- typeCheckAll moduleName rest

99+ return $ d : ds

100+typeCheckAll moduleName (d@(DataBindingGroupDeclaration tys) : rest) = do

101+ rethrow (("Error in data binding group " ++ show (map (\(name, _, _) -> name) tys) ++ ":\n") ++) $ do

102+ forM_ tys $ \(name, _, _) ->

103+ typeIsNotDefined moduleName name

104+ ks <- kindsOfAll moduleName (map (\(name, args, dctors) -> (name, args, mapMaybe snd dctors)) tys)

105+ forM_ (zip tys ks) $ \((name, args, dctors), ctorKind) ->

106+ addDataType moduleName name args dctors ctorKind

107+ ds <- typeCheckAll moduleName rest

108+ return $ d : ds

109+typeCheckAll moduleName (d@(TypeSynonymDeclaration name args ty) : rest) = do

110+ rethrow (("Error in type synonym " ++ show name ++ ":\n") ++) $ do

111+ typeIsNotDefined moduleName name

112+ kind <- kindsOf moduleName name args [ty]

113+ addTypeSynonym moduleName name args ty kind

114+ ds <- typeCheckAll moduleName rest

115+ return $ d : ds

116+typeCheckAll _ (TypeDeclaration _ _ : _) = error "Type declarations should have been removed"

117+typeCheckAll moduleName (ValueDeclaration name [] Nothing val : rest) = do

118+ d <- rethrow (("Error in declaration " ++ show name ++ ":\n") ++) $ do

119+ valueIsNotDefined moduleName name

120+ [(_, (val', ty))] <- typesOf moduleName [(name, val)]

121+ addValue moduleName name ty

122+ return $ ValueDeclaration name [] Nothing val'

123+ ds <- typeCheckAll moduleName rest

124+ return $ d : ds

125+typeCheckAll _ (ValueDeclaration _ _ _ _ : _) = error "Binders were not desugared"

126+typeCheckAll moduleName (BindingGroupDeclaration vals : rest) = do

127+ d <- rethrow (("Error in binding group " ++ show (map fst vals) ++ ":\n") ++) $ do

128+ forM_ (map fst vals) $ \name ->

129+ valueIsNotDefined moduleName name

130+ tys <- typesOf moduleName vals

131+ vals' <- forM (zip (map fst vals) (map snd tys)) $ \(name, (val, ty)) -> do

132+ addValue moduleName name ty

133+ return (name, val)

134+ return $ BindingGroupDeclaration vals'

135+ ds <- typeCheckAll moduleName rest

136+ return $ d : ds

137+typeCheckAll moduleName (d@(ExternDataDeclaration name kind) : rest) = do

138+ env <- getEnv

139+ guardWith (show name ++ " is already defined") $ not $ M.member (moduleName, name) (types env)

140+ putEnv $ env { types = M.insert (moduleName, name) (kind, TypeSynonym) (types env) }

141+ ds <- typeCheckAll moduleName rest

142+ return $ d : ds

143+typeCheckAll moduleName (d@(ExternDeclaration importTy name _ ty) : rest) = do

144+ rethrow (("Error in foreign import declaration " ++ show name ++ ":\n") ++) $ do

145+ env <- getEnv

146+ kind <- kindOf moduleName ty

147+ guardWith "Expected kind *" $ kind == Star

148+ case M.lookup (moduleName, name) (names env) of

149+ Just _ -> throwError $ show name ++ " is already defined"

150+ Nothing -> putEnv (env { names = M.insert (moduleName, name) (qualifyAllUnqualifiedNames moduleName env ty, Extern importTy) (names env) })

151+ ds <- typeCheckAll moduleName rest

152+ return $ d : ds

153+typeCheckAll moduleName (d@(FixityDeclaration _ name) : rest) = do

154+ ds <- typeCheckAll moduleName rest

155+ env <- getEnv

156+ guardWith ("Fixity declaration with no binding: " ++ name) $ M.member (moduleName, Op name) $ names env

157+ return $ d : ds

158+typeCheckAll currentModule (d@(ImportDeclaration moduleName idents) : rest) = do

159+ env <- getEnv

160+ rethrow errorMessage $ do

161+ guardWith ("Module " ++ show moduleName ++ " does not exist") $ moduleExists env

162+ case idents of

163+ Nothing -> do

164+ shadowIdents (map snd $ filterModule (names env)) env

165+ shadowTypes (map snd $ filterModule (types env)) env

166+ Just idents' -> do

167+ shadowIdents (lefts idents') env

168+ shadowTypes (rights idents') env

169+ ds <- typeCheckAll currentModule rest

170+ return $ d : ds

171+ where errorMessage = (("Error in import declaration " ++ show moduleName ++ ":\n") ++)

172+ filterModule = filter ((== moduleName) . fst) . M.keys

173+ moduleExists env = not (null (filterModule (names env))) || not (null (filterModule (types env)))

174+ shadowIdents idents' env =

175+ forM_ idents' $ \ident -> do

176+ case (moduleName, ident) `M.lookup` names env of

177+ Just (_, Alias _ _) -> return ()

178+ Just (pt, _) -> do

179+ guardWith (show currentModule ++ "." ++ show ident ++ " is already defined") $ (currentModule, ident) `M.notMember` names env

180+ modifyEnv (\e -> e { names = M.insert (currentModule, ident) (pt, Alias moduleName ident) (names e) })

181+ Nothing -> throwError (show moduleName ++ "." ++ show ident ++ " is undefined")

182+ shadowTypes pns env =

183+ forM_ pns $ \pn -> do

184+ case (moduleName, pn) `M.lookup` types env of

185+ Nothing -> throwError (show moduleName ++ "." ++ show pn ++ " is undefined")

186+ Just (_, DataAlias _ _) -> return ()

187+ Just (k, _) -> do

188+ guardWith (show currentModule ++ "." ++ show pn ++ " is already defined") $ (currentModule, pn) `M.notMember` types env

189+ modifyEnv (\e -> e { types = M.insert (currentModule, pn) (k, DataAlias moduleName pn) (types e) })

190+ let keys = map (snd . fst) . filter (\(_, (fn, _)) -> fn `constructs` pn) . M.toList . dataConstructors $ env

191+ forM_ keys $ \dctor -> do

192+ case (moduleName, dctor) `M.lookup` dataConstructors env of

193+ Just (_, Alias _ _) -> return ()

194+ Just (ctorTy, _) -> do

195+ guardWith (show currentModule ++ "." ++ show dctor ++ " is already defined") $ (currentModule, dctor) `M.notMember` dataConstructors env

196+ modifyEnv (\e -> e { dataConstructors = M.insert (currentModule, dctor) (ctorTy, Alias moduleName (Ident (runProperName dctor))) (dataConstructors e) })

197+ Nothing -> throwError (show moduleName ++ "." ++ show dctor ++ " is undefined")

198+ constructs (TypeConstructor (Qualified (Just mn) pn')) pn

199+ = mn == moduleName && pn' == pn

200+ constructs (ForAll _ ty) pn = ty `constructs` pn

201+ constructs (Function _ ty) pn = ty `constructs` pn

202+ constructs (TypeApp ty _) pn = ty `constructs` pn

203+ constructs fn _ = error $ "Invalid arguments to constructs: " ++ show fn

204+typeCheckAll moduleName (d@(TypeClassDeclaration _ _ _) : rest) = do

205+ env <- getEnv

206+ ds <- typeCheckAll moduleName rest

207+ return $ qualifyAllUnqualifiedNames moduleName env d : ds

208+typeCheckAll moduleName (d@(TypeInstanceDeclaration deps className ty _) : rest) = do

209+ env <- getEnv

210+ dictName <- Check . lift $ mkDictionaryValueName moduleName className ty

211+ addTypeClassDictionaries (qualifyAllUnqualifiedNames moduleName env [TypeClassDictionaryInScope dictName className ty (Just deps)])

212+ ds <- typeCheckAll moduleName rest

213+ return $ qualifyAllUnqualifiedNames moduleName env d : ds

src/Language/PureScript/TypeChecker/Kinds.hsnew file+144

@@ -0,0 +1,144 @@

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+{-# OPTIONS_GHC -fno-warn-orphans #-}

16+{-# LANGUAGE DeriveDataTypeable #-}

17+

18+module Language.PureScript.TypeChecker.Kinds (

19+ kindOf,

20+ kindsOf,

21+ kindsOfAll

22+) where

23+

24+import Language.PureScript.Types

25+import Language.PureScript.Kinds

26+import Language.PureScript.Names

27+import Language.PureScript.TypeChecker.Monad

28+import Language.PureScript.Pretty

29+import Language.PureScript.Unknown

30+

31+import Control.Monad.State

32+import Control.Monad.Error

33+import Control.Monad.Reader

34+

35+import Control.Applicative

36+

37+import qualified Data.Map as M

38+

39+instance Unifiable Kind where

40+ unknown = KUnknown

41+ isUnknown (KUnknown u) = Just u

42+ isUnknown _ = Nothing

43+ KUnknown u1 ~~ KUnknown u2 | u1 == u2 = return ()

44+ KUnknown u ~~ k = replace u k

45+ k ~~ KUnknown u = replace u k

46+ Star ~~ Star = return ()

47+ Bang ~~ Bang = return ()

48+ Row k1 ~~ Row k2 = k1 ~~ k2

49+ FunKind k1 k2 ~~ FunKind k3 k4 = do

50+ k1 ~~ k3

51+ k2 ~~ k4

52+ k1 ~~ k2 = throwError $ "Cannot unify " ++ prettyPrintKind k1 ++ " with " ++ prettyPrintKind k2 ++ "."

53+ apply s (KUnknown u) = runSubstitution s u

54+ apply s (FunKind k1 k2) = FunKind (apply s k1) (apply s k2)

55+ apply _ k = k

56+ unknowns (KUnknown (Unknown u)) = [u]

57+ unknowns (FunKind k1 k2) = unknowns k1 ++ unknowns k2

58+ unknowns _ = []

59+

60+kindOf :: ModuleName -> Type -> Check Kind

61+kindOf moduleName ty = fmap (\(k, s) -> apply s k) . runSubst (SubstContext moduleName) $ starIfUnknown <$> infer ty

62+

63+kindsOf :: ModuleName -> ProperName -> [String] -> [Type] -> Check Kind

64+kindsOf moduleName name args ts = fmap (starIfUnknown . (\(k, s) -> apply s k)) . runSubst (SubstContext moduleName) $ do

65+ tyCon <- fresh

66+ kargs <- replicateM (length args) fresh

67+ let dict = (name, tyCon) : zip (map ProperName args) kargs

68+ bindLocalTypeVariables moduleName dict $

69+ solveTypes ts kargs tyCon

70+

71+kindsOfAll :: ModuleName -> [(ProperName, [String], [Type])] -> Check [Kind]

72+kindsOfAll moduleName tys = fmap (map starIfUnknown . (\(ks, s) -> apply s ks)) . runSubst (SubstContext moduleName) $ do

73+ tyCons <- replicateM (length tys) fresh

74+ let dict = zipWith (\(name, _, _) tyCon -> (name, tyCon)) tys tyCons

75+ bindLocalTypeVariables moduleName dict $

76+ zipWithM (\tyCon (_, args, ts) -> do

77+ kargs <- replicateM (length args) fresh

78+ let argDict = zip (map ProperName args) kargs

79+ bindLocalTypeVariables moduleName argDict $

80+ solveTypes ts kargs tyCon) tyCons tys

81+

82+solveTypes :: [Type] -> [Kind] -> Kind -> Subst Kind

83+solveTypes ts kargs tyCon = do

84+ ks <- mapM infer ts

85+ tyCon ~~ foldr FunKind Star kargs

86+ forM_ ks $ \k -> k ~~ Star

87+ return tyCon

88+

89+starIfUnknown :: Kind -> Kind

90+starIfUnknown (KUnknown _) = Star

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

92+starIfUnknown k = k

93+

94+infer :: Type -> Subst Kind

95+infer Number = return Star

96+infer String = return Star

97+infer Boolean = return Star

98+infer (Array t) = do

99+ k <- infer t

100+ k ~~ Star

101+ return Star

102+infer (Object row) = do

103+ k <- infer row

104+ k ~~ Row Star

105+ return Star

106+infer (Function args ret) = do

107+ ks <- mapM infer args

108+ k <- infer ret

109+ k ~~ Star

110+ forM_ ks (~~ Star)

111+ return Star

112+infer (TypeVar v) = do

113+ moduleName <- substCurrentModule <$> ask

114+ lookupTypeVariable moduleName (Qualified Nothing (ProperName v))

115+infer (TypeConstructor v) = do

116+ env <- liftCheck getEnv

117+ moduleName <- substCurrentModule `fmap` ask

118+ case M.lookup (qualify moduleName v) (types env) of

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

120+ Just (kind, _) -> return kind

121+infer (TypeApp t1 t2) = do

122+ k0 <- fresh

123+ k1 <- infer t1

124+ k2 <- infer t2

125+ k1 ~~ FunKind k2 k0

126+ return k0

127+infer (ForAll ident ty) = do

128+ k <- fresh

129+ moduleName <- substCurrentModule <$> ask

130+ bindLocalTypeVariables moduleName [(ProperName ident, k)] $ infer ty

131+infer REmpty = do

132+ k <- fresh

133+ return $ Row k

134+infer (RCons _ ty row) = do

135+ k1 <- infer ty

136+ k2 <- infer row

137+ k2 ~~ Row k1

138+ return $ Row k1

139+infer (ConstrainedType deps ty) = do

140+ mapM_ (infer . snd) deps

141+ k <- infer ty

142+ k ~~ Star

143+ return Star

144+infer _ = error "Invalid argument to infer"

src/Language/PureScript/TypeChecker/Monad.hsnew file+246

@@ -0,0 +1,246 @@

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

23+import Language.PureScript.Names

24+import Language.PureScript.Unknown

25+import Language.PureScript.Declarations

26+

27+import Data.Data

28+import Data.Maybe

29+import Data.Monoid

30+import Data.Generics (mkT, everywhere)

31+

32+import Control.Applicative

33+import Control.Monad.State

34+import Control.Monad.Error

35+import Control.Monad.Reader

36+

37+import qualified Data.Map as M

38+

39+data NameKind

40+ = Value

41+ | Extern ForeignImportType

42+ | Alias ModuleName Ident

43+ | LocalVariable

44+ | DataConstructor deriving Show

45+

46+data TypeDeclarationKind

47+ = Data

48+ | ExternData

49+ | TypeSynonym

50+ | DataAlias ModuleName ProperName

51+ | LocalTypeVariable deriving Show

52+

53+data Environment = Environment

54+ { names :: M.Map (ModuleName, Ident) (Type, NameKind)

55+ , types :: M.Map (ModuleName, ProperName) (Kind, TypeDeclarationKind)

56+ , dataConstructors :: M.Map (ModuleName, ProperName) (Type, NameKind)

57+ , typeSynonyms :: M.Map (ModuleName, ProperName) ([String], Type)

58+ , typeClassDictionaries :: [TypeClassDictionaryInScope]

59+ } deriving (Show)

60+

61+emptyEnvironment :: Environment

62+emptyEnvironment = Environment M.empty M.empty M.empty M.empty []

63+

64+bindNames :: (MonadState CheckState m) => M.Map (ModuleName, Ident) (Type, NameKind) -> m a -> m a

65+bindNames newNames action = do

66+ orig <- get

67+ modify $ \st -> st { checkEnv = (checkEnv st) { names = newNames `M.union` (names . checkEnv $ st) } }

68+ a <- action

69+ modify $ \st -> st { checkEnv = (checkEnv st) { names = names . checkEnv $ orig } }

70+ return a

71+

72+bindTypes :: (MonadState CheckState m) => M.Map (ModuleName, ProperName) (Kind, TypeDeclarationKind) -> m a -> m a

73+bindTypes newNames action = do

74+ orig <- get

75+ modify $ \st -> st { checkEnv = (checkEnv st) { types = newNames `M.union` (types . checkEnv $ st) } }

76+ a <- action

77+ modify $ \st -> st { checkEnv = (checkEnv st) { types = types . checkEnv $ orig } }

78+ return a

79+

80+withTypeClassDictionaries :: (MonadState CheckState m) => [TypeClassDictionaryInScope] -> m a -> m a

81+withTypeClassDictionaries entries action = do

82+ orig <- get

83+ modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = entries ++ (typeClassDictionaries . checkEnv $ st) } }

84+ a <- action

85+ modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = typeClassDictionaries . checkEnv $ orig } }

86+ return a

87+

88+getTypeClassDictionaries :: (Functor m, MonadState CheckState m) => m [TypeClassDictionaryInScope]

89+getTypeClassDictionaries = typeClassDictionaries . checkEnv <$> get

90+

91+bindLocalVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(Ident, Type)] -> m a -> m a

92+bindLocalVariables moduleName bindings action =

93+ bindNames (M.fromList $ flip map bindings $ \(name, ty) -> ((moduleName, name), (ty, LocalVariable))) action

94+

95+bindLocalTypeVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(ProperName, Kind)] -> m a -> m a

96+bindLocalTypeVariables moduleName bindings action =

97+ bindTypes (M.fromList $ flip map bindings $ \(name, k) -> ((moduleName, name), (k, LocalTypeVariable))) action

98+

99+lookupVariable :: (Functor m, MonadState CheckState m, MonadError String m) => ModuleName -> Qualified Ident -> m Type

100+lookupVariable currentModule (Qualified moduleName var) = do

101+ env <- getEnv

102+ case M.lookup (fromMaybe currentModule moduleName, var) (names env) of

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

104+ Just (ty, _) -> return ty

105+

106+lookupTypeVariable :: (Functor m, MonadState CheckState m, MonadError String m) => ModuleName -> Qualified ProperName -> m Kind

107+lookupTypeVariable currentModule (Qualified moduleName name) = do

108+ env <- getEnv

109+ case M.lookup (fromMaybe currentModule moduleName, name) (types env) of

110+ Nothing -> throwError $ "Type variable " ++ show name ++ " is undefined"

111+ Just (k, _) -> return k

112+

113+canonicalize :: ModuleName -> Environment -> Qualified Ident -> (ModuleName, Ident)

114+canonicalize _ _ (Qualified (Just mn) i) = (mn, i)

115+canonicalize mn env (Qualified Nothing i) = case (mn, i) `M.lookup` names env of

116+ Just (_, Alias mn' i') -> (mn', i')

117+ _ -> (mn, i)

118+

119+canonicalizeType :: ModuleName -> Environment -> Qualified ProperName -> (ModuleName, ProperName)

120+canonicalizeType _ _ (Qualified (Just mn) nm) = (mn, nm)

121+canonicalizeType mn env (Qualified Nothing nm) = case (mn, nm) `M.lookup` types env of

122+ Just (_, DataAlias mn' pn') -> (mn', pn')

123+ _ -> (mn, nm)

124+

125+data CheckState = CheckState { checkEnv :: Environment

126+ , checkNextVar :: Int

127+ , checkNextDictName :: Int

128+ }

129+

130+newtype Check a = Check { unCheck :: StateT CheckState (Either String) a }

131+ deriving (Functor, Monad, Applicative, MonadPlus, MonadState CheckState, MonadError String)

132+

133+getEnv :: (Functor m, MonadState CheckState m) => m Environment

134+getEnv = checkEnv <$> get

135+

136+putEnv :: (MonadState CheckState m) => Environment -> m ()

137+putEnv env = modify (\s -> s { checkEnv = env })

138+

139+modifyEnv :: (MonadState CheckState m) => (Environment -> Environment) -> m ()

140+modifyEnv f = modify (\s -> s { checkEnv = f (checkEnv s) })

141+

142+runCheck :: Check a -> Either String (a, Environment)

143+runCheck c = do

144+ (a, s) <- flip runStateT (CheckState emptyEnvironment 0 0) $ unCheck c

145+ return (a, checkEnv s)

146+

147+guardWith :: (MonadError e m) => e -> Bool -> m ()

148+guardWith _ True = return ()

149+guardWith e False = throwError e

150+

151+rethrow :: (MonadError e m) => (e -> e) -> m a -> m a

152+rethrow f = flip catchError $ \e -> throwError (f e)

153+

154+freshDictionaryName :: Check Int

155+freshDictionaryName = do

156+ n <- checkNextDictName <$> get

157+ modify $ \s -> s { checkNextDictName = succ (checkNextDictName s) }

158+ return n

159+

160+newtype Substitution = Substitution { runSubstitution :: forall t. (Unifiable t) => Unknown t -> t }

161+

162+instance Monoid Substitution where

163+ mempty = Substitution unknown

164+ s1 `mappend` s2 = Substitution $ \u -> apply s1 (apply s2 (unknown u))

165+

166+data SubstState = SubstState { substSubst :: Substitution }

167+

168+newtype SubstContext = SubstContext { substCurrentModule :: ModuleName } deriving (Show)

169+

170+newtype Subst a = Subst { unSubst :: ReaderT SubstContext (StateT SubstState Check) a }

171+ deriving (Functor, Monad, Applicative, MonadPlus, MonadReader SubstContext)

172+

173+instance MonadState CheckState Subst where

174+ get = Subst . lift . lift $ get

175+ put = Subst . lift . lift . put

176+

177+deriving instance MonadError String Subst

178+

179+liftCheck :: Check a -> Subst a

180+liftCheck = Subst . lift . lift

181+

182+getSubstState :: Subst SubstState

183+getSubstState = Subst . lift $ get

184+

185+runSubst :: SubstContext -> Subst a -> Check (a, Substitution)

186+runSubst context subst = do

187+ (a, s) <- flip runStateT (SubstState mempty) . flip runReaderT context . unSubst $ subst

188+ return (a, substSubst s)

189+

190+substituteWith :: (Typeable t) => (Unknown t -> t) -> Substitution

191+substituteWith f = Substitution $ \u -> fromMaybe (unknown u) $ do

192+ u1 <- cast u

193+ cast (f u1)

194+

195+substituteOne :: (Unifiable t) => Unknown t -> t -> Substitution

196+substituteOne u t = substituteWith $ \u1 ->

197+ case u1 of

198+ u2 | u2 == u -> t

199+ | otherwise -> unknown u2

200+

201+replace :: (Unifiable t) => Unknown t -> t -> Subst ()

202+replace u t' = do

203+ sub <- substSubst <$> Subst get

204+ let t = apply sub t'

205+ occursCheck u t

206+ let current = apply sub $ unknown u

207+ case isUnknown current of

208+ Just u1 | u1 == u -> return ()

209+ _ -> current ~~ t

210+ Subst . modify $ \s -> s { substSubst = substituteOne u t <> substSubst s }

211+

212+class (Typeable t, Data t, Show t) => Unifiable t where

213+ unknown :: Unknown t -> t

214+ (~~) :: t -> t -> Subst ()

215+ isUnknown :: t -> Maybe (Unknown t)

216+ apply :: Substitution -> t -> t

217+ unknowns :: t -> [Int]

218+

219+instance (Unifiable a) => Unifiable [a] where

220+ unknown _ = error "not supported"

221+ (~~) = zipWithM_ (~~)

222+ isUnknown _ = error "not supported"

223+ apply s = map (apply s)

224+ unknowns = concatMap unknowns

225+

226+occursCheck :: (Unifiable t) => Unknown s -> t -> Subst ()

227+occursCheck (Unknown u) t =

228+ case isUnknown t of

229+ Nothing -> guardWith "Occurs check fails" (u `notElem` unknowns t)

230+ _ -> return ()

231+

232+fresh' :: Subst Int

233+fresh' = do

234+ n <- checkNextVar <$> get

235+ modify $ \s -> s { checkNextVar = succ (checkNextVar s) }

236+ return n

237+

238+fresh :: (Unifiable t) => Subst t

239+fresh = unknown . Unknown <$> fresh'

240+

241+qualifyAllUnqualifiedNames :: (Data d) => ModuleName -> Environment -> d -> d

242+qualifyAllUnqualifiedNames mn env = everywhere (mkT go)

243+ where

244+ go :: Qualified ProperName -> Qualified ProperName

245+ go qual = let (mn', pn') = canonicalizeType mn env qual

246+ in Qualified (Just mn') pn'

src/Language/PureScript/TypeChecker/Synonyms.hsnew file+49

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

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

22+import Language.PureScript.TypeChecker.Monad (Environment(..), canonicalizeType)

23+

24+import Data.Maybe (fromMaybe)

25+import Data.Data

26+import Data.Generics

27+import Data.Generics.Extras

28+import Control.Monad.Writer

29+import Control.Monad.Error

30+

31+buildTypeSubstitution :: Environment -> ModuleName -> (ModuleName, ProperName) -> Int -> Type -> Either String (Maybe Type)

32+buildTypeSubstitution env moduleName name n = go n []

33+ where

34+ go :: Int -> [Type] -> Type -> Either String (Maybe Type)

35+ go 0 args (TypeConstructor ctor) | name == canonicalizeType moduleName env ctor = return (Just $ SaturatedTypeSynonym ctor args)

36+ go m _ (TypeConstructor ctor) | m > 0 && name == qualify moduleName ctor = throwError $ "Partially applied type synonym " ++ show name

37+ go m args (TypeApp f arg) = go (m - 1) (arg:args) f

38+ go _ _ _ = return Nothing

39+

40+saturateTypeSynonym :: (Data d) => Environment -> ModuleName -> (ModuleName, ProperName) -> Int -> d -> Either String d

41+saturateTypeSynonym env moduleName name n = everywhereM' (mkM replace)

42+ where

43+ replace t = fmap (fromMaybe t) $ buildTypeSubstitution env moduleName name n t

44+

45+saturateAllTypeSynonyms :: (Data d) => Environment -> ModuleName -> [((ModuleName, ProperName), Int)] -> d -> Either String d

46+saturateAllTypeSynonyms env moduleName syns d = foldM (\result (name, n) -> saturateTypeSynonym env moduleName name n result) d syns

47+

48+

49+

src/Language/PureScript/TypeChecker/Types.hsnew file+807

@@ -0,0 +1,807 @@

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+{-# OPTIONS_GHC -fno-warn-orphans #-}

16+{-# LANGUAGE DeriveDataTypeable, FlexibleContexts #-}

17+

18+module Language.PureScript.TypeChecker.Types (

19+ typesOf

20+) where

21+

22+import Data.List

23+import Data.Maybe (maybeToList, isNothing, isJust, fromMaybe)

24+import qualified Data.Data as D

25+import Data.Generics

26+ (mkM, everywhereM, everything, mkT, something, everywhere, mkQ)

27+

28+import Language.PureScript.Values

29+import Language.PureScript.Types

30+import Language.PureScript.Kinds

31+import Language.PureScript.Names

32+import Language.PureScript.TypeChecker.Monad

33+import Language.PureScript.TypeChecker.Kinds

34+import Language.PureScript.TypeChecker.Synonyms

35+import Language.PureScript.Pretty

36+import Language.PureScript.Unknown

37+

38+import Control.Monad.State

39+import Control.Monad.Error

40+import Control.Monad.Reader

41+

42+import Control.Applicative

43+import Control.Arrow (Arrow(..))

44+

45+import qualified Data.Map as M

46+import Data.Function (on)

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 s (RCons name ty r) = RCons name (apply s ty) (apply s r)

61+ apply _ t = t

62+ unknowns (TUnknown (Unknown u)) = [u]

63+ unknowns (SaturatedTypeSynonym _ tys) = concatMap unknowns tys

64+ unknowns (ForAll _ ty) = unknowns ty

65+ unknowns (Array t) = unknowns t

66+ unknowns (Object r) = unknowns r

67+ unknowns (Function args ret) = concatMap unknowns args ++ unknowns ret

68+ unknowns (TypeApp t1 t2) = unknowns t1 ++ unknowns t2

69+ unknowns (RCons _ ty r) = unknowns ty ++ unknowns r

70+ unknowns _ = []

71+

72+unifyTypes :: Type -> Type -> Subst ()

73+unifyTypes t1 t2 = rethrow (\e -> "Error unifying type " ++ prettyPrintType t1 ++ " with type " ++ prettyPrintType t2 ++ ":\n" ++ e) $ do

74+ unifyTypes' t1 t2

75+ where

76+ unifyTypes' (TUnknown u1) (TUnknown u2) | u1 == u2 = return ()

77+ unifyTypes' (TUnknown u) t = replace u t

78+ unifyTypes' t (TUnknown u) = replace u t

79+ unifyTypes' (SaturatedTypeSynonym name args) ty = do

80+ ty1 <- expandTypeSynonym name args

81+ ty1 `unifyTypes` ty

82+ unifyTypes' ty s@(SaturatedTypeSynonym _ _) = s `unifyTypes` ty

83+ unifyTypes' (ForAll ident1 ty1) (ForAll ident2 ty2) = do

84+ sk <- skolemize ident1 ty1

85+ replaced <- replaceVarWithUnknown ident2 ty2

86+ sk `unifyTypes` replaced

87+ unifyTypes' (ForAll ident ty1) ty2 = do

88+ sk <- skolemize ident ty1

89+ sk `unifyTypes` ty2

90+ unifyTypes' ty f@(ForAll _ _) = f `unifyTypes` ty

91+ unifyTypes' Number Number = return ()

92+ unifyTypes' String String = return ()

93+ unifyTypes' Boolean Boolean = return ()

94+ unifyTypes' (Array s) (Array t) = s `unifyTypes` t

95+ unifyTypes' (Object row1) (Object row2) = row1 ~~ row2

96+ unifyTypes' (Function args1 ret1) (Function args2 ret2) = do

97+ guardWith "Function applied to incorrect number of args" $ length args1 == length args2

98+ zipWithM_ unifyTypes args1 args2

99+ ret1 `unifyTypes` ret2

100+ unifyTypes' (TypeVar v1) (TypeVar v2) | v1 == v2 = return ()

101+ unifyTypes' (TypeConstructor c1) (TypeConstructor c2) = do

102+ env <- getEnv

103+ moduleName <- substCurrentModule `fmap` ask

104+ guardWith ("Cannot unify " ++ show c1 ++ " with " ++ show c2 ++ ".") (typeConstructorsAreEqual env moduleName c1 c2)

105+ unifyTypes' (TypeApp t3 t4) (TypeApp t5 t6) = do

106+ t3 `unifyTypes` t5

107+ t4 `unifyTypes` t6

108+ unifyTypes' (Skolem s1) (Skolem s2) | s1 == s2 = return ()

109+ unifyTypes' r1@(RCons _ _ _) r2 = unifyRows r1 r2

110+ unifyTypes' r1 r2@(RCons _ _ _) = unifyRows r1 r2

111+ unifyTypes' r1@REmpty r2 = unifyRows r1 r2

112+ unifyTypes' r1 r2@REmpty = unifyRows r1 r2

113+ unifyTypes' t3 t4 = throwError $ "Cannot unify " ++ prettyPrintType t3 ++ " with " ++ prettyPrintType t4 ++ "."

114+

115+unifyRows :: Type -> Type -> Subst ()

116+unifyRows r1 r2 =

117+ let

118+ (s1, r1') = rowToList r1

119+ (s2, r2') = rowToList r2

120+ int = [ (t1, t2) | (name, t1) <- s1, (name', t2) <- s2, name == name' ]

121+ sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ]

122+ sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ]

123+ in do

124+ forM_ int (uncurry (~~))

125+ unifyRows' sd1 r1' sd2 r2'

126+ where

127+ unifyRows' :: [(String, Type)] -> Type -> [(String, Type)] -> Type -> Subst ()

128+ unifyRows' [] (TUnknown u) sd r = replace u (rowFromList (sd, r))

129+ unifyRows' sd r [] (TUnknown u) = replace u (rowFromList (sd, r))

130+ unifyRows' ((name, ty):row) r others u@(TUnknown un) = do

131+ occursCheck un ty

132+ forM_ row $ \(_, t) -> occursCheck un t

133+ u' <- fresh

134+ u ~~ RCons name ty u'

135+ unifyRows' row r others u'

136+ unifyRows' [] REmpty [] REmpty = return ()

137+ unifyRows' [] (TypeVar v1) [] (TypeVar v2) | v1 == v2 = return ()

138+ unifyRows' [] (Skolem s1) [] (Skolem s2) | s1 == s2 = return ()

139+ unifyRows' sd3 r3 sd4 r4 = throwError $ "Cannot unify " ++ prettyPrintRow (rowFromList (sd3, r3)) ++ " with " ++ prettyPrintRow (rowFromList (sd4, r4)) ++ "."

140+

141+typeConstructorsAreEqual :: Environment -> ModuleName -> Qualified ProperName -> Qualified ProperName -> Bool

142+typeConstructorsAreEqual env moduleName = (==) `on` canonicalizeType moduleName env

143+

144+typesOf :: ModuleName -> [(Ident, Value)] -> Check [(Ident, (Value, Type))]

145+typesOf moduleName vals = do

146+ tys <- fmap (\(tys, s) -> map (\(ident, (val, ty)) -> (ident, (overTypes (apply s) val, apply s ty))) tys)

147+ . runSubst (SubstContext moduleName) $ do

148+ let es = map isTyped vals

149+ typed = filter (isJust . snd . snd) es

150+ untyped = filter (isNothing . snd . snd) es

151+ typedDict = map (\(ident, (_, Just ty)) -> (ident, ty)) typed

152+ untypedNames <- replicateM (length untyped) fresh

153+ let untypedDict = zip (map fst untyped) untypedNames

154+ dict = M.fromList (map (\(ident, ty) -> ((moduleName, ident), (ty, LocalVariable))) $ (map (id *** fst) typedDict) ++ untypedDict)

155+ forM es $ \e -> do

156+ triple@(_, (val, ty)) <- case e of

157+ (ident, (val, Just (ty, checkType))) -> do

158+ kind <- liftCheck $ kindOf moduleName ty

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

160+ ty' <- replaceAllTypeSynonyms ty

161+ val' <- bindNames dict $ if checkType then check val ty' else return val

162+ return (ident, (val', ty'))

163+ (ident, (val, Nothing)) -> do

164+ TypedValue _ val' ty <- bindNames dict $ infer val

165+ ty ~~ fromMaybe (error "name not found in dictionary") (lookup ident untypedDict)

166+ return (ident, (val', ty))

167+ when (moduleName == ModuleName (ProperName "Main") && fst e == Ident "main") $ do

168+ [eff, a] <- replicateM 2 fresh

169+ ty ~~ TypeApp (TypeApp (TypeConstructor (Qualified (Just (ModuleName (ProperName "Eff"))) (ProperName "Eff"))) eff) a

170+ escapeCheck val ty

171+ return triple

172+ forM_ tys $ skolemEscapeCheck . snd . snd

173+ forM tys $ \(ident, (val, ty)) -> do

174+ val' <- replaceTypeClassDictionaries moduleName val

175+ return (ident, (overTypes (desaturateAllTypeSynonyms . setifyAll) $ val'

176+ , varIfUnknown . desaturateAllTypeSynonyms . setifyAll $ ty))

177+

178+isTyped :: (Ident, Value) -> (Ident, (Value, Maybe (Type, Bool)))

179+isTyped (name, TypedValue checkType value ty) = (name, (value, Just (ty, checkType)))

180+isTyped (name, value) = (name, (value, Nothing))

181+

182+overTypes :: (Type -> Type) -> Value -> Value

183+overTypes f = everywhere (mkT f)

184+

185+replaceTypeClassDictionaries :: ModuleName -> Value -> Check Value

186+replaceTypeClassDictionaries mn = everywhereM (mkM go)

187+ where

188+ go (TypeClassDictionary constraint dicts) = entails mn dicts constraint

189+ go other = return other

190+

191+entails :: ModuleName -> [TypeClassDictionaryInScope] -> (Qualified ProperName, Type) -> Check Value

192+entails moduleName context goal@(className, ty) = do

193+ env <- getEnv

194+ case go env goal of

195+ [] -> throwError $ "No " ++ show className ++ " instance found for " ++ prettyPrintType ty

196+ (dict : _) -> return dict

197+ where

198+ go env (className', ty') =

199+ [ mkDictionary (tcdName tcd) args

200+ | tcd <- context

201+ , qualify moduleName className' == qualify moduleName (tcdClassName tcd)

202+ , subst <- maybeToList $ typeHeadsAreEqual moduleName env ty' (tcdInstanceType tcd)

203+ , args <- solveSubgoals env subst (tcdDependencies tcd) ]

204+ solveSubgoals _ _ Nothing = return Nothing

205+ solveSubgoals env subst (Just subgoals) = do

206+ dict <- mapM (go env) (replaceAllTypeVars subst subgoals)

207+ return $ Just dict

208+ mkDictionary fnName Nothing = Var (Qualified Nothing fnName)

209+ mkDictionary fnName (Just args) = App (Var (Qualified Nothing fnName)) args

210+

211+typeHeadsAreEqual :: ModuleName -> Environment -> Type -> Type -> Maybe [(String, Type)]

212+typeHeadsAreEqual _ _ String String = Just []

213+typeHeadsAreEqual _ _ Number Number = Just []

214+typeHeadsAreEqual _ _ Boolean Boolean = Just []

215+typeHeadsAreEqual _ _ (Skolem s1) (Skolem s2) | s1 == s2 = Just []

216+typeHeadsAreEqual _ _ (Array (TypeVar v)) (Array ty) = Just [(v, ty)]

217+typeHeadsAreEqual _ _ (Array ty) (Array (TypeVar v)) = Just [(v, ty)]

218+typeHeadsAreEqual m e (Array ty1) (Array ty2) = typeHeadsAreEqual m e ty1 ty2

219+typeHeadsAreEqual m e (TypeConstructor c1) (TypeConstructor c2) | typeConstructorsAreEqual e m c1 c2 = Just []

220+typeHeadsAreEqual m e (TypeApp h1 (TypeVar v)) (TypeApp h2 arg) = (:) (v, arg) <$> typeHeadsAreEqual m e h1 h2

221+typeHeadsAreEqual m e t1@(TypeApp _ _) t2@(TypeApp _ (TypeVar _)) = typeHeadsAreEqual m e t2 t1

222+typeHeadsAreEqual _ _ _ _ = Nothing

223+

224+escapeCheck :: Value -> Type -> Subst ()

225+escapeCheck value ty = do

226+ subst <- substSubst <$> getSubstState

227+ let visibleUnknowns = nub $ unknowns $ apply subst ty

228+ let allUnknowns = findAllTypes value

229+ forM_ allUnknowns $ \t -> do

230+ let unsolvedUnknowns = nub . unknowns $ apply subst t

231+ guardWith "Escape check fails" $ null $ unsolvedUnknowns \\ visibleUnknowns

232+

233+findAllTypes :: Value -> [Type]

234+findAllTypes = everything (++) (mkQ [] go)

235+ where

236+ go (TypedValue _ _ ty) = [ty]

237+ go _ = []

238+

239+skolemEscapeCheck :: Type -> Check ()

240+skolemEscapeCheck ty =

241+ case something (mkQ Nothing findSkolems) ty of

242+ Nothing -> return ()

243+ Just _ -> throwError $ "Skolem variables cannot escape. Consider adding a type signature." ++ show ty

244+ where

245+ findSkolems (Skolem _) = return ()

246+ findSkolems _ = mzero

247+

248+setify :: Type -> Type

249+setify = rowFromList . first (M.toList . M.fromList) . rowToList

250+

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

252+setifyAll = everywhere (mkT setify)

253+

254+varIfUnknown :: Type -> Type

255+varIfUnknown ty =

256+ let unks = nub $ unknowns ty

257+ toName = (:) 't' . show

258+ ty' = everywhere (mkT typeToVar) $ ty

259+ typeToVar :: Type -> Type

260+ typeToVar (TUnknown (Unknown u)) = TypeVar (toName u)

261+ typeToVar t = t

262+ in mkForAll (sort . map toName $ unks) ty'

263+

264+replaceAllTypeVars :: (D.Data d) => [(String, Type)] -> d -> d

265+replaceAllTypeVars = foldl' (\f (name, ty) -> replaceTypeVars name ty . f) id

266+

267+replaceAllVarsWithUnknowns :: Type -> Subst Type

268+replaceAllVarsWithUnknowns (ForAll ident ty) = replaceVarWithUnknown ident ty >>= replaceAllVarsWithUnknowns

269+replaceAllVarsWithUnknowns ty = return ty

270+

271+replaceVarWithUnknown :: String -> Type -> Subst Type

272+replaceVarWithUnknown ident ty = do

273+ tu <- fresh

274+ return $ replaceTypeVars ident tu $ ty

275+

276+replaceAllTypeSynonyms :: (Functor m, MonadState CheckState m, MonadReader SubstContext m, MonadError String m) => (D.Data d) => d -> m d

277+replaceAllTypeSynonyms d = do

278+ env <- getEnv

279+ moduleName <- substCurrentModule <$> ask

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

281+ either throwError return $ saturateAllTypeSynonyms env moduleName syns d

282+

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

284+desaturateAllTypeSynonyms = everywhere (mkT replaceSaturatedTypeSynonym)

285+ where

286+ replaceSaturatedTypeSynonym (SaturatedTypeSynonym name args) = foldl TypeApp (TypeConstructor name) args

287+ replaceSaturatedTypeSynonym t = t

288+

289+expandTypeSynonym :: Qualified ProperName -> [Type] -> Subst Type

290+expandTypeSynonym name args = do

291+ env <- getEnv

292+ moduleName <- substCurrentModule `fmap` ask

293+ case M.lookup (canonicalizeType moduleName env name) (typeSynonyms env) of

294+ Just (synArgs, body) -> return $ replaceAllTypeVars (zip synArgs args) body

295+ Nothing -> error "Type synonym was not defined"

296+

297+ensureNoDuplicateProperties :: (MonadError String m) => [(String, Value)] -> m ()

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

299+

300+infer :: Value -> Subst Value

301+infer val = rethrow (\e -> "Error inferring type of term " ++ prettyPrintValue val ++ ":\n" ++ e) $ infer' val

302+

303+infer' :: Value -> Subst Value

304+infer' v@(NumericLiteral _) = return $ TypedValue True v Number

305+infer' v@(StringLiteral _) = return $ TypedValue True v String

306+infer' v@(BooleanLiteral _) = return $ TypedValue True v Boolean

307+infer' (ArrayLiteral vals) = do

308+ ts <- mapM infer vals

309+ els <- fresh

310+ forM_ ts $ \(TypedValue _ _ t) -> els ~~ Array t

311+ return $ TypedValue True (ArrayLiteral ts) els

312+infer' (Unary op val) = do

313+ v <- infer val

314+ inferUnary op v

315+infer' (Binary op left right) = do

316+ v1 <- infer left

317+ v2 <- infer right

318+ inferBinary op v1 v2

319+infer' (ObjectLiteral ps) = do

320+ ensureNoDuplicateProperties ps

321+ ts <- mapM (infer . snd) ps

322+ let fields = zipWith (\name (TypedValue _ _ t) -> (name, t)) (map fst ps) ts

323+ ty = Object $ rowFromList (fields, REmpty)

324+ return $ TypedValue True (ObjectLiteral (zip (map fst ps) ts)) ty

325+infer' (ObjectUpdate o ps) = do

326+ ensureNoDuplicateProperties ps

327+ row <- fresh

328+ newVals <- zipWith (\(name, _) t -> (name, t)) ps <$> mapM (infer . snd) ps

329+ let newTys = map (\(name, TypedValue _ _ ty) -> (name, ty)) newVals

330+ oldTys <- zip (map fst ps) <$> replicateM (length ps) fresh

331+ o' <- check o $ Object $ rowFromList (oldTys, row)

332+ return $ TypedValue True (ObjectUpdate o' newVals) $ Object $ rowFromList (newTys, row)

333+infer' (Indexer index val) = do

334+ el <- fresh

335+ index' <- check index Number

336+ val' <- check val (Array el)

337+ return $ TypedValue True (Indexer (TypedValue True index' Number) (TypedValue True val' (Array el))) el

338+infer' (Accessor prop val) = do

339+ typed@(TypedValue _ _ objTy) <- infer val

340+ propTy <- inferProperty objTy prop

341+ case propTy of

342+ Nothing -> do

343+ field <- fresh

344+ rest <- fresh

345+ objTy `subsumes` Object (RCons prop field rest)

346+ return $ TypedValue True (Accessor prop typed) field

347+ Just ty -> return $ TypedValue True (Accessor prop typed) ty

348+infer' (Abs args ret) = do

349+ ts <- replicateM (length args) fresh

350+ moduleName <- substCurrentModule <$> ask

351+ bindLocalVariables moduleName (zip args ts) $ do

352+ body@(TypedValue _ _ bodyTy) <- infer' ret

353+ return $ TypedValue True (Abs args body) $ Function ts bodyTy

354+infer' (App f args) = do

355+ f'@(TypedValue _ _ ft) <- infer f

356+ ret <- fresh

357+ app <- checkFunctionApplication f' ft args ret

358+ return $ TypedValue True app ret

359+infer' (Var var) = do

360+ moduleName <- substCurrentModule <$> ask

361+ ty <- lookupVariable moduleName var

362+ ty' <- replaceAllTypeSynonyms ty

363+ case ty' of

364+ ConstrainedType constraints _ -> do

365+ env <- getEnv

366+ dicts <- getTypeClassDictionaries

367+ return $ TypedValue True (App (Var var) (map (flip TypeClassDictionary dicts) (qualifyAllUnqualifiedNames moduleName env constraints))) ty'

368+ _ -> return $ TypedValue True (Var var) ty'

369+infer' (Block ss) = do

370+ ret <- fresh

371+ (allCodePathsReturn, _, ss') <- checkBlock M.empty ret ss

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

373+ return $ TypedValue True (Block ss') ret

374+infer' v@(Constructor c) = do

375+ env <- getEnv

376+ moduleName <- substCurrentModule `fmap` ask

377+ case M.lookup (qualify moduleName c) (dataConstructors env) of

378+ Nothing -> throwError $ "Constructor " ++ show c ++ " is undefined"

379+ Just (ty, _) -> do ty' <- replaceAllTypeSynonyms ty

380+ return $ TypedValue True v ty'

381+infer' (Case vals binders) = do

382+ ts <- mapM infer vals

383+ ret <- fresh

384+ binders' <- checkBinders (map (\(TypedValue _ _ t) -> t) ts) ret binders

385+ return $ TypedValue True (Case ts binders') ret

386+infer' (IfThenElse cond th el) = do

387+ cond' <- check cond Boolean

388+ v2@(TypedValue _ _ t2) <- infer th

389+ v3@(TypedValue _ _ t3) <- infer el

390+ t2 ~~ t3

391+ return $ TypedValue True (IfThenElse cond' v2 v3) t2

392+infer' (TypedValue checkType val ty) = do

393+ moduleName <- substCurrentModule <$> ask

394+ kind <- liftCheck $ kindOf moduleName ty

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

396+ ty' <- replaceAllTypeSynonyms ty

397+ val' <- if checkType then check val ty' else return val

398+ return $ TypedValue True val' ty

399+infer' _ = error "Invalid argument to infer"

400+

401+inferProperty :: Type -> String -> Subst (Maybe Type)

402+inferProperty (Object row) prop = do

403+ let (props, _) = rowToList row

404+ return $ lookup prop props

405+inferProperty (SaturatedTypeSynonym name args) prop = do

406+ replaced <- expandTypeSynonym name args

407+ inferProperty replaced prop

408+inferProperty (ForAll ident ty) prop = do

409+ replaced <- replaceVarWithUnknown ident ty

410+ inferProperty replaced prop

411+inferProperty _ _ = return Nothing

412+

413+inferUnary :: UnaryOperator -> Value -> Subst Value

414+inferUnary op (TypedValue _ val valTy) =

415+ case fromMaybe (error "Invalid operator") $ lookup op unaryOps of

416+ (valTy', resTy) -> do

417+ valTy' ~~ valTy

418+ return $ TypedValue True (Unary op val) resTy

419+inferUnary _ _ = error "Invalid arguments to inferUnary"

420+

421+checkUnary :: UnaryOperator -> Value -> Type -> Subst Value

422+checkUnary op val res =

423+ case fromMaybe (error "Invalid operator") $ lookup op unaryOps of

424+ (valTy, resTy) -> do

425+ res ~~ resTy

426+ val' <- check val valTy

427+ return $ Unary op val'

428+

429+unaryOps :: [(UnaryOperator, (Type, Type))]

430+unaryOps = [ (Negate, (Number, Number))

431+ , (Not, (Boolean, Boolean))

432+ , (BitwiseNot, (Number, Number))

433+ ]

434+

435+inferBinary :: BinaryOperator -> Value -> Value -> Subst Value

436+inferBinary op left@(TypedValue _ _ leftTy) right@(TypedValue _ _ rightTy) | isEqualityTest op = do

437+ leftTy ~~ rightTy

438+ return $ TypedValue True (Binary op left right) Boolean

439+inferBinary op left@(TypedValue _ _ leftTy) right@(TypedValue _ _ rightTy) =

440+ case fromMaybe (error "Invalid operator") $ lookup op binaryOps of

441+ (valTy, resTy) -> do

442+ leftTy ~~ valTy

443+ rightTy ~~ valTy

444+ return $ TypedValue True (Binary op left right) resTy

445+inferBinary _ _ _ = error "Invalid arguments to inferBinary"

446+

447+checkBinary :: BinaryOperator -> Value -> Value -> Type -> Subst Value

448+checkBinary op left right res | isEqualityTest op = do

449+ res ~~ Boolean

450+ left'@(TypedValue _ _ t1) <- infer left

451+ right'@(TypedValue _ _ t2) <- infer right

452+ t1 ~~ t2

453+ return $ Binary op left' right'

454+checkBinary op left right res =

455+ case fromMaybe (error "Invalid operator") $ lookup op binaryOps of

456+ (valTy, resTy) -> do

457+ res ~~ resTy

458+ left' <- check left valTy

459+ right' <- check right valTy

460+ return $ Binary op left' right'

461+

462+isEqualityTest :: BinaryOperator -> Bool

463+isEqualityTest EqualTo = True

464+isEqualityTest NotEqualTo = True

465+isEqualityTest _ = False

466+

467+binaryOps :: [(BinaryOperator, (Type, Type))]

468+binaryOps = [ (Add, (Number, Number))

469+ , (Subtract, (Number, Number))

470+ , (Multiply, (Number, Number))

471+ , (Divide, (Number, Number))

472+ , (Modulus, (Number, Number))

473+ , (BitwiseAnd, (Number, Number))

474+ , (BitwiseOr, (Number, Number))

475+ , (BitwiseXor, (Number, Number))

476+ , (ShiftRight, (Number, Number))

477+ , (ZeroFillShiftRight, (Number, Number))

478+ , (And, (Boolean, Boolean))

479+ , (Or, (Boolean, Boolean))

480+ , (Concat, (String, String))

481+ , (Modulus, (Number, Number))

482+ , (LessThan, (Number, Boolean))

483+ , (LessThanOrEqualTo, (Number, Boolean))

484+ , (GreaterThan, (Number, Boolean))

485+ , (GreaterThanOrEqualTo, (Number, Boolean))

486+ ]

487+

488+inferBinder :: Type -> Binder -> Subst (M.Map Ident Type)

489+inferBinder _ NullBinder = return M.empty

490+inferBinder val (StringBinder _) = val ~~ String >> return M.empty

491+inferBinder val (NumberBinder _) = val ~~ Number >> return M.empty

492+inferBinder val (BooleanBinder _) = val ~~ Boolean >> return M.empty

493+inferBinder val (VarBinder name) = return $ M.singleton name val

494+inferBinder val (NullaryBinder ctor) = do

495+ env <- getEnv

496+ moduleName <- substCurrentModule <$> ask

497+ case M.lookup (qualify moduleName ctor) (dataConstructors env) of

498+ Just (ty, _) -> do

499+ ty `subsumes` val

500+ return M.empty

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

502+inferBinder val (UnaryBinder ctor binder) = do

503+ env <- getEnv

504+ moduleName <- substCurrentModule <$> ask

505+ case M.lookup (qualify moduleName ctor) (dataConstructors env) of

506+ Just (ty, _) -> do

507+ fn <- replaceAllVarsWithUnknowns ty

508+ case fn of

509+ Function [obj] ret -> do

510+ val `subsumes` ret

511+ inferBinder obj binder

512+ _ -> throwError $ "Constructor " ++ show ctor ++ " is not a unary constructor"

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

514+inferBinder val (ObjectBinder props) = do

515+ row <- fresh

516+ rest <- fresh

517+ m1 <- inferRowProperties row rest props

518+ val ~~ Object row

519+ return m1

520+ where

521+ inferRowProperties :: Type -> Type -> [(String, Binder)] -> Subst (M.Map Ident Type)

522+ inferRowProperties nrow row [] = nrow ~~ row >> return M.empty

523+ inferRowProperties nrow row ((name, binder):binders) = do

524+ propTy <- fresh

525+ m1 <- inferBinder propTy binder

526+ m2 <- inferRowProperties nrow (RCons name propTy row) binders

527+ return $ m1 `M.union` m2

528+inferBinder val (ArrayBinder binders) = do

529+ el <- fresh

530+ m1 <- M.unions <$> mapM (inferBinder el) binders

531+ val ~~ Array el

532+ return m1

533+inferBinder val (ConsBinder headBinder tailBinder) = do

534+ el <- fresh

535+ m1 <- inferBinder el headBinder

536+ m2 <- inferBinder val tailBinder

537+ val ~~ Array el

538+ return $ m1 `M.union` m2

539+inferBinder val (NamedBinder name binder) = do

540+ m <- inferBinder val binder

541+ return $ M.insert name val m

542+

543+checkBinders :: [Type] -> Type -> [([Binder], Maybe Guard, Value)] -> Subst [([Binder], Maybe Guard, Value)]

544+checkBinders _ _ [] = return []

545+checkBinders nvals ret ((binders, grd, val):bs) = do

546+ moduleName <- substCurrentModule <$> ask

547+ m1 <- M.unions <$> zipWithM inferBinder nvals binders

548+ r <- bindLocalVariables moduleName (M.toList m1) $ do

549+ val' <- check val ret

550+ case grd of

551+ Nothing -> return (binders, Nothing, val')

552+ Just g -> do

553+ g' <- check g Boolean

554+ return (binders, Just g', val')

555+ rs <- checkBinders nvals ret bs

556+ return $ r : rs

557+

558+assignVariable :: Ident -> Subst ()

559+assignVariable name = do

560+ env <- checkEnv <$> get

561+ moduleName <- substCurrentModule <$> ask

562+ case M.lookup (moduleName, name) (names env) of

563+ Just (_, LocalVariable) -> throwError $ "Variable with name " ++ show name ++ " already exists."

564+ _ -> return ()

565+

566+checkStatement :: M.Map Ident Type -> Type -> Statement -> Subst (Bool, M.Map Ident Type, Statement)

567+checkStatement mass _ (VariableIntroduction name val) = do

568+ assignVariable name

569+ val'@(TypedValue _ _ t) <- infer val

570+ return (False, M.insert name t mass, VariableIntroduction name val')

571+checkStatement mass _ (Assignment ident val) = do

572+ val'@(TypedValue _ _ t) <- infer val

573+ case M.lookup ident mass of

574+ Nothing -> throwError $ "No local variable with name " ++ show ident

575+ Just ty -> do t ~~ ty

576+ return (False, mass, Assignment ident val')

577+checkStatement mass ret (While val inner) = do

578+ val' <- check val Boolean

579+ (allCodePathsReturn, _, inner') <- checkBlock mass ret inner

580+ return (allCodePathsReturn, mass, While val' inner')

581+checkStatement mass ret (If ifst) = do

582+ (allCodePathsReturn, ifst') <- checkIfStatement mass ret ifst

583+ return (allCodePathsReturn, mass, If ifst')

584+checkStatement mass ret (For ident start end inner) = do

585+ moduleName <- substCurrentModule <$> ask

586+ assignVariable ident

587+ start' <- check start Number

588+ end' <- check end Number

589+ (allCodePathsReturn, _, inner') <- bindLocalVariables moduleName [(ident, Number)] $ checkBlock mass ret inner

590+ return (allCodePathsReturn, mass, For ident start' end' inner')

591+checkStatement mass ret (Return val) = do

592+ val' <- check val ret

593+ return (True, mass, Return val')

594+

595+checkIfStatement :: M.Map Ident Type -> Type -> IfStatement -> Subst (Bool, IfStatement)

596+checkIfStatement mass ret (IfStatement val thens Nothing) = do

597+ val' <- check val Boolean

598+ (_, _, thens') <- checkBlock mass ret thens

599+ return (False, IfStatement val' thens' Nothing)

600+checkIfStatement mass ret (IfStatement val thens (Just elses)) = do

601+ val' <- check val Boolean

602+ (allCodePathsReturn1, _, thens') <- checkBlock mass ret thens

603+ (allCodePathsReturn2, elses') <- checkElseStatement mass ret elses

604+ return (allCodePathsReturn1 && allCodePathsReturn2, IfStatement val' thens' (Just elses'))

605+

606+checkElseStatement :: M.Map Ident Type -> Type -> ElseStatement -> Subst (Bool, ElseStatement)

607+checkElseStatement mass ret (Else elses) = do

608+ (allCodePathsReturn, _, elses') <- checkBlock mass ret elses

609+ return (allCodePathsReturn, Else elses')

610+checkElseStatement mass ret (ElseIf ifst) = (id *** ElseIf) <$> checkIfStatement mass ret ifst

611+

612+checkBlock :: M.Map Ident Type -> Type -> [Statement] -> Subst (Bool, M.Map Ident Type, [Statement])

613+checkBlock mass _ [] = return (False, mass, [])

614+checkBlock mass ret (s:ss) = do

615+ moduleName <- substCurrentModule <$> ask

616+ (b1, mass1, s') <- checkStatement mass ret s

617+ bindLocalVariables moduleName (M.toList mass1) $ case (b1, ss) of

618+ (True, []) -> return (True, mass1, [s'])

619+ (True, _) -> throwError "Unreachable code"

620+ (False, ss') -> do

621+ (b, m, ss'') <- checkBlock mass1 ret ss'

622+ return (b, m, s':ss'')

623+

624+skolemize :: String -> Type -> Subst Type

625+skolemize ident ty = do

626+ tsk <- Skolem <$> fresh'

627+ return $ replaceTypeVars ident tsk ty

628+

629+check :: Value -> Type -> Subst Value

630+check val ty = rethrow errorMessage $ check' val ty

631+ where

632+ errorMessage msg =

633+ "Error checking type of term " ++

634+ prettyPrintValue val ++

635+ " against type " ++

636+ prettyPrintType ty ++

637+ ":\n" ++

638+ msg

639+

640+check' :: Value -> Type -> Subst Value

641+check' val (ForAll idents ty) = do

642+ sk <- skolemize idents ty

643+ check val sk

644+check' val (ConstrainedType constraints ty) = do

645+ env <- getEnv

646+ moduleName <- substCurrentModule <$> ask

647+ dictNames <- flip mapM constraints $ \(Qualified _ (ProperName className), _) -> do

648+ n <- liftCheck freshDictionaryName

649+ return $ Ident $ "__dict_" ++ className ++ "_" ++ show n

650+ val' <- withTypeClassDictionaries (zipWith (\name (className, instanceTy) -> TypeClassDictionaryInScope name className instanceTy Nothing) dictNames (qualifyAllUnqualifiedNames moduleName env constraints)) $ check val ty

651+ return $ Abs dictNames val'

652+check' val u@(TUnknown _) = do

653+ val'@(TypedValue _ _ ty) <- infer val

654+ -- Don't unify an unknown with an inferred polytype

655+ ty' <- replaceAllVarsWithUnknowns ty

656+ ty' ~~ u

657+ return val'

658+check' v@(NumericLiteral _) Number = return v

659+check' v@(StringLiteral _) String = return v

660+check' v@(BooleanLiteral _) Boolean = return v

661+check' (Unary op val) ty = checkUnary op val ty

662+check' (Binary op left right) ty = checkBinary op left right ty

663+check' (ArrayLiteral vals) (Array ty) = ArrayLiteral <$> forM vals (\val -> check val ty)

664+check' (Indexer index vals) ty = do

665+ index' <- check index Number

666+ vals' <- check vals (Array ty)

667+ return $ Indexer index' vals'

668+check' (Abs args ret) (Function argTys retTy) = do

669+ moduleName <- substCurrentModule <$> ask

670+ guardWith "Incorrect number of function arguments" (length args == length argTys)

671+ ret' <- bindLocalVariables moduleName (zip args argTys) $ check ret retTy

672+ return $ Abs args ret'

673+check' (App f args) ret = do

674+ f'@(TypedValue _ _ ft) <- infer f

675+ app <- checkFunctionApplication f' ft args ret

676+ return $ app

677+check' (Var var) ty = do

678+ moduleName <- substCurrentModule <$> ask

679+ ty1 <- lookupVariable moduleName var

680+ repl <- replaceAllTypeSynonyms ty1

681+ repl `subsumes` ty

682+ return $ Var var

683+check' (TypedValue checkType val ty1) ty2 = do

684+ moduleName <- substCurrentModule <$> ask

685+ kind <- liftCheck $ kindOf moduleName ty1

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

687+ ty1 `subsumes` ty2

688+ val' <- if checkType then check val ty1 else return val

689+ return $ TypedValue True val' ty1

690+check' (Case vals binders) ret = do

691+ vals' <- mapM infer vals

692+ let ts = map (\(TypedValue _ _ t) -> t) vals'

693+ binders' <- checkBinders ts ret binders

694+ return $ Case vals' binders'

695+check' (IfThenElse cond th el) ty = do

696+ cond' <- check cond Boolean

697+ th' <- check th ty

698+ el' <- check el ty

699+ return $ IfThenElse cond' th' el'

700+check' (ObjectLiteral ps) (Object row) = do

701+ ensureNoDuplicateProperties ps

702+ ps' <- checkProperties ps row False

703+ return $ ObjectLiteral ps'

704+check' (ObjectUpdate obj ps) (Object row) = do

705+ ensureNoDuplicateProperties ps

706+ us <- zip (map fst ps) <$> replicateM (length ps) fresh

707+ let (propsToCheck, rest) = rowToList row

708+ propsToRemove = map fst ps

709+ remainingProps = filter (\(p, _) -> p `notElem` propsToRemove) propsToCheck

710+ obj' <- check obj (Object (rowFromList (us ++ remainingProps, rest)))

711+ ps' <- checkProperties ps row True

712+ return $ ObjectUpdate obj' ps'

713+check' (Accessor prop val) ty = do

714+ rest <- fresh

715+ val' <- check val (Object (RCons prop ty rest))

716+ return $ Accessor prop val'

717+check' (Block ss) ret = do

718+ (allCodePathsReturn, _, ss') <- checkBlock M.empty ret ss

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

720+ return $ Block ss'

721+check' (Constructor c) ty = do

722+ env <- getEnv

723+ moduleName <- substCurrentModule <$> ask

724+ case M.lookup (qualify moduleName c) (dataConstructors env) of

725+ Nothing -> throwError $ "Constructor " ++ show c ++ " is undefined"

726+ Just (ty1, _) -> do

727+ repl <- replaceAllTypeSynonyms ty1

728+ repl `subsumes` ty

729+ return $ Constructor c

730+check' val (SaturatedTypeSynonym name args) = do

731+ ty <- expandTypeSynonym name args

732+ check val ty

733+check' val ty = throwError $ prettyPrintValue val ++ " does not have type " ++ prettyPrintType ty

734+

735+checkProperties :: [(String, Value)] -> Type -> Bool -> Subst [(String, Value)]

736+checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where

737+ go [] [] REmpty = return []

738+ go [] [] u@(TUnknown _) = do u ~~ REmpty

739+ return []

740+ go [] [] (Skolem _) | lax = return []

741+ go [] ((p, _): _) _ | lax = return []

742+ | otherwise = throwError $ prettyPrintValue (ObjectLiteral ps) ++ " does not have property " ++ p

743+ go ((p,_):_) [] REmpty = throwError $ "Property " ++ p ++ " is not present in closed object type " ++ prettyPrintRow row

744+ go ((p,v):ps') [] u@(TUnknown _) = do

745+ v'@(TypedValue _ _ ty) <- infer v

746+ rest <- fresh

747+ u ~~ RCons p ty rest

748+ ps'' <- go ps' [] rest

749+ return $ (p, v') : ps''

750+ go ((p,v):ps') ts r =

751+ case lookup p ts of

752+ Nothing -> do

753+ v'@(TypedValue _ _ ty) <- infer v

754+ rest <- fresh

755+ r ~~ RCons p ty rest

756+ ps'' <- go ps' ts rest

757+ return $ (p, v') : ps''

758+ Just ty -> do

759+ v' <- check v ty

760+ ps'' <- go ps' (delete (p, ty) ts) r

761+ return $ (p, v') : ps''

762+ go _ _ _ = throwError $ prettyPrintValue (ObjectLiteral ps) ++ " does not have type " ++ prettyPrintType (Object row)

763+

764+checkFunctionApplication :: Value -> Type -> [Value] -> Type -> Subst Value

765+checkFunctionApplication fn fnTy args ret = rethrow errorMessage $ checkFunctionApplication' fn fnTy args ret

766+ where

767+ errorMessage msg = "Error applying function of type "

768+ ++ prettyPrintType fnTy

769+ ++ " to arguments " ++ intercalate ", " (map prettyPrintValue args)

770+ ++ ":\n" ++ msg

771+

772+checkFunctionApplication' :: Value -> Type -> [Value] -> Type -> Subst Value

773+checkFunctionApplication' fn (Function argTys retTy) args ret = do

774+ guardWith "Incorrect number of function arguments" (length args == length argTys)

775+ args' <- zipWithM check args argTys

776+ retTy `subsumes` ret

777+ return $ App fn args'

778+checkFunctionApplication' fn (ForAll ident ty) args ret = do

779+ replaced <- replaceVarWithUnknown ident ty

780+ checkFunctionApplication fn replaced args ret

781+checkFunctionApplication' fn u@(TUnknown _) args ret = do

782+ args' <- mapM (\arg -> infer arg >>= \(TypedValue _ v t) -> TypedValue True v <$> replaceAllVarsWithUnknowns t) args

783+ let tys = map (\(TypedValue _ _ t) -> t) args'

784+ u ~~ Function tys ret

785+ return $ App fn args'

786+checkFunctionApplication' fn (SaturatedTypeSynonym name tyArgs) args ret = do

787+ ty <- expandTypeSynonym name tyArgs

788+ checkFunctionApplication fn ty args ret

789+checkFunctionApplication' fn (ConstrainedType constraints fnTy) args ret = do

790+ env <- getEnv

791+ dicts <- getTypeClassDictionaries

792+ moduleName <- substCurrentModule <$> ask

793+ checkFunctionApplication' (App fn (map (flip TypeClassDictionary dicts) (qualifyAllUnqualifiedNames moduleName env constraints))) fnTy args ret

794+checkFunctionApplication' _ fnTy args ret = throwError $ "Applying a function of type "

795+ ++ prettyPrintType fnTy

796+ ++ " to argument(s) " ++ intercalate ", " (map prettyPrintValue args)

797+ ++ " does not yield a value of type " ++ prettyPrintType ret ++ "."

798+

799+subsumes :: Type -> Type -> Subst ()

800+subsumes (ForAll ident ty1) ty2 = do

801+ replaced <- replaceVarWithUnknown ident ty1

802+ replaced `subsumes` ty2

803+subsumes (Function args1 ret1) (Function args2 ret2) = do

804+ zipWithM_ subsumes args2 args1

805+ ret1 `subsumes` ret2

806+subsumes ty1 ty2 = ty1 ~~ ty2

807+

src/Language/PureScript/Types.hsnew file+77

@@ -0,0 +1,77 @@

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 Data.Generics (mkT, mkQ, everywhereBut)

21+

22+import Language.PureScript.Names

23+import Language.PureScript.Unknown (Unknown(..))

24+

25+data Type

26+ = TUnknown (Unknown Type)

27+ | Number

28+ | String

29+ | Boolean

30+ | Array Type

31+ | Object Type

32+ | Function [Type] Type

33+ | TypeVar String

34+ | TypeConstructor (Qualified ProperName)

35+ | TypeApp Type Type

36+ | SaturatedTypeSynonym (Qualified ProperName) [Type]

37+ | ForAll String Type

38+ | ConstrainedType [(Qualified ProperName, Type)] Type

39+ | Skolem Int

40+ | REmpty

41+ | RCons String Type Type deriving (Show, Eq, Data, Typeable)

42+

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

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

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

46+rowToList r = ([], r)

47+

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

49+rowFromList ([], r) = r

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

51+

52+isMonoType :: Type -> Bool

53+isMonoType (ForAll _ _) = False

54+isMonoType ty = isPolyType ty

55+

56+isPolyType :: Type -> Bool

57+isPolyType (Array ty) = isMonoType ty

58+isPolyType (Object ps) = all isPolyType (map snd . fst $ rowToList ps)

59+isPolyType (Function args ret) = all isPolyType args && isPolyType ret

60+isPolyType (TypeApp t1 t2) = isMonoType t1 && isMonoType t2

61+isPolyType (SaturatedTypeSynonym _ args) = all isPolyType args

62+isPolyType (ForAll _ ty) = isPolyType ty

63+isPolyType _ = True

64+

65+mkForAll :: [String] -> Type -> Type

66+mkForAll = flip . foldl . flip $ ForAll

67+

68+unit :: Type

69+unit = Object REmpty

70+

71+replaceTypeVars :: (Data d) => String -> Type -> d -> d

72+replaceTypeVars name t = everywhereBut (mkQ False isShadowed) (mkT replaceTypeVar)

73+ where

74+ replaceTypeVar (TypeVar v) | v == name = t

75+ replaceTypeVar other = other

76+ isShadowed (ForAll v _) | v == name = True

77+ isShadowed _ = False

src/Language/PureScript/Unknown.hsnew file+24

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

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+

21+newtype Unknown t = Unknown { runUnknown :: Int } deriving (Show, Eq, Ord, Data, Typeable)

22+

23+

24+

src/Language/PureScript/Values.hsnew file+115

@@ -0,0 +1,115 @@

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+type Guard = Value

25+

26+data UnaryOperator

27+ = Negate

28+ | Not

29+ | BitwiseNot

30+ | Positive deriving (Show, Eq, Data, Typeable)

31+

32+data BinaryOperator

33+ = Add

34+ | Subtract

35+ | Multiply

36+ | Divide

37+ | Modulus

38+ | EqualTo

39+ | NotEqualTo

40+ | LessThan

41+ | LessThanOrEqualTo

42+ | GreaterThan

43+ | GreaterThanOrEqualTo

44+ | And

45+ | Or

46+ | BitwiseAnd

47+ | BitwiseOr

48+ | BitwiseXor

49+ | ShiftLeft

50+ | ShiftRight

51+ | ZeroFillShiftRight

52+ | Concat deriving (Show, Eq, Data, Typeable)

53+

54+data Value

55+ = NumericLiteral (Either Integer Double)

56+ | StringLiteral String

57+ | BooleanLiteral Bool

58+ | Unary UnaryOperator Value

59+ | Binary BinaryOperator Value Value

60+ | BinaryNoParens (Qualified Ident) Value Value

61+ | Parens Value

62+ | ArrayLiteral [Value]

63+ | Indexer Value Value

64+ | ObjectLiteral [(String, Value)]

65+ | Accessor String Value

66+ | ObjectUpdate Value [(String, Value)]

67+ | Abs [Ident] Value

68+ | App Value [Value]

69+ | Var (Qualified Ident)

70+ | IfThenElse Value Value Value

71+ | Block [Statement]

72+ | Constructor (Qualified ProperName)

73+ | Case [Value] [([Binder], Maybe Guard, Value)]

74+ | TypedValue Bool Value Type

75+ | Do [DoNotationElement]

76+ | TypeClassDictionary (Qualified ProperName, Type) [TypeClassDictionaryInScope] deriving (Show, Data, Typeable)

77+

78+data TypeClassDictionaryInScope

79+ = TypeClassDictionaryInScope { tcdName :: Ident

80+ , tcdClassName :: Qualified ProperName

81+ , tcdInstanceType :: Type

82+ , tcdDependencies :: Maybe [(Qualified ProperName, Type)]

83+ } deriving (Show, Data, Typeable)

84+

85+data DoNotationElement

86+ = DoNotationValue Value

87+ | DoNotationBind Binder Value

88+ | DoNotationLet Binder Value deriving (Show, Data, Typeable)

89+

90+data Statement

91+ = VariableIntroduction Ident Value

92+ | Assignment Ident Value

93+ | While Value [Statement]

94+ | For Ident Value Value [Statement]

95+ | If IfStatement

96+ | Return Value deriving (Show, Data, Typeable)

97+

98+data IfStatement = IfStatement Value [Statement] (Maybe ElseStatement) deriving (Show, Data, Typeable)

99+

100+data ElseStatement

101+ = Else [Statement]

102+ | ElseIf IfStatement deriving (Show, Data, Typeable)

103+

104+data Binder

105+ = NullBinder

106+ | BooleanBinder Bool

107+ | StringBinder String

108+ | NumberBinder (Either Integer Double)

109+ | VarBinder Ident

110+ | NullaryBinder (Qualified ProperName)

111+ | UnaryBinder (Qualified ProperName) Binder

112+ | ObjectBinder [(String, Binder)]

113+ | ArrayBinder [Binder]

114+ | ConsBinder Binder Binder

115+ | NamedBinder Ident Binder deriving (Show, Data, Typeable)

src/Tests.hsdeleted−141

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

1−module Tests (runTests) where

2−

3−import Prelude.Compat

4−import Data.List

5−import Control.Applicative

6−import Control.Monad

7−

8−import System.Process

9−import System.FilePath

10−import System.IO

11−import System.Directory

12−

13−-------------------------------------------------------------------------------

14−testsDir :: IO (FilePath, FilePath)

15−-------------------------------------------------------------------------------

16−testsDir = do

17− baseDir <- getCurrentDirectory

18− return (baseDir </> "purescript-tests", baseDir)

19−

20−-------------------------------------------------------------------------------

21−runTests :: IO ()

22−-------------------------------------------------------------------------------

23−runTests = do

24−

25− (outputDir, baseDir) <- testsDir

26−

27− outputDirExists <- doesDirectoryExist outputDir

28− when outputDirExists $ removeDirectoryRecursive outputDir

29− createDirectory outputDir

30−

31− let srcDir = outputDir </> "src"

32− createDirectory srcDir

33−

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

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

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

37−

38− setCurrentDirectory outputDir

39−

40− fetchPackages

41−

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

43−

44− tmp <- getTemporaryDirectory

45− createDirectoryIfMissing False (tmp </> logpath)

46− outputFile <- openFile (tmp </> logpath </> logfile) WriteMode

47− hClose outputFile

48−

49− -- Run the tests

50− --

51− forM_ tests $ \inputFile -> do

52− --

53− -- Compile/build

54− --

55− putStrLn $ "Compiling test " ++ inputFile ++ " ..."

56− setCurrentDirectory outputDir

57− copyFile (passingDir </> inputFile) (srcDir </> inputFile)

58−

59− let testCaseDir = passingDir </> (takeWhile (/='.') inputFile)

60− testCaseDirExists <- doesDirectoryExist testCaseDir

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

62−

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

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

65− callProcess "spago" ["build"]

66− --

67− -- Run executable file

68− --

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

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

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

72−

73− removeFile (srcDir </> inputFile)

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

75−

76− -- TODO: support failing test cases

77− --

78− -- let failing = baseDir </> "examples" </> "failing"

79− -- failingTestCases <- sort . filter (".purs" `isSuffixOf`) <$> getDirectoryContents failing

80− --

81−

82− setCurrentDirectory baseDir

83− putStrLn "PureScript tests finished"

84− putStrLn $ "Total tests available: " ++ show (length passingTestCases)

85− putStrLn $ "Tests run: " ++ show (length tests)

86− putStrLn $ "Tests skipped: " ++ show (length skipped)

87−

88−-------------------------------------------------------------------------------

89−packages :: [String]

90−-------------------------------------------------------------------------------

91−packages =

92− [ "arrays"

93− , "assert"

94− , "console"

95− , "control"

96− , "effect"

97− , "foldable-traversable"

98− , "functions"

99− , "generics-rep"

100− , "invariant"

101− , "newtype"

102− , "partial"

103− , "prelude"

104− , "proxy"

105− , "refs"

106− , "st"

107− , "type-equality"

108− , "typelevel-prelude"

109− ]

110−

111−-------------------------------------------------------------------------------

112−fetchPackages :: IO ()

113−-------------------------------------------------------------------------------

114−fetchPackages = do

115− callProcess "spago" ["init"]

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

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

118−

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

120− return ()

121−

122−-------------------------------------------------------------------------------

123−skipped :: [String]

124−-------------------------------------------------------------------------------

125−skipped =

126− [ "2172.purs" -- foreign in Main needed (test manually)

127− , "EffFn.purs" -- foreign in Main needed (test manually)

128− , "FunWithFunDeps.purs" -- foreign in Main needed (test manually)

129− , "NumberLiterals.purs" -- unreliable float string comparison (test manually)

130− , "PolyLabels.purs" -- foreign in Main needed (test manually)

131− , "RowUnion.purs" -- foreign in Main needed (test manually)

132− , "ShadowedModuleName.purs" -- ?

133− , "StringEdgeCases.purs" -- javascript char encoding specific

134− , "StringEscapes.purs" -- Partially javascript-char-encoding-specific (test manually)

135− ]

136−

137−logpath :: FilePath

138−logpath = "purescript-output"

139−

140−logfile :: FilePath

141−logfile = "purescript-tests.out"

stack.nixdeleted−23

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

1−#

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

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

4−#

5−#

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

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

8−#

9−#

10−{ pkgs ?

11− import (builtins.fetchTarball {

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

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

14− sha256 = "11z6ajj108fy2q5g8y4higlcaqncrbjm3dnv17pvif6avagw4mcb";

15− }) {}

16−}:

17−

18−pkgs.haskell.lib.buildStackProject {

19− name = "default-stack-shell";

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

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

22− LANG = "en_US.UTF-8";

23−}

stack.yamldeleted−24

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

1−resolver: lts-13.26

2−

3−packages:

4−- .

5−

6−extra-deps:

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

8− commit: 9cad73ed8ea7df3011032ddbd2f3de5a0c08629c

9−- happy-1.19.9

10−- language-javascript-0.7.0.0

11−- network-3.0.1.1

12−- these-1.0.1

13−- semialign-1

14−

15−nix:

16− enable: false

17− shell-file: stack.nix

18−

19−flags:

20− aeson-pretty:

21− lib-only: true

22− these:

23− assoc: false

24− quickcheck: false

support/ffi-loader.godeleted−30

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

1−package ffi_loader

2−

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

4−// faster/smaller builds.

5−

6−import (

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

26−)

27−

28−// Add your own FFI packages here.

29−

30−import ()

support/go.mod.ffi-loaderdeleted−2

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

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

2−

support/go.mod.outputdeleted−2

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

1−module $PROJECT/purescript-native/output

2−

support/go.mod.workingdeleted−1

@@ -1 +0,0 @@

1−module $PROJECT/example

test/Spec.hsdeleted−2

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

1−main :: IO ()

2−main = putStrLn "Test suite not yet implemented"

tests/Main.hsnew file+71

@@ -0,0 +1,71 @@

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

2+--

3+-- Module : Main

4+-- Copyright : (c) Phil Freeman 2013

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+--

13+-----------------------------------------------------------------------------

14+

15+module Main (main) where

16+

17+import 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+ modules <- P.runIndentParser P.parseModules <$> U.readFile inputFile

31+ case modules of

32+ Left parseError -> do

33+ return (Left $ show parseError)

34+ Right ms -> do

35+ case P.compile P.defaultOptions ms 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