git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
swap
355eb9b3778 ahead, 0 behind
.gitignore+15
since splitsnapshots
unifiedsplit
@@ -1,8 +1,23 @@
1dist
1dist
2cabal-dev
2cabal-dev
3+.cabal-sandbox
4+cabal.sandbox.config
3*.o
5*.o
4*.hi
6*.hi
5*.chi
7*.chi
6*.chs.h
8*.chs.h
7*.lksh*
9*.lksh*
8.virthualenv
10.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.ymldeleted−3
@@ -1,3 +0,0 @@
1−language: haskell
2−notifications:
3− email: false
CONTRIBUTING.mddeleted−14
@@ -1,14 +0,0 @@
1−Pull requests are encouraged.
2−
3−Please follow the following guidelines:
4−
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`.
9−
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.mdnew file+3
@@ -0,0 +1,3 @@
1+# Changelog for pscpp
2+
3+## Unreleased changes
LICENSE+26−16
@@ -1,20 +1,30 @@
1−The MIT License (MIT)
1+Copyright Andy Arvanitis (c) 2018
2
2
3−Copyright (c) 2013 Phil Freeman
3+All rights reserved.
4
4
5−Permission is hereby granted, free of charge, to any person obtaining a copy of
5+Redistribution and use in source and binary forms, with or without
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:
6+modification, are permitted provided that the following conditions are met:
11
7
12−The above copyright notice and this permission notice shall be included in all
8+ * Redistributions of source code must retain the above copyright
13−copies or substantial portions of the Software.
9+ notice, this list of conditions and the following disclaimer.
14
10
15−THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
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
16−IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
22+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
17−FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
23+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
18−COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
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
19−IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
29+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
20−CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
30+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
README-go.mdnew file+48
@@ -0,0 +1,48 @@
1+
2+### psgo
3+
4+#### Performance
5+
6+* No runtime system beyond some support types and functions
7+* Uses PureScript's normal tail call optimization techniques for generated Go code
8+
9+#### Differences from PureScript:
10+
11+* Foreign imports/exports are Go instead of JavaScript – see [standard library foreign implementations](https://github.com/andyarvanitis/purescript-native-go-ffi)
12+* No Go-specific REPL
13+
14+#### Other notes:
15+
16+* The provided `Any` type is just an alias for `interface{}`
17+* PureScript types are represented in Go with:
18+
19+ | PureScript | Go |
20+ |------------|----|
21+ |`Array` | `[]Any`|
22+ |`String` | `string`|
23+ |`Number` | `float64`|
24+ |`Int` | `int`|
25+ |`Char` | `string` (single UTF-8 entity)|
26+ |`Boolean` | `bool`|
27+ |Records | `map[string]Any`|
28+
29+#### Future ideas:
30+
31+* Nice facilities (modules) for concurrency/parallelism, using goroutines
32+
33+
34+#### Getting Started
35+This assumes you are running macOS (OS X) or a Unix-like system (Linux, *BSD, etc.).
36+
37+1. Choose a working directory wherever you like. Then create a `src` subdirectory under it, which will be where you will place your own PureScript source files.
38+
39+1. Initialize your project with `spago init`, and install any dependencies with `spago install` (please see their instructions if you haven't used it before).
40+
41+1. Add the `backend = "psgo"` option to your `spago.dhall` file. That way `spago` will use the psgo backend when compiling.
42+
43+1. You should now be ready to build a PureScript program:
44+ * As stated above, place your source file(s) in the working directory's `src` subdirectory and execute `spago build`.
45+
46+ * This will generate the Go source tree for your program and then build an executable binary. The resulting executable will be in your working directory and will be named `Main`. The generated source files will be under `output/`.
47+
48+---
README.md+28−868
@@ -1,881 +1,41 @@
1−purescript
1+[![PureScript](https://raw.githubusercontent.com/purescript/purescript/master/logo.png)](http://purescript.org)
2−==========
3
2
4−[![Build Status](https://secure.travis-ci.org/paf31/purescript.png?branch=master)](http://travis-ci.org/paf31/purescript)
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.
5
4
6−A small strongly, statically typed compile-to-JS language with basic extensible records and type-safe blocks
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).
7
6
8−Bitcoin donations are gratefully accepted at 14ZhCym28WDuFhocP44tU1dBpCzjX1DvhF.
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`
9
20
10−## Current Features
11
21
12−- Full Type Inference
22+#### Requirements for building `pscpp` and `psgo`
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
25
23
26−## Try It!
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/))
27
25
28−Try PureScript in the browser [here](http://tryps.functorial.com/).
26+#### Requirements for using PureScript + purescript-native
29
27
30−## License
28+* A recent version (0.13+) of [purescript](https://github.com/purescript/purescript/releases).
31
29
32−See the `LICENSE` file
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.
33
34
34−## Contributing
35
35
36−Contributions are always encouraged! Please see `CONTRIBUTING.md` for guidelines.
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)
37
39
38−- Join the discussion on FreeNode at <a href="irc://irc.freenode.net/#purescript">#purescript</a>.
39−- Follow @purescript on Twitter for development updates
40
40
41−## Installation
41+---
42−
43−Install the Haskell Plaform, then `cabal install`
44−
45−## Usage
46−
47−The `psc` executable takes a list of PureScript source files as arguments and by default writes out its errors or output to the console.
48−
49−The following options are supported:
50−
51− -s --stdin
52− Read input from standard input instead of from files
53−
54− -o --output
55− Write the generated Javascript to the specified file
56−
57− -e --foreign imports
58− Write a list of foreign imports declarations to the specified file in addition to generating Javascript output
59−
60− --runtime-type-checks
61− Generate simple runtime type checks for function arguments with simple types.
62−
63− --tco
64− Perform tail-call elimination on the generated Javascript.
65−
66− --no-prelude
67− Do not include the Prelude in the generated Javascript.
68−
69− --magic-do
70− Overload the `do` keyword to inline calls to `bind` for the `Eff` monad, to generate more efficient code.
71−
72− --run-main
73− Generate a call to `Main.main` after all other generated Javascript.
74−
75−## Motivation
76−
77−I was looking for a simple functional language which would compile to JavaScript and have the following characteristics:
78−
79−- Generate simple readable Javascript
80−- Provide the ability to compile to tight loops if necessary
81−- Reasonable type system
82−- Ideally, written in a programming language I would enjoy working in
83−- Provides a simple interface to existing Javascript code
84−
85−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.
86−
87−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.
88−
89−PureScript can also be seen as a trade-off between a theoretically ideal language and one which generates reasonably high performance code.
90−
91−## Hello, PureScript!
92−
93−As an introductory example, here is the usual "Hello World" written in PureScript:
94−
95−```haskell
96−module Main where
97−
98−import Trace
99−
100−main = trace "Hello, World!"
101−```
102−
103−which compiles to the following Javascript, ignoring the Prelude:
104−
105−```javascript
106−var Main;
107−(function (Main) {
108− var main = trace("Hello, World!");
109− Main.main = main;
110−})(Main = Main || {});
111−```
112−
113−The following command will compile and execute the PureScript code above:
114−
115−```
116−psc input.purs --run-main | nodejs
117−```
118−
119−## Another Example
120−
121−The following code defines a `Person` data type and a function to generate a string representation for a `Person`:
122−
123−```haskell
124−data Person = Person { name :: String, age :: Number }
125−
126−foreign import numberToString :: Number -> String
127−
128−showPerson :: Person -> String
129−showPerson (Person o) = o.name ++ ", aged " ++ numberToString(o.age)
130−```
131−
132−Line by line, this reads as follows:
133−
134−- `Person` is a data type with one constructor, also called `Person`
135− - The `Person` constructor takes an object with two properties, `name` which is a `String`, and `age` which is a `Number`
136−- The `numberToString` function is written in Javascript, and converts a `Number` to its `String` representation
137−- The `showPerson` function takes a `Person` and returns a `String`
138−- `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.
139−
140−The generated Javascript looks like this:
141−
142−```javascript
143−var Person = function (value) {
144− return { ctor: 'Person', value: value };
145−};
146−
147−function showPerson(_1) {
148− if (_1.ctor === "Person") {
149− return _1.value.name + ", aged " + numberToString(_1.value.age);
150− };
151− throw "Failed pattern match";
152−};
153−
154−```
155−
156−## Type System
157−
158−The type system defines the following types:
159−
160−- Primitive Types
161− - Number
162− - String
163− - Boolean
164−- Arrays
165− - E.g. `[String]`, `[[Number]]`
166−- Records
167− - E.g. `{ foo :: String, bar :: Number }`
168−- Tagged Unions
169− - E.g. `data Foo a = Foo | Bar String`
170−- Functions
171− - E.g. `Number -> String`
172− - E.g. `(Number, Number) -> Number`
173− - Functions can have zero or more arguments
174−- Polymorphic types
175− - E.g. `forall a. a -> a`
176−
177−## Primitive Types
178−
179−The three primitive types `String`, `Number` and `Boolean` correspond to their Javascript equivalents at runtime.
180−
181−PureScript supports the same binary and unary operations on primitive types as Javascript, with the following exceptions:
182−
183−- String concatenation is denoted `++` to differentiate it from numeric addition, `+`
184−- PureScript's `==` and `!=` correspond to Javascript's strong equality tests `===` and `!==`
185−
186−Examples:
187−
188−```haskell
189−num = 1 + 2 * 3
190−str = "Hello, " ++ "World!"
191−bool = 1 > 2 || true
192−```
193−
194−## Arrays
195−
196−PureScript arrays correspond to Javascript arrays at runtime, but all elements must have the same type.
197−
198−Array literals look like Javascript array literals: `[1, 2, 3]`
199−
200−Array elements can be read using array index notation `arr !! index`
201−
202−## Records
203−
204−PureScript records correspond to Javascript objects.
205−
206−Record literals look like Javascript object literals: `{ foo: "Foo" }`
207−
208−Properties can be read by using dot notation: `o.foo`
209−
210−## Tagged Unions
211−
212−Tagged unions consist of one or more constructors, each of which takes zero or one arguments.
213−
214−Tagged unions can only be created using their constructors, and deconstructed through pattern matching (see later).
215−
216−For example:
217−
218−```haskell
219−data Foo a = Foo | Bar String
220−
221−runFoo Foo = "It's a Foo"
222−runFoo (Bar s) = "It's a Bar. The string is " ++ s
223−
224−test = runFoo Foo ++ runFoo (Bar "Test")
225−```
226−
227−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.
228−
229−`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.
230−
231−## Functions
232−
233−Functions in PureScript can have zero or more arguments in general, just like in Javascript.
234−
235−Functions are introduced by using a backslash followed by a list of argument names:
236−
237−```haskell
238−test1 = \a b -> a + b
239−```
240−
241−which would correspond to the Javascript
242−
243−```javascript
244−function test1(a) {
245− return function (b) {
246− return a + b;
247− }
248−}
249−```
250−
251−Multiple argument functions can be introduced by wrapping the arguments in parentheses, and separating them with commas:
252−
253−```haskell
254−test1 = \(a, b) -> a + b
255−```
256−
257−which generates
258−
259−```javascript
260−function test1(a, b) {
261− return a + b;
262−}
263−```
264−
265−In the case of a function with no arguments, the parentheses may be omitted, as follows:
266−
267−```haskell
268−test2 = \ -> 100
269−```
270−
271−which would correspond to the Javascript `function test2() { return 100; }`
272−
273−Multiple-argument and single-argument syntax can be mixed, as follows:
274−
275−```haskell
276−test3 = \a (b, c) d -> a + b + c + d
277−```
278−
279−which generates
280−
281−```javascript
282−function test3(a) {
283− return function (b, c) {
284− return function (d) {
285− return a + b + c + d;
286− }
287− }
288−}
289−```
290−
291−Functions are applied by providing their arguments inside parentheses:
292−
293−```haskell
294−test1(1, 2, 3)
295−test2()
296−```
297−
298−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:
299−
300−```haskell
301−-- has type Number -> Number -> Number -> Number
302−addThree = \a b c -> a + b + c
303−
304−-- has type Number -> Number -> Number
305−addThree 1
306−
307−-- has type Number -> Number
308−addThree 1 2
309−
310−-- has type Number
311−addThree 1 2 3
312−```
313−
314−## Polymorphic Types
315−
316−Expressions defined at the top level may have polymorphic types.
317−
318−Here is an example:
319−
320−```haskell
321−identity x = x
322−```
323−
324−`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.
325−
326−A type annotation can also be provided:
327−
328−```haskell
329−identity :: forall a. a -> a
330−identity x = x
331−```
332−
333−Functions may also be polymorphic in row types or type variables with other kinds (see "Kind System"):
334−
335−```haskell
336−addProps o = o.foo + o.bar
337−```
338−
339−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*.
340−
341−So, the following compiles:
342−
343−```haskell
344−addProps { foo: 1, bar: 2, baz: 3 }
345−```
346−
347−but the following does not:
348−
349−```haskell
350−addProps { foo: 1 }
351−```
352−
353−since the `bar` property is missing.
354−
355−Again, a type annotation can be provided if necessary.
356−
357−## Rank N Types
358−
359−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.
360−
361−In most cases, a type annotation is necessary when using this feature.
362−
363−As an example, we can pass a polymorphic function as an argument to another function:
364−
365−```haskell
366−poly :: (forall a. a -> a) -> Boolean
367−poly f = (f 0 < 1) == f true
368−```
369−
370−Notice that the polymorphic function's type argument is instantiated to both `Number` and `Boolean`.
371−
372−An argument to `poly` must indeed be polymorphic. For example, the following fails:
373−
374−```haskell
375−test = poly (\n -> n + 1)
376−```
377−
378−since the skolemized type variable `a` does not unify with `Number`.
379−
380−## Type Inference
381−
382−All types can be inferred, but annotations can optionally be provided.
383−
384−## Kind System
385−
386−There are two primitive kinds, the kind `*` of types and the kind `!` of effects.
387−
388−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.
389−
390−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.
391−
392−## Whitespace
393−
394−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.
395−
396−That is, the following is valid:
397−
398−```haskell
399−foo = bar(x) +
400− baz(x)
401−```
402−
403−But this is not:
404−
405−```haskell
406−foo = bar(x) +
407−baz(x)
408−```
409−
410−## Blocks
411−
412−Blocks are collections of statements wrapped in braces `{ ... }`. Blocks must return a value of the same type on every branch of execution.
413−
414−The following types of statement are supported:
415−
416−- Variable introduction
417−- Variable assignment
418−- For loops
419−- For-each loops
420−- While loops
421−- If-Then-Else statements
422−
423−Here is an example of a power function defined using a block:
424−
425−```haskell
426−pow n p = {
427− var m = n;
428− for (i <- 0 until p) {
429− m = m * n;
430− }
431− return m;
432− }
433−```
434−
435−Blocks enable local mutation of their variables, but mutation is not allowed in general. The type system prevents mutable variables from escaping their scope.
436−
437−That is, while the example above is valid, the following does not compile:
438−
439−```haskell
440−incr n = {
441− n = n + 1;
442− return n;
443− }
444−```
445−
446−The variable `n` is not mutable, and so the assignment in the first line of the `do` block is not allowed.
447−
448−This function can be rewritten as follows:
449−
450−```haskell
451−incr n = {
452− var m = n;
453− m = m + 1;
454− return m;
455− }
456−```
457−
458−## For Loops
459−
460−For loops look like this:
461−
462−```haskell
463−total = {
464− var n = 0;
465− for (i <- 0 until 10) {
466− n = n + i;
467− }
468− return n;
469− }
470−```
471−
472−The bounds `0` and `10` are inclusive and exclusive respectively.
473−
474−## For-Each Loops
475−
476−For each loops loop over the elements in an array using the `Object.forEach` method. A polyfill may be required for some browsers:
477−
478−```haskell
479−total arr = {
480− var n = 0;
481− foreach (i in arr) {
482− n = n + i;
483− }
484− return n;
485− }
486−```
487−
488−## While Loops
489−
490−The syntax of a while loop is similar to a foreach loop:
491−
492−```haskell
493−log2 n = {
494− var count = 0;
495− var m = n;
496− while (m > 1) {
497− m = m / 2;
498− count = count + 1;
499− }
500− return count;
501− }
502−```
503−
504−## If-Then-Else Statements
505−
506−Else branches are optional, and may contain further `if` statements, just as in Javascript:
507−
508−```haskell
509−collatz n = {
510− var count = 0;
511− var m = n;
512− while (m > 1) {
513− if (m % 2 == 0) {
514− m = m / 2;
515− } else {
516− m = m * 3 + 1;
517− }
518− count = count + 1;
519− }
520− return count;
521− }
522−```
523−
524−## If-Then-Else Expressions
525−
526−The `if`, `then` and `else` keywords can also be used to create conditional expressions. In this case, the `else` block is always required.
527−
528−For example,
529−
530−```haskell
531−conditional = if 2 > 1 then "ok" else "oops"
532−```
533−
534−## Do Notation
535−
536−The `do` keyword introduces simple syntactic sugar for monadic expressions.
537−
538−Here is an example, using the maybe monad:
539−
540−```haskell
541−data Maybe a = Nothing | Just a
542−
543−instance Monad Maybe where
544− ret = Just
545− (>>=) Nothing _ = Nothing
546− (>>=) (Just a) f = f a
547−
548−isEven n | n % 2 == 0 = Just {}
549−isEven _ = Nothing
550−
551−evenSum a b = do
552− n <- a
553− m <- b
554− let sum = n + m
555− isEven sum
556− ret sum
557−```
558−
559−`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`.
560−
561−This example illustrates the following aspects of `do` notation:
562−
563−- The corresponding type constructor must be an instance of the `Prelude.Monad` type class, which defines the `ret` and `>>=` functions.
564−- Statements can have the following form:
565− - `a <- x` which desugars to `m.bind x (\a -> ...)`
566− - `let a = x` which desugars to `(\a -> ...)(x)`
567− - `x` which desugars to `m.bind x (\_ -> ...)` or just `x` if this is the last statement.
568−
569−Not illustrated here, but equally valid is the use of a binder on the left hand side of `<-` or `=`. For example:
570−
571−```haskell
572−test arr = do
573− (x:y:_) <- arr
574− ret (x + y)
575−```
576−
577−A pattern match failure will generate a runtime exception, just as in the case of a regular `case` statement.
578−
579−## Pattern Matching
580−
581−Pattern matching deconstructs a value to bring zero or more expressions into scope. Pattern matches are introduced with the `case` keyword.
582−
583−Pattern matches have the following general form
584−
585−```haskell
586−case value of
587− pattern -> result
588− -- ...
589− pattern -> result
590−```
591−
592−Pattern matching can also be used in the declaration of functions, as we have already seen:
593−
594−```haskell
595−fn pattern_1 ... pattern_n = result
596−```
597−
598−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,
599−
600−```haskell
601−example x (y, z) w = x * y + z * w
602−```
603−
604−The following pattern types are supported:
605−
606−- Wildcard pattern
607−- Literal patterns
608−- Variable pattern
609−- Array patterns
610−- Cons patterns
611−- Record patterns
612−- Named patterns
613−- Guards
614−
615−Patterns need not be exhaustive. A pattern match failed exception will be thrown at runtime if no pattern matches the input.
616−
617−## Wildcard Patterns
618−
619−The wilcard `_` matches any input and brings nothing into scope:
620−
621−```haskell
622−case x of
623− _ -> 0
624−```
625−
626−## Literal Patterns
627−
628−Literal patterns are provided to match on primitives:
629−
630−```haskell
631−case booleanValue of
632− true -> 0
633− false -> 1
634−
635−case stringValue of
636− "Foo" -> 0
637− _ -> 1
638−
639−case numericValue of
640− 0 -> 0
641− _ -> 1
642−```
643−
644−## Variable Pattern
645−
646−A variable pattern matches any input and binds that input to its name:
647−
648−```haskell
649−case foo(x) of
650− result -> bar(result)
651−```
652−
653−## Array Patterns
654−
655−Array patterns match an input which is an array, and bring its elements into scope.
656−
657−For example:
658−
659−```haskell
660−f = \arr -> case arr of
661− [x] -> x
662− [x, y] -> x * y + f xs
663− _ -> 0
664−```
665−
666−Here, the first pattern only matches arrays of length one, and brings the first element of the array into scope.
667−
668−The second pattern matches arrays with two elements, and brings the first and second elements into scope.
669−
670−## Cons Patterns
671−
672−The head and tail of a non-empty array can be matched by using a cons pattern:
673−
674−```haskell
675−add = \arr -> case arr of
676− [] -> 0
677− x : xs -> x + add xs
678−```
679−
680−`:` associates to the right:
681−
682−```haskell
683−addPairs = \arr -> case arr of
684− x : y : xs -> x * y + addPairs xs
685− _ -> 0
686−```
687−
688−## Record Patterns
689−
690−Record patterns match an input which is a record, and bring its properties into scope.
691−
692−```haskell
693−f = \o -> case o of
694− { foo = "Foo" } -> o.bar
695− _ -> 0
696−```
697−
698−## Nested Patterns
699−
700−The patterns above can be combined to create larger patterns.
701−
702−For example:
703−
704−```haskell
705−f = \o -> case o of
706− { arr = x : _, take = "car" } -> x
707− { arr = _ : x : _, take = "cadr" } -> x
708− _ -> 0
709−```
710−
711−## Named Patterns
712−
713−Named patterns bring additional names into scope when using nested patterns. Any pattern can be named by using the `@` symbol:
714−
715−```haskell
716−f = \arr -> case arr of
717− a@(_ : _ : _) -> true
718− a -> false
719−```
720−
721−Here, in the first pattern, any array with two or more elements will be matched and bound to the variable `a`.
722−
723−## Guards
724−
725−Guards are used to impose additional constraints inside a pattern using boolean-valued expressions, and are introduced with a pipe after the pattern:
726−
727−```haskell
728−evens = \arr -> case arr of
729− [] -> 0
730− x : xs | x % 2 == 0 -> 1 + evens xs
731− _ : xs -> evens xs
732−```
733−
734−When defining a function, guards appear after all patterns:
735−
736−```haskell
737−greater x y | x > y = true
738−greater _ _ = false
739−```
740−
741−## Type Synonyms
742−
743−For convenience, it is possible to declare a synonym for a type using the `type` keyword. Type synonyms can include type arguments.
744−
745−For example:
746−
747−```haskell
748−type Foo = { foo :: Number, bar Number }
749−
750−addFoo :: Foo -> Number
751−addFoo = \o -> o.foo + o.bar
752−```
753−## Record Updates
754−
755−Properties on records can be updated using the following syntax: `o { key = value, ..., key = value }`
756−
757−For example, the following function increments the `foo` property on its argument:
758−
759−```haskell
760−incr = \o -> o { foo = o.foo + 1 }
761−```
762−
763−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
764−
765−```haskell
766−Object.prototype.extend = function(o, p) {
767− return $.extend({}, o, p);
768−};
769−```
770−
771−## Operators
772−
773−In addition to the standard operators, user-defined infix operators can be created by enclosing names in parentheses:
774−
775−E.g. to create a synonym for string concatenation:
776−
777−```haskell
778−(<>) = \s1 s2 -> s1 ++ s2
779−
780−greeting = "Hello" <> "World!"
781−```
782−
783−Regular functions can be used as operators by enclosing their names in backticks:
784−
785−```haskell
786−foo = \x y -> x * y + y
787−
788−test = 10 `foo` 20
789−```
790−
791−Fixity declarations can associate a precedence level, which is a natural number, to a user-defined operator, and specify which way it associates:
792−
793−```haskell
794−infixl 5 <>
795−infixr 7 %%
796−```
797−
798−## Modules
799−
800−Modules are introduced using the `module` keyword. All code must be placed in a module.
801−
802−Introduce a module as follows, with a list of declarations:
803−
804−```haskell
805−module A where
806−
807−id x = x
808−```
809−
810−Names may be qualified by using a dot:
811−
812−```
813−foo = A.foo
814−bar = A.B.bar
815−```
816−
817−All the names in a module can be aliased using the `import` declaration:
818−
819−```haskell
820−import A
821−```
822−
823−You can also limit which names are going to be aliased:
824−
825−```haskell
826−import A.B (bar)
827−```
828−
829−## Foreign Function Interface
830−
831−The `foreign import` keyword declares a value which is defined in Javascript, and its type:
832−
833−```haskell
834−foreign import pow :: (Number, Number) -> Number
835−```
836−
837−To declare a new type with no constructors, use `foreign import data` and provide the kind:
838−
839−```haskell
840−foreign import data IO :: * -> *
841−
842−foreign import console :: {
843− log :: String -> IO {}
844−}
845−```
846−
847−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:
848−
849−```haskell
850−foreign import member "length" length :: forall a. [a] -> Number
851−```
852−
853−## Type Classes
854−
855−PureScript has basic support for type classes via the `class` and `instance` keywords.
856−
857−Type class instances must be of the form `String`, `Number`, `Boolean`, `[t]` or `C t1 ... tn`, and only a single type class parameter is supported.
858−
859−Type class instances are resolved based on the order in which they appeared in the source files. In particular, overlapping instances are permitted.
860−
861−```haskell
862−class Show a where
863− show :: a -> String
864−
865−instance Show String where
866− show s = s
867−
868−instance Show Boolean where
869− show true = "true"
870− show false = "false"
871−
872−instance (Show a) => Show [a] where
873− show arr = "[" ++ showArray arr ++ "]"
874−
875−showArray :: forall a. (Show a) => [a] -> String
876−showArray [] = ""
877−showArray [x] = show x
878−showArray (x:xs) = show x ++ ", " ++ showArray xs
879−
880−example = show [true, false]
881−```
RELEASE.mddeleted−171
@@ -1,171 +0,0 @@
1−## 0.3.0 Changes
2−
3−Many thanks to the [contributors](https://github.com/paf31/purescript/graphs/contributors) who helped with this release.
4−
5−- Full language guide can be found [here](http://functorial.com/purescript).
6−- Try out the latest features [here](http://tryps.functorial.com).
7−
8−## New Features / Enhancements
9−
10−- Mutually recursive functions and types are now allowed within a module.
11−- Syntactic sugar for patterns in top-level declarations has been added. For example:
12−
13− sum [] = 0
14− sum (x:xs) = x + sum xs
15−
16−- Basic support for type classes has been added. Polymorphic types of the form `forall a. (C a) => ...` will not be inferred but can be checked. Type inference still works if all type class instances can be determined. There is not yet support for functionality like GHC's `FlexibleInstances`, `FlexibleContexts` or `MultiParamTypesClasses`. For example:
17−
18− class Truthy a where
19− isTrue :: a -> Boolean
20−
21− instance Truthy Boolean where
22− isTrue b = b
23−
24− instance Truthy String where
25− isTrue "" = false
26− isTrue _ = true
27−
28− ifThenElse :: forall a b. (Truthy a) => a -> b -> b -> b
29− ifThenElse a tr fa = if isTrue a then tr else fa
30−
31−- There is now support for `do` notation, using the `Monad` type class from the `Prelude` module. For example:
32−
33− data Maybe = Nothing | Just a
34−
35− instance Prelude.Monad Maybe where
36− ret = Just
37− (>>=) Nothing _ = Nothing
38− (>>=) (Just a) f = f a
39−
40− test = do
41− x <- Just 1
42− y <- Just 2
43− ret $ x + y
44−
45−- There is now a better story for side-effects. The `Eff` module in the `Prelude` defines a monad `Eff e` where e is a row of effect types. The kind system now defines a new kind `!` of effects. Row polymorphism allows different native effects to be interleaved. For example:
46−
47− test = do
48− trace "Testing"
49− throwError "Error!"
50−
51− has inferred type `forall eff. Eff (trace :: Trace | error :: Error String | eff)`.
52− See the `/examples/passing/Eff.purs` file for a more in-depth set of examples.
53− Supported native effects currently include `ST`, `Trace`, `Error` and `DOM` (via the `libraries/jquery` module).
54−- There is a new flag `--run-main` which will check the type of the `Main.main` function and emit the call to `main();` after all other generated Javascript.
55−- The `Prelude` module is now automatically included, unless the `--no-prelude` flag is specified.
56−- The class of accepted operator names has been expanded. Specifically, `$` is now a valid operator, and is defined in the `Prelude` module.
57−- Tail calls can be eliminated using the `--tco` flag.
58−- There is basic support for checking the types of values at runtime, using the `--runtime-type-checks` flag. Right now, this only works for primitive types, and so is a work-in-progress.
59−- GHCJS/Fay-style foreign imports are now supported. An example is
60−
61− foreign import "function(n) { \
62− \ return function(p) {\
63− \ return Math.pow(n, p);\
64− \ }\
65− \ }" pow :: Number -> Number -> Number
66−- Data constructors now get imported along with their type definitions.
67−- The `-s` flag will now cause the compiler to use `stdin` for input.
68−- There is a new executable `psci` which provides simple REPL-like functionality - it parses expressions, passes the generated Javascript to Node for execution, and prints the result. This is a work-in-progress.
69−- The JQuery example (`libraries/jquery/test`) has been improved to use the new `Eff` monad and `do` notation.
70−
71−## Regressions
72−
73−- `foreach` is no longer supported. The `Prelude` module defines `map` which should provide the same functionality.
74−- Support for naked expressions as statements has been removed.
75−
76−## Bug Fixes
77−
78−- Operator precedence rules now work across modules.
79−- A bug in which expressions involving non-qualified names did not typecheck was fixed.
80−- Trailing spaces have been removed in the generated Javascript, thanks to @utkarshkukreti.
81−- Type synonyms now work properly across modules.
82−- Module imports are not transitive, which was previously leading to some unexpected error messages.
83−- A bug which caused the optimizer to break generated Javascript for mutually recursive values was fixed.
84−- Some `Prelude` functions which called methods in the standard Javascript library have been fixed.
85−
86−## 0.2.0 Changes
87−
88−Many thanks to the [contributors](https://github.com/paf31/purescript/graphs/contributors) who helped with this release.
89−
90−- Full language guide can be found [here](http://functorial.com/purescript).
91−- Try out the latest features [here](http://tryps.functorial.com).
92−
93−### New Features
94−
95−- RankNTypes
96−
97− 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:
98−
99− rank2 :: (forall a. a -> a) -> Number
100− rank2 = \f -> if f true then f 1 else f 2
101−
102−- Modules
103−- Polymorphic Object Update
104−
105− Records now support member update in which the type of the field changes during the update. For example:
106−
107− data Wrap a = Wrap a
108−
109− update = \o -> o { prop = Wrap o.prop }
110−
111−### Enhancements
112−
113−- Naked expressions as statements
114−
115− Naked expressions of type `{}` can now be used as statements.
116−
117−- Split code generation into `AST -> JS` and `JS -> String`
118−
119− 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.
120−
121−- Syntactic sugar for introducing curried functions
122−
123− Single-argument functions and multiple-argument functions can now be introduced in the same way:
124−
125− test = \a (b, c) d -> a + b + c + d
126−
127−- JavaScript optimizations
128−
129− Some basic dead-variable elimination, inlining and eta-conversion are now performed on the generated JavaScript.
130−
131−- Generate formatted Javascript
132−
133− The generated JavaScript is now formatted to be more readable. In particular, newlines get generated, and the correct indentation is used.
134−
135−- More valid infix operators
136−
137− The colon and period characters are now valid in infix operator names.
138−
139−### Syntax Changes
140−
141−- Avoid 'do' keyword for blocks
142−
143− `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.
144−
145−- Member foreign import syntax
146−
147− A small syntactic addition to the FFI, to support a common use case.
148−
149−- Make FFI syntax match Haskell
150−
151− Use `foreign import` instead of `extern`.
152−
153−- Make record declaration syntax match Haskell
154−- Simplify array binders
155−
156− 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]`.
157−
158−- Array indexing syntax is ambiguous
159−
160− Array elements are now accessed using the `!!` operator: `arr !! 0` etc.
161−
162−### Bug Fixes
163−
164−- Allow guards access to current scope
165−
166−### Libraries
167−
168−- Prelude
169−
170− There is now a basic prelude in the `libraries/prelude` folder.
171−
Setup.hsnew file+2
@@ -0,0 +1,2 @@
1+import Distribution.Simple
2+main = defaultMain
Setup.lhsdeleted−6
@@ -1,6 +0,0 @@
1−#!/usr/bin/runhaskell
2−> module Main where
3−> import Distribution.Simple
4−> main :: IO ()
5−> main = defaultMain
6−
app/Main.hsnew file+250
@@ -0,0 +1,250 @@
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.nixnew file+23
@@ -0,0 +1,23 @@
1+let
2+ haskellNix = import (builtins.fetchTarball https://github.com/input-output-hk/haskell.nix/archive/master.tar.gz) {};
3+ nixpkgsSrc = haskellNix.sources.nixpkgs-1903; # has hsc2hs-0.68.4
4+
5+ hsc2hsOverlay = self: super: {
6+ buildPackages = super.buildPackages // {
7+ hsc2hs = super.haskellPackages.hsc2hs;
8+ };
9+ };
10+
11+ nixpkgsArgs = haskellNix.nixpkgsArgs // {
12+ overlays = haskellNix.nixpkgsArgs.overlays ++ [ hsc2hsOverlay ];
13+ };
14+in
15+{ pkgs ? import nixpkgsSrc nixpkgsArgs
16+}:
17+
18+pkgs.haskell-nix.stackProject {
19+ src = pkgs.haskell-nix.haskellLib.cleanGit {
20+ name = "purescript-native";
21+ src = ./.;
22+ };
23+}
docs/.gitignoredeleted−1
@@ -1 +0,0 @@
1−build
docs/Makefiledeleted−177
@@ -1,177 +0,0 @@
1−# Makefile for Sphinx documentation
2−#
3−
4−# You can set these variables from the command line.
5−SPHINXOPTS =
6−SPHINXBUILD = sphinx-build
7−PAPER =
8−BUILDDIR = build
9−
10−# User-friendly check for sphinx-build
11−ifeq ($(shell which $(SPHINXBUILD) >/dev/null 2>&1; echo $$?), 1)
12−$(error The '$(SPHINXBUILD)' command was not found. Make sure you have Sphinx installed, then set the SPHINXBUILD environment variable to point to the full path of the '$(SPHINXBUILD)' executable. Alternatively you can add the directory with the executable to your PATH. If you don't have Sphinx installed, grab it from http://sphinx-doc.org/)
13−endif
14−
15−# Internal variables.
16−PAPEROPT_a4 = -D latex_paper_size=a4
17−PAPEROPT_letter = -D latex_paper_size=letter
18−ALLSPHINXOPTS = -d $(BUILDDIR)/doctrees $(PAPEROPT_$(PAPER)) $(SPHINXOPTS) source
19−# the i18n builder cannot share the environment and doctrees with the others
20−I18NSPHINXOPTS = $(PAPEROPT_$(PAPER)) $(SPHINXOPTS) source
21−
22−.PHONY: help clean html dirhtml singlehtml pickle json htmlhelp qthelp devhelp epub latex latexpdf text man changes linkcheck doctest gettext
23−
24−help:
25− @echo "Please use \`make <target>' where <target> is one of"
26− @echo " html to make standalone HTML files"
27− @echo " dirhtml to make HTML files named index.html in directories"
28− @echo " singlehtml to make a single large HTML file"
29− @echo " pickle to make pickle files"
30− @echo " json to make JSON files"
31− @echo " htmlhelp to make HTML files and a HTML help project"
32− @echo " qthelp to make HTML files and a qthelp project"
33− @echo " devhelp to make HTML files and a Devhelp project"
34− @echo " epub to make an epub"
35− @echo " latex to make LaTeX files, you can set PAPER=a4 or PAPER=letter"
36− @echo " latexpdf to make LaTeX files and run them through pdflatex"
37− @echo " latexpdfja to make LaTeX files and run them through platex/dvipdfmx"
38− @echo " text to make text files"
39− @echo " man to make manual pages"
40− @echo " texinfo to make Texinfo files"
41− @echo " info to make Texinfo files and run them through makeinfo"
42− @echo " gettext to make PO message catalogs"
43− @echo " changes to make an overview of all changed/added/deprecated items"
44− @echo " xml to make Docutils-native XML files"
45− @echo " pseudoxml to make pseudoxml-XML files for display purposes"
46− @echo " linkcheck to check all external links for integrity"
47− @echo " doctest to run all doctests embedded in the documentation (if enabled)"
48−
49−clean:
50− rm -rf $(BUILDDIR)/*
51−
52−html:
53− $(SPHINXBUILD) -b html $(ALLSPHINXOPTS) $(BUILDDIR)/html
54− @echo
55− @echo "Build finished. The HTML pages are in $(BUILDDIR)/html."
56−
57−dirhtml:
58− $(SPHINXBUILD) -b dirhtml $(ALLSPHINXOPTS) $(BUILDDIR)/dirhtml
59− @echo
60− @echo "Build finished. The HTML pages are in $(BUILDDIR)/dirhtml."
61−
62−singlehtml:
63− $(SPHINXBUILD) -b singlehtml $(ALLSPHINXOPTS) $(BUILDDIR)/singlehtml
64− @echo
65− @echo "Build finished. The HTML page is in $(BUILDDIR)/singlehtml."
66−
67−pickle:
68− $(SPHINXBUILD) -b pickle $(ALLSPHINXOPTS) $(BUILDDIR)/pickle
69− @echo
70− @echo "Build finished; now you can process the pickle files."
71−
72−json:
73− $(SPHINXBUILD) -b json $(ALLSPHINXOPTS) $(BUILDDIR)/json
74− @echo
75− @echo "Build finished; now you can process the JSON files."
76−
77−htmlhelp:
78− $(SPHINXBUILD) -b htmlhelp $(ALLSPHINXOPTS) $(BUILDDIR)/htmlhelp
79− @echo
80− @echo "Build finished; now you can run HTML Help Workshop with the" \
81− ".hhp project file in $(BUILDDIR)/htmlhelp."
82−
83−qthelp:
84− $(SPHINXBUILD) -b qthelp $(ALLSPHINXOPTS) $(BUILDDIR)/qthelp
85− @echo
86− @echo "Build finished; now you can run "qcollectiongenerator" with the" \
87− ".qhcp project file in $(BUILDDIR)/qthelp, like this:"
88− @echo "# qcollectiongenerator $(BUILDDIR)/qthelp/PureScript.qhcp"
89− @echo "To view the help file:"
90− @echo "# assistant -collectionFile $(BUILDDIR)/qthelp/PureScript.qhc"
91−
92−devhelp:
93− $(SPHINXBUILD) -b devhelp $(ALLSPHINXOPTS) $(BUILDDIR)/devhelp
94− @echo
95− @echo "Build finished."
96− @echo "To view the help file:"
97− @echo "# mkdir -p $$HOME/.local/share/devhelp/PureScript"
98− @echo "# ln -s $(BUILDDIR)/devhelp $$HOME/.local/share/devhelp/PureScript"
99− @echo "# devhelp"
100−
101−epub:
102− $(SPHINXBUILD) -b epub $(ALLSPHINXOPTS) $(BUILDDIR)/epub
103− @echo
104− @echo "Build finished. The epub file is in $(BUILDDIR)/epub."
105−
106−latex:
107− $(SPHINXBUILD) -b latex $(ALLSPHINXOPTS) $(BUILDDIR)/latex
108− @echo
109− @echo "Build finished; the LaTeX files are in $(BUILDDIR)/latex."
110− @echo "Run \`make' in that directory to run these through (pdf)latex" \
111− "(use \`make latexpdf' here to do that automatically)."
112−
113−latexpdf:
114− $(SPHINXBUILD) -b latex $(ALLSPHINXOPTS) $(BUILDDIR)/latex
115− @echo "Running LaTeX files through pdflatex..."
116− $(MAKE) -C $(BUILDDIR)/latex all-pdf
117− @echo "pdflatex finished; the PDF files are in $(BUILDDIR)/latex."
118−
119−latexpdfja:
120− $(SPHINXBUILD) -b latex $(ALLSPHINXOPTS) $(BUILDDIR)/latex
121− @echo "Running LaTeX files through platex and dvipdfmx..."
122− $(MAKE) -C $(BUILDDIR)/latex all-pdf-ja
123− @echo "pdflatex finished; the PDF files are in $(BUILDDIR)/latex."
124−
125−text:
126− $(SPHINXBUILD) -b text $(ALLSPHINXOPTS) $(BUILDDIR)/text
127− @echo
128− @echo "Build finished. The text files are in $(BUILDDIR)/text."
129−
130−man:
131− $(SPHINXBUILD) -b man $(ALLSPHINXOPTS) $(BUILDDIR)/man
132− @echo
133− @echo "Build finished. The manual pages are in $(BUILDDIR)/man."
134−
135−texinfo:
136− $(SPHINXBUILD) -b texinfo $(ALLSPHINXOPTS) $(BUILDDIR)/texinfo
137− @echo
138− @echo "Build finished. The Texinfo files are in $(BUILDDIR)/texinfo."
139− @echo "Run \`make' in that directory to run these through makeinfo" \
140− "(use \`make info' here to do that automatically)."
141−
142−info:
143− $(SPHINXBUILD) -b texinfo $(ALLSPHINXOPTS) $(BUILDDIR)/texinfo
144− @echo "Running Texinfo files through makeinfo..."
145− make -C $(BUILDDIR)/texinfo info
146− @echo "makeinfo finished; the Info files are in $(BUILDDIR)/texinfo."
147−
148−gettext:
149− $(SPHINXBUILD) -b gettext $(I18NSPHINXOPTS) $(BUILDDIR)/locale
150− @echo
151− @echo "Build finished. The message catalogs are in $(BUILDDIR)/locale."
152−
153−changes:
154− $(SPHINXBUILD) -b changes $(ALLSPHINXOPTS) $(BUILDDIR)/changes
155− @echo
156− @echo "The overview file is in $(BUILDDIR)/changes."
157−
158−linkcheck:
159− $(SPHINXBUILD) -b linkcheck $(ALLSPHINXOPTS) $(BUILDDIR)/linkcheck
160− @echo
161− @echo "Link check complete; look for any errors in the above output " \
162− "or in $(BUILDDIR)/linkcheck/output.txt."
163−
164−doctest:
165− $(SPHINXBUILD) -b doctest $(ALLSPHINXOPTS) $(BUILDDIR)/doctest
166− @echo "Testing of doctests in the sources finished, look at the " \
167− "results in $(BUILDDIR)/doctest/output.txt."
168−
169−xml:
170− $(SPHINXBUILD) -b xml $(ALLSPHINXOPTS) $(BUILDDIR)/xml
171− @echo
172− @echo "Build finished. The XML files are in $(BUILDDIR)/xml."
173−
174−pseudoxml:
175− $(SPHINXBUILD) -b pseudoxml $(ALLSPHINXOPTS) $(BUILDDIR)/pseudoxml
176− @echo
177− @echo "Build finished. The pseudo-XML files are in $(BUILDDIR)/pseudoxml."
docs/source/conf.pydeleted−258
@@ -1,258 +0,0 @@
1−# -*- coding: utf-8 -*-
2−#
3−# PureScript documentation build configuration file, created by
4−# sphinx-quickstart on Wed Jan 22 22:04:23 2014.
5−#
6−# This file is execfile()d with the current directory set to its
7−# containing dir.
8−#
9−# Note that not all possible configuration values are present in this
10−# autogenerated file.
11−#
12−# All configuration values have a default; values that are commented out
13−# serve to show the default.
14−
15−import sys
16−import os
17−
18−# If extensions (or modules to document with autodoc) are in another directory,
19−# add these directories to sys.path here. If the directory is relative to the
20−# documentation root, use os.path.abspath to make it absolute, like shown here.
21−#sys.path.insert(0, os.path.abspath('.'))
22−
23−# -- General configuration ------------------------------------------------
24−
25−# If your documentation needs a minimal Sphinx version, state it here.
26−#needs_sphinx = '1.0'
27−
28−# Add any Sphinx extension module names here, as strings. They can be
29−# extensions coming with Sphinx (named 'sphinx.ext.*') or your custom
30−# ones.
31−extensions = []
32−
33−# Add any paths that contain templates here, relative to this directory.
34−templates_path = ['_templates']
35−
36−# The suffix of source filenames.
37−source_suffix = '.rst'
38−
39−# The encoding of source files.
40−#source_encoding = 'utf-8-sig'
41−
42−# The master toctree document.
43−master_doc = 'index'
44−
45−# General information about the project.
46−project = u'PureScript'
47−copyright = u'2014, Phil Freeman'
48−
49−# The version info for the project you're documenting, acts as replacement for
50−# |version| and |release|, also used in various other places throughout the
51−# built documents.
52−#
53−# The short X.Y version.
54−version = '0.3.1'
55−# The full version, including alpha/beta/rc tags.
56−release = '0.3.1'
57−
58−# The language for content autogenerated by Sphinx. Refer to documentation
59−# for a list of supported languages.
60−#language = None
61−
62−# There are two options for replacing |today|: either, you set today to some
63−# non-false value, then it is used:
64−#today = ''
65−# Else, today_fmt is used as the format for a strftime call.
66−#today_fmt = '%B %d, %Y'
67−
68−# List of patterns, relative to source directory, that match files and
69−# directories to ignore when looking for source files.
70−exclude_patterns = []
71−
72−# The reST default role (used for this markup: `text`) to use for all
73−# documents.
74−#default_role = None
75−
76−# If true, '()' will be appended to :func: etc. cross-reference text.
77−#add_function_parentheses = True
78−
79−# If true, the current module name will be prepended to all description
80−# unit titles (such as .. function::).
81−#add_module_names = True
82−
83−# If true, sectionauthor and moduleauthor directives will be shown in the
84−# output. They are ignored by default.
85−#show_authors = False
86−
87−# The name of the Pygments (syntax highlighting) style to use.
88−pygments_style = 'sphinx'
89−
90−# A list of ignored prefixes for module index sorting.
91−#modindex_common_prefix = []
92−
93−# If true, keep warnings as "system message" paragraphs in the built documents.
94−#keep_warnings = False
95−
96−
97−# -- Options for HTML output ----------------------------------------------
98−
99−# The theme to use for HTML and HTML Help pages. See the documentation for
100−# a list of builtin themes.
101−html_theme = 'default'
102−
103−# Theme options are theme-specific and customize the look and feel of a theme
104−# further. For a list of options available for each theme, see the
105−# documentation.
106−#html_theme_options = {}
107−
108−# Add any paths that contain custom themes here, relative to this directory.
109−#html_theme_path = []
110−
111−# The name for this set of Sphinx documents. If None, it defaults to
112−# "<project> v<release> documentation".
113−#html_title = None
114−
115−# A shorter title for the navigation bar. Default is the same as html_title.
116−#html_short_title = None
117−
118−# The name of an image file (relative to this directory) to place at the top
119−# of the sidebar.
120−#html_logo = None
121−
122−# The name of an image file (within the static path) to use as favicon of the
123−# docs. This file should be a Windows icon file (.ico) being 16x16 or 32x32
124−# pixels large.
125−#html_favicon = None
126−
127−# Add any paths that contain custom static files (such as style sheets) here,
128−# relative to this directory. They are copied after the builtin static files,
129−# so a file named "default.css" will overwrite the builtin "default.css".
130−html_static_path = ['_static']
131−
132−# Add any extra paths that contain custom files (such as robots.txt or
133−# .htaccess) here, relative to this directory. These files are copied
134−# directly to the root of the documentation.
135−#html_extra_path = []
136−
137−# If not '', a 'Last updated on:' timestamp is inserted at every page bottom,
138−# using the given strftime format.
139−#html_last_updated_fmt = '%b %d, %Y'
140−
141−# If true, SmartyPants will be used to convert quotes and dashes to
142−# typographically correct entities.
143−#html_use_smartypants = True
144−
145−# Custom sidebar templates, maps document names to template names.
146−#html_sidebars = {}
147−
148−# Additional templates that should be rendered to pages, maps page names to
149−# template names.
150−#html_additional_pages = {}
151−
152−# If false, no module index is generated.
153−#html_domain_indices = True
154−
155−# If false, no index is generated.
156−#html_use_index = True
157−
158−# If true, the index is split into individual pages for each letter.
159−#html_split_index = False
160−
161−# If true, links to the reST sources are added to the pages.
162−#html_show_sourcelink = True
163−
164−# If true, "Created using Sphinx" is shown in the HTML footer. Default is True.
165−#html_show_sphinx = True
166−
167−# If true, "(C) Copyright ..." is shown in the HTML footer. Default is True.
168−#html_show_copyright = True
169−
170−# If true, an OpenSearch description file will be output, and all pages will
171−# contain a <link> tag referring to it. The value of this option must be the
172−# base URL from which the finished HTML is served.
173−#html_use_opensearch = ''
174−
175−# This is the file name suffix for HTML files (e.g. ".xhtml").
176−#html_file_suffix = None
177−
178−# Output file base name for HTML help builder.
179−htmlhelp_basename = 'PureScriptdoc'
180−
181−
182−# -- Options for LaTeX output ---------------------------------------------
183−
184−latex_elements = {
185−# The paper size ('letterpaper' or 'a4paper').
186−#'papersize': 'letterpaper',
187−
188−# The font size ('10pt', '11pt' or '12pt').
189−#'pointsize': '10pt',
190−
191−# Additional stuff for the LaTeX preamble.
192−#'preamble': '',
193−}
194−
195−# Grouping the document tree into LaTeX files. List of tuples
196−# (source start file, target name, title,
197−# author, documentclass [howto, manual, or own class]).
198−latex_documents = [
199− ('index', 'PureScript.tex', u'PureScript Documentation',
200− u'Phil Freeman', 'manual'),
201−]
202−
203−# The name of an image file (relative to this directory) to place at the top of
204−# the title page.
205−#latex_logo = None
206−
207−# For "manual" documents, if this is true, then toplevel headings are parts,
208−# not chapters.
209−#latex_use_parts = False
210−
211−# If true, show page references after internal links.
212−#latex_show_pagerefs = False
213−
214−# If true, show URL addresses after external links.
215−#latex_show_urls = False
216−
217−# Documents to append as an appendix to all manuals.
218−#latex_appendices = []
219−
220−# If false, no module index is generated.
221−#latex_domain_indices = True
222−
223−
224−# -- Options for manual page output ---------------------------------------
225−
226−# One entry per manual page. List of tuples
227−# (source start file, name, description, authors, manual section).
228−man_pages = [
229− ('index', 'purescript', u'PureScript Documentation',
230− [u'Phil Freeman'], 1)
231−]
232−
233−# If true, show URL addresses after external links.
234−#man_show_urls = False
235−
236−
237−# -- Options for Texinfo output -------------------------------------------
238−
239−# Grouping the document tree into Texinfo files. List of tuples
240−# (source start file, target name, title, author,
241−# dir menu entry, description, category)
242−texinfo_documents = [
243− ('index', 'PureScript', u'PureScript Documentation',
244− u'Phil Freeman', 'PureScript', 'One line description of project.',
245− 'Miscellaneous'),
246−]
247−
248−# Documents to append as an appendix to all manuals.
249−#texinfo_appendices = []
250−
251−# If false, no module index is generated.
252−#texinfo_domain_indices = True
253−
254−# How to display URL addresses: 'footnote', 'no', or 'inline'.
255−#texinfo_show_urls = 'footnote'
256−
257−# If true, do not generate a @detailmenu in the "Top" node's menu.
258−#texinfo_no_detailmenu = False
docs/source/index.rstdeleted−22
@@ -1,22 +0,0 @@
1−.. PureScript documentation master file, created by
2− sphinx-quickstart on Wed Jan 22 22:04:23 2014.
3− You can adapt this file completely to your liking, but it should at least
4− contain the root `toctree` directive.
5−
6−Welcome to PureScript's documentation!
7−======================================
8−
9−Contents:
10−
11−.. toctree::
12− :maxdepth: 2
13−
14− intro
15−
16−Indices and tables
17−==================
18−
19−* :ref:`genindex`
20−* :ref:`modindex`
21−* :ref:`search`
22−
docs/source/intro.rstdeleted−138
@@ -1,138 +0,0 @@
1−purescript
2−==========
3−
4−PureScript is a small strongly, statically typed compile-to-JS language with a number of interesting features, such as:
5−
6−- Type Inference
7−- Higher Kinded Polymorphism
8−- Support for basic Javascript types
9−- Extensible records
10−- Extensible effects
11−- Type-safe blocks with for/while/assignment etc.
12−- Functions with multiple arguments
13−- Pattern matching
14−- Simple FFI
15−- Modules
16−- Rank N Types
17−- Do Notation
18−- Optional tail-call elimination
19−- Type Classes
20−
21−## Try It!
22−
23−Try PureScript in the browser [here](http://tryps.functorial.com/).
24−
25−## Installation
26−
27−Install the Haskell Plaform, then `cabal install`
28−
29−## Usage
30−
31−The `psc` executable takes a list of PureScript source files as arguments and by default writes out its errors or output to the console.
32−
33−The following options are supported:
34−
35− -s --stdin
36− Read input from standard input instead of from files
37−
38− -o --output
39− Write the generated Javascript to the specified file
40−
41− -e --foreign imports
42− Write a list of foreign imports declarations to the specified file in addition to generating Javascript output
43−
44− --runtime-type-checks
45− Generate simple runtime type checks for function arguments with simple types.
46−
47− --tco
48− Perform tail-call elimination on the generated Javascript.
49−
50− --no-prelude
51− Do not include the Prelude in the generated Javascript.
52−
53− --magic-do
54− Overload the `do` keyword to inline calls to `bind` for the `Eff` monad, to generate more efficient code.
55−
56− --run-main
57− Generate a call to `Main.main` after all other generated Javascript.
58−
59−## Motivation
60−
61−I was looking for a simple functional language which would compile to JavaScript and have the following characteristics:
62−
63−- Generate simple readable Javascript
64−- Provide the ability to compile to tight loops if necessary
65−- Reasonable type system
66−- Ideally, written in a programming language I would enjoy working in
67−- Provides a simple interface to existing Javascript code
68−
69−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.
70−
71−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.
72−
73−PureScript can also be seen as a trade-off between a theoretically ideal language and one which generates reasonably high performance code.
74−
75−## Hello, PureScript!
76−
77−As an introductory example, here is the usual "Hello World" written in PureScript:
78−
79−```haskell
80−module Main where
81−
82−import Trace
83−
84−main = trace "Hello, World!"
85−```
86−
87−which compiles to the following Javascript, ignoring the Prelude:
88−
89−```javascript
90−var Main;
91−(function (Main) {
92− var main = trace("Hello, World!");
93− Main.main = main;
94−})(Main = Main || {});
95−```
96−
97−The following command will compile and execute the PureScript code above:
98−
99−```
100−psc input.purs --run-main | nodejs
101−```
102−
103−## Another Example
104−
105−The following code defines a `Person` data type and a function to generate a string representation for a `Person`:
106−
107−```haskell
108−data Person = Person { name :: String, age :: Number }
109−
110−foreign import numberToString :: Number -> String
111−
112−showPerson :: Person -> String
113−showPerson (Person o) = o.name ++ ", aged " ++ numberToString(o.age)
114−```
115−
116−Line by line, this reads as follows:
117−
118−- `Person` is a data type with one constructor, also called `Person`
119− - The `Person` constructor takes an object with two properties, `name` which is a `String`, and `age` which is a `Number`
120−- The `numberToString` function is written in Javascript, and converts a `Number` to its `String` representation
121−- The `showPerson` function takes a `Person` and returns a `String`
122−- `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.
123−
124−The generated Javascript looks like this:
125−
126−```javascript
127−var Person = function (value) {
128− return { ctor: 'Person', value: value };
129−};
130−
131−function showPerson(_1) {
132− if (_1.ctor === "Person") {
133− return _1.value.name + ", aged " + numberToString(_1.value.age);
134− };
135− throw "Failed pattern match";
136−};
137−
138−```
docs/source/modules.rstdeleted−29
@@ -1,29 +0,0 @@
1−## Modules
2−
3−Modules are introduced using the `module` keyword. All code must be placed in a module.
4−
5−Introduce a module as follows, with a list of declarations:
6−
7−```haskell
8−module A where
9−
10−id x = x
11−```
12−
13−Names may be qualified by using a dot:
14−
15−```
16−foo = A.id
17−```
18−
19−All the names in a module can be aliased using the `import` declaration:
20−
21−```haskell
22−import A
23−```
24−
25−You can also limit which names are going to be aliased:
26−
27−```haskell
28−import A (id)
29−```
docs/source/syntax.rstdeleted−213
@@ -1,213 +0,0 @@
1−## Whitespace
2−
3−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.
4−
5−That is, the following is valid:
6−
7−```haskell
8−foo = bar(x) +
9− baz(x)
10−```
11−
12−But this is not:
13−
14−```haskell
15−foo = bar(x) +
16−baz(x)
17−```
18−
19−## Blocks
20−
21−Blocks are collections of statements wrapped in braces `{ ... }`. Blocks must return a value of the same type on every branch of execution.
22−
23−The following types of statement are supported:
24−
25−- Variable introduction
26−- Variable assignment
27−- For loops
28−- For-each loops
29−- While loops
30−- If-Then-Else statements
31−
32−Here is an example of a power function defined using a block:
33−
34−```haskell
35−pow n p = {
36− var m = n;
37− for (i <- 0 until p) {
38− m = m * n;
39− }
40− return m;
41− }
42−```
43−
44−Blocks enable local mutation of their variables, but mutation is not allowed in general. The type system prevents mutable variables from escaping their scope.
45−
46−That is, while the example above is valid, the following does not compile:
47−
48−```haskell
49−incr n = {
50− n = n + 1;
51− return n;
52− }
53−```
54−
55−The variable `n` is not mutable, and so the assignment in the first line of the `do` block is not allowed.
56−
57−This function can be rewritten as follows:
58−
59−```haskell
60−incr n = {
61− var m = n;
62− m = m + 1;
63− return m;
64− }
65−```
66−
67−## For Loops
68−
69−For loops look like this:
70−
71−```haskell
72−total = {
73− var n = 0;
74− for (i <- 0 until 10) {
75− n = n + i;
76− }
77− return n;
78− }
79−```
80−
81−The bounds `0` and `10` are inclusive and exclusive respectively.
82−
83−## For-Each Loops
84−
85−For each loops loop over the elements in an array using the `Object.forEach` method. A polyfill may be required for some browsers:
86−
87−```haskell
88−total arr = {
89− var n = 0;
90− foreach (i in arr) {
91− n = n + i;
92− }
93− return n;
94− }
95−```
96−
97−## While Loops
98−
99−The syntax of a while loop is similar to a foreach loop:
100−
101−```haskell
102−log2 n = {
103− var count = 0;
104− var m = n;
105− while (m > 1) {
106− m = m / 2;
107− count = count + 1;
108− }
109− return count;
110− }
111−```
112−
113−## If-Then-Else Statements
114−
115−Else branches are optional, and may contain further `if` statements, just as in Javascript:
116−
117−```haskell
118−collatz n = {
119− var count = 0;
120− var m = n;
121− while (m > 1) {
122− if (m % 2 == 0) {
123− m = m / 2;
124− } else {
125− m = m * 3 + 1;
126− }
127− count = count + 1;
128− }
129− return count;
130− }
131−```
132−
133−## If-Then-Else Expressions
134−
135−The `if`, `then` and `else` keywords can also be used to create conditional expressions. In this case, the `else` block is always required.
136−
137−For example,
138−
139−```haskell
140−conditional = if 2 > 1 then "ok" else "oops"
141−```
142−
143−## Do Notation
144−
145−The `do` keyword introduces simple syntactic sugar for monadic expressions.
146−
147−Here is an example, using the maybe monad:
148−
149−```haskell
150−data Maybe a = Nothing | Just a
151−
152−instance Monad Maybe where
153− ret = Just
154− (>>=) Nothing _ = Nothing
155− (>>=) (Just a) f = f a
156−
157−isEven n | n % 2 == 0 = Just {}
158−isEven _ = Nothing
159−
160−evenSum a b = do
161− n <- a
162− m <- b
163− let sum = n + m
164− isEven sum
165− ret sum
166−```
167−
168−`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`.
169−
170−This example illustrates the following aspects of `do` notation:
171−
172−- The corresponding type constructor must be an instance of the `Prelude.Monad` type class, which defines the `ret` and `>>=` functions.
173−- Statements can have the following form:
174− - `a <- x` which desugars to `m.bind x (\a -> ...)`
175− - `let a = x` which desugars to `(\a -> ...)(x)`
176− - `x` which desugars to `m.bind x (\_ -> ...)` or just `x` if this is the last statement.
177−
178−Not illustrated here, but equally valid is the use of a binder on the left hand side of `<-` or `=`. For example:
179−
180−```haskell
181−test arr = do
182− (x:y:_) <- arr
183− ret (x + y)
184−```
185−
186−A pattern match failure will generate a runtime exception, just as in the case of a regular `case` statement.
187−
188−## Operators
189−
190−In addition to the standard operators, user-defined infix operators can be created by enclosing names in parentheses:
191−
192−E.g. to create a synonym for string concatenation:
193−
194−```haskell
195−(<>) = \s1 s2 -> s1 ++ s2
196−
197−greeting = "Hello" <> "World!"
198−```
199−
200−Regular functions can be used as operators by enclosing their names in backticks:
201−
202−```haskell
203−foo = \x y -> x * y + y
204−
205−test = 10 `foo` 20
206−```
207−
208−Fixity declarations can associate a precedence level, which is a natural number, to a user-defined operator, and specify which way it associates:
209−
210−```haskell
211−infixl 5 <>
212−infixr 7 %%
213−```
docs/source/types.rstdeleted−235
@@ -1,235 +0,0 @@
1−## Type System
2−
3−The type system defines the following types:
4−
5−- Primitive Types
6− - Number
7− - String
8− - Boolean
9−- Arrays
10− - E.g. `[String]`, `[[Number]]`
11−- Records
12− - E.g. `{ foo :: String, bar :: Number }`
13−- Tagged Unions
14− - E.g. `data Foo a = Foo | Bar String`
15−- Functions
16− - E.g. `Number -> String`
17− - E.g. `(Number, Number) -> Number`
18− - Functions can have zero or more arguments
19−- Polymorphic types
20− - E.g. `forall a. a -> a`
21−
22−## Primitive Types
23−
24−The three primitive types `String`, `Number` and `Boolean` correspond to their Javascript equivalents at runtime.
25−
26−PureScript supports the same binary and unary operations on primitive types as Javascript, with the following exceptions:
27−
28−- String concatenation is denoted `++` to differentiate it from numeric addition, `+`
29−- PureScript's `==` and `!=` correspond to Javascript's strong equality tests `===` and `!==`
30−
31−Examples:
32−
33−```haskell
34−num = 1 + 2 * 3
35−str = "Hello, " ++ "World!"
36−bool = 1 > 2 || true
37−```
38−
39−## Arrays
40−
41−PureScript arrays correspond to Javascript arrays at runtime, but all elements must have the same type.
42−
43−Array literals look like Javascript array literals: `[1, 2, 3]`
44−
45−Array elements can be read using array index notation `arr !! index`
46−
47−## Records
48−
49−PureScript records correspond to Javascript objects.
50−
51−Record literals look like Javascript object literals: `{ foo: "Foo" }`
52−
53−Properties can be read by using dot notation: `o.foo`
54−
55−## Tagged Unions
56−
57−Tagged unions consist of one or more constructors, each of which takes zero or one arguments.
58−
59−Tagged unions can only be created using their constructors, and deconstructed through pattern matching (see later).
60−
61−For example:
62−
63−```haskell
64−data Foo a = Foo | Bar String
65−
66−runFoo Foo = "It's a Foo"
67−runFoo (Bar s) = "It's a Bar. The string is " ++ s
68−
69−test = runFoo Foo ++ runFoo (Bar "Test")
70−```
71−
72−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.
73−
74−`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.
75−
76−## Functions
77−
78−Functions in PureScript can have zero or more arguments in general, just like in Javascript.
79−
80−Functions are introduced by using a backslash followed by a list of argument names:
81−
82−```haskell
83−test1 = \a b -> a + b
84−```
85−
86−which would correspond to the Javascript
87−
88−```javascript
89−function test1(a) {
90− return function (b) {
91− return a + b;
92− }
93−}
94−```
95−
96−Multiple argument functions can be introduced by wrapping the arguments in parentheses, and separating them with commas:
97−
98−```haskell
99−test1 = \(a, b) -> a + b
100−```
101−
102−which generates
103−
104−```javascript
105−function test1(a, b) {
106− return a + b;
107−}
108−```
109−
110−In the case of a function with no arguments, the parentheses may be omitted, as follows:
111−
112−```haskell
113−test2 = \ -> 100
114−```
115−
116−which would correspond to the Javascript `function test2() { return 100; }`
117−
118−Multiple-argument and single-argument syntax can be mixed, as follows:
119−
120−```haskell
121−test3 = \a (b, c) d -> a + b + c + d
122−```
123−
124−which generates
125−
126−```javascript
127−function test3(a) {
128− return function (b, c) {
129− return function (d) {
130− return a + b + c + d;
131− }
132− }
133−}
134−```
135−
136−Functions are applied by providing their arguments inside parentheses:
137−
138−```haskell
139−test1(1, 2, 3)
140−test2()
141−```
142−
143−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:
144−
145−```haskell
146−-- has type Number -> Number -> Number -> Number
147−addThree = \a b c -> a + b + c
148−
149−-- has type Number -> Number -> Number
150−addThree 1
151−
152−-- has type Number -> Number
153−addThree 1 2
154−
155−-- has type Number
156−addThree 1 2 3
157−```
158−
159−## Polymorphic Types
160−
161−Expressions defined at the top level may have polymorphic types.
162−
163−Here is an example:
164−
165−```haskell
166−identity x = x
167−```
168−
169−`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.
170−
171−A type annotation can also be provided:
172−
173−```haskell
174−identity :: forall a. a -> a
175−identity x = x
176−```
177−
178−Functions may also be polymorphic in row types or type variables with other kinds (see "Kind System"):
179−
180−```haskell
181−addProps o = o.foo + o.bar
182−```
183−
184−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*.
185−
186−So, the following compiles:
187−
188−```haskell
189−addProps { foo: 1, bar: 2, baz: 3 }
190−```
191−
192−but the following does not:
193−
194−```haskell
195−addProps { foo: 1 }
196−```
197−
198−since the `bar` property is missing.
199−
200−Again, a type annotation can be provided if necessary.
201−
202−## Rank N Types
203−
204−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.
205−
206−In most cases, a type annotation is necessary when using this feature.
207−
208−As an example, we can pass a polymorphic function as an argument to another function:
209−
210−```haskell
211−poly :: (forall a. a -> a) -> Boolean
212−poly f = (f 0 < 1) == f true
213−```
214−
215−Notice that the polymorphic function's type argument is instantiated to both `Number` and `Boolean`.
216−
217−An argument to `poly` must indeed be polymorphic. For example, the following fails:
218−
219−```haskell
220−test = poly (\n -> n + 1)
221−```
222−
223−since the skolemized type variable `a` does not unify with `Number`.
224−
225−## Type Inference
226−
227−All types can be inferred, but annotations can optionally be provided.
228−
229−## Kind System
230−
231−There are two primitive kinds, the kind `*` of types and the kind `!` of effects.
232−
233−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.
234−
235−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.
examples/.gitignoredeleted−1
@@ -1 +0,0 @@
1−shelltest/tests
examples/failing/Arrays.pursdeleted−3
@@ -1,3 +0,0 @@
1−module Arrays where
2−
3− test = \arr -> arr !! (0 !! 0)
examples/failing/Do.pursdeleted−10
@@ -1,10 +0,0 @@
1−module Do where
2−
3−id = { ret: \x -> x, bind: \x f -> f x }
4−
5−test1 = id do let x = 1
6−
7−test2 y = id do x <- y
8−
9−test3 = id do return 1
10− return 2
examples/failing/Import.pursdeleted−3
@@ -1,3 +0,0 @@
1−module Module where
2−
3− import UndefinedModule
examples/failing/KindError.pursdeleted−3
@@ -1,3 +0,0 @@
1−module KindError where
2−
3− data KindError f a = One f | Two f a
examples/failing/LocalVars.pursdeleted−6
@@ -1,6 +0,0 @@
1−module LocalVars where
2−
3− bad = \x -> {
4− x = x + 1;
5− return x;
6− }
examples/failing/PatternScope.pursdeleted−10
@@ -1,10 +0,0 @@
1−module PatternScope where
2−
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.pursdeleted−5
@@ -1,5 +0,0 @@
1−module Rank2Types where
2−
3− foreign import test :: (forall a. a -> a) -> Number
4−
5− test1 = test (\n -> n + 1)
examples/failing/ReadShow.pursdeleted−7
@@ -1,7 +0,0 @@
1−module ReadShow where
2−
3− foreign import read :: forall a. String -> a
4−
5− foreign import show :: forall a. a -> String
6−
7− test = \x -> show (read x)
examples/failing/SkolemEscape.pursdeleted−5
@@ -1,5 +0,0 @@
1−module SkolemEscape where
2−
3− foreign import foo :: (forall a. a -> a) -> Number
4−
5− test = \x -> foo x
examples/failing/TypeClasses.pursdeleted−7
@@ -1,7 +0,0 @@
1−module TypeClasses where
2−
3−class Show a where
4− show :: a -> String
5−
6−instance TypeClasses.Show ([[String]]) where
7− show _ = "array"
examples/failing/TypeClasses2.pursdeleted−15
@@ -1,15 +0,0 @@
1−module TC1 where
2−
3−class Show a where
4− show :: a -> String
5−
6−module TC2 where
7−
8−instance TC1.Show String where
9− show s = s
10−
11−module TC3 where
12−
13−import TC1
14−
15−test = show "testing"
examples/failing/TypeError.pursdeleted−3
@@ -1,3 +0,0 @@
1−module TypeError where
2−
3− test = x ++ "A"
examples/passing/ArrayType.pursdeleted−13
@@ -1,13 +0,0 @@
1−module ArrayType where
2−
3−test :: [] Number
4−test = [1, 2, 3]
5−
6−class Functor f where
7− fmap :: forall a b. (a -> b) -> f a -> f b
8−
9−foreign import (:) :: forall a. a -> [a] -> [a]
10−
11−instance Functor [] where
12− fmap _ [] = []
13− fmap f (x:xs) = f x : fmap f xs
examples/passing/Arrays.pursdeleted−21
@@ -1,21 +0,0 @@
1−module Arrays where
2−
3−test1 = \arr -> arr !! 0 + arr !! 1
4−
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.pursdeleted−9
@@ -1,9 +0,0 @@
1−module Assign where
2−
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.pursdeleted−11
@@ -1,11 +0,0 @@
1−module Auto where
2−
3− data Auto s i o = Auto { state :: s, step :: s -> i -> o }
4−
5− type SomeAuto i o = forall r. (forall s. Auto s i o -> r) -> r
6−
7− exists :: forall s i o. s -> (s -> i -> o) -> SomeAuto i o
8− exists = \state step f -> f (Auto { state: state, step: step })
9−
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.pursdeleted−14
@@ -1,14 +0,0 @@
1−module Church where
2−
3− type List a = forall r. r -> (a -> r -> r) -> r
4−
5− empty :: forall a. List a
6− empty = \r f -> r
7−
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.pursdeleted−7
@@ -1,7 +0,0 @@
1−module Conditional where
2−
3− fns = \f -> if f true then f else \x -> x
4−
5− bin = \x -> if x && !x then x else x
6−
7− not = \x -> if x then false else true
examples/passing/Cons.pursdeleted−9
@@ -1,9 +0,0 @@
1−module Cons where
2−
3− infixr 6 :
4−
5− foreign import (:) :: forall a. a -> [a] -> [a]
6−
7− test1 = \xs -> 1 : xs
8−
9− test2 = 1 : 2 : 3 : []
examples/passing/Console.pursdeleted−25
@@ -1,25 +0,0 @@
1−module Console where
2−
3− foreign import data IO :: * -> *
4−
5− foreign import ret :: forall a. a -> IO a
6−
7− foreign import (>>=) :: forall a b. IO a -> (a -> IO b) -> IO b
8−
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.pursdeleted−12
@@ -1,12 +0,0 @@
1−module M1 where
2−
3−data Test = Test
4−
5−module M2 where
6−
7−import M1
8−
9−test :: Test -> M1.Test
10−test t = t
11−
12−testCtor = Test
examples/passing/Do.pursdeleted−65
@@ -1,65 +0,0 @@
1−module Prelude where
2−
3−class Monad m where
4− ret :: forall a. a -> m a
5− (>>=) :: forall a b. m a -> (a -> m b) -> m b
6−
7−module Do where
8−
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.pursdeleted−12
@@ -1,12 +0,0 @@
1−module Dollar where
2−
3−($) :: forall a b. (a -> b) -> a -> b
4−($) f x = f x
5−
6−infixr 1000 $
7−
8−id x = x
9−
10−test1 x = id $ id $ id $ id $ x
11−
12−test2 x = id id $ id x
examples/passing/Eff.pursdeleted−71
@@ -1,71 +0,0 @@
1−module Prelude where
2−
3−class Monad m where
4− ret :: forall a. a -> m a
5− (>>=) :: forall a b. m a -> (a -> m b) -> m b
6−
7−module Eff where
8−
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.pursdeleted−15
@@ -1,15 +0,0 @@
1−module ExternData where
2−
3− foreign import data IO :: * -> *
4−
5− foreign import fmap :: forall a b. IO a -> (a -> b) -> IO b
6−
7− foreign import ret :: forall a. a -> IO a
8−
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.pursdeleted−13
@@ -1,13 +0,0 @@
1−module ExternRaw where
2−
3−foreign import first "function first(xs) { return xs[0]; }" :: forall a. [a] -> a
4−
5−foreign import cond "function cond(b, t, f) { return b ? t : f; }" :: forall a. (Boolean, a, a) -> a
6−
7−foreign import loop "function loop() { while (true) {} }" :: forall a. a
8−
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.pursdeleted−12
@@ -1,12 +0,0 @@
1−module FFI where
2−
3−foreign import foo :: String -> String
4−
5−bar :: String -> String
6−bar = \x -> foo (x ++ "bar")
7−
8−module FFIModuleTest where
9−
10−import FFI
11−
12−baz = foo "test"
examples/passing/Functions.pursdeleted−13
@@ -1,13 +0,0 @@
1−module Functions where
2−
3− test1 = \ -> 0
4−
5− test2 = \() -> 0
6−
7− test3 = \a (b, c) d -> a + b + c + d
8−
9− test4 = \(a) -> a
10−
11− test5 = \(%%) -> 1 %% 2
12−
13− test6 = \((+++), (***)) -> 1 +++ 2 *** 3
examples/passing/Guards.pursdeleted−10
@@ -1,10 +0,0 @@
1−module Guards where
2−
3− collatz = \x -> case x of
4− y | y % 2 == 0 -> y / 2
5− y -> y * 3 + 1
6−
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.pursdeleted−36
@@ -1,36 +0,0 @@
1−module IfThenElse where
2−
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.pursdeleted−12
@@ -1,12 +0,0 @@
1−module M1 where
2−
3− id :: forall a. a -> a
4− id = \x -> x
5−
6− foo = id
7−
8−module M2 where
9−
10− import M1
11−
12− main = \() -> foo 42
examples/passing/List.pursdeleted−21
@@ -1,21 +0,0 @@
1−module List where
2−
3− data List a
4− = Nil
5− | Cons
6− { head :: a
7− , tail :: List a
8− }
9−
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.pursdeleted−5
@@ -1,5 +0,0 @@
1−module Match where
2−
3− data Foo a = Foo
4−
5− foo = \f -> case f of Foo -> "foo"
examples/passing/Maybe.pursdeleted−11
@@ -1,11 +0,0 @@
1−module Maybe where
2−
3− data Maybe a = Nothing | Just a
4−
5− maybe :: forall a b. b -> (a -> b) -> Maybe a -> b
6− maybe b _ Nothing = b
7− maybe _ f (Just a) = f a
8−
9− fmap m f = maybe Nothing (\a -> Just (f a)) m
10−
11− bind m f = maybe Nothing f m
examples/passing/Module.pursdeleted−20
@@ -1,20 +0,0 @@
1−module M1 where
2−
3− data Foo = Foo String
4−
5− foo :: M1.Foo -> String
6− foo = \f -> case f of Foo s -> s ++ "foo"
7−
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.pursdeleted−28
@@ -1,28 +0,0 @@
1−module Monad where
2−
3− type Monad m = { ret :: forall a. a -> m a
4− , bind :: forall a b. m a -> (a -> m b) -> m b }
5−
6− data Id a = Id a
7−
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.pursdeleted−15
@@ -1,15 +0,0 @@
1−module MutRec where
2−
3− f 0 = 0
4− f x = g x + 1
5−
6− g x = f (x / 2)
7−
8− data Even = Zero | Even Odd
9−
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.pursdeleted−5
@@ -1,5 +0,0 @@
1−module NamedPatterns where
2−
3− foo = \x -> case x of
4− y@{ foo = "Foo" } -> y
5− y -> y
examples/passing/Nested.pursdeleted−5
@@ -1,5 +0,0 @@
1−module Nested where
2−
3− data Extend r a = Extend { prev :: r a, next :: a }
4−
5− data Matrix r a = Square (r (r a)) | Bigger (Matrix (Extend r) a)
examples/passing/ObjectUpdate.pursdeleted−16
@@ -1,16 +0,0 @@
1−module ObjectUpdate where
2−
3− update1 = \o -> o { foo = "Foo" }
4−
5− update2 :: forall r. { foo :: String | r } -> { foo :: String | r }
6− update2 = \o -> o { foo = "Foo" }
7−
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.pursdeleted−14
@@ -1,14 +0,0 @@
1−module Objects where
2−
3− test = \x -> x.foo + x.bar
4−
5− append = \o -> { foo: o.foo, bar: 1 }
6−
7− apTest = append({foo : "Foo", baz: "Baz"})
8−
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/OneConstructor.pursdeleted−5
@@ -1,5 +0,0 @@
1−module OneConstructor where
2−
3−data One a = One a
4−
5−one (One a) = a
examples/passing/Operators.pursdeleted−46
@@ -1,46 +0,0 @@
1−module Operators1 where
2−
3− (@@) :: forall a b. (a -> b) -> a -> b
4− (@@) = \f x -> f x
5−
6− foo :: String -> String
7− foo = \s -> s
8−
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]
45−
46− test12 (<%>) a b = a <%> b
examples/passing/OptimizerBug.pursdeleted−5
@@ -1,5 +0,0 @@
1−module OptimizerBug where
2−
3−x = 1 + y
4−
5−y = x
examples/passing/Patterns.pursdeleted−25
@@ -1,25 +0,0 @@
1−module Patterns where
2−
3− test = \x -> case x of
4− { str = "Foo", bool = true } -> true
5− { str = "Bar", bool = b } -> b
6− _ -> false
7−
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.pursdeleted−9
@@ -1,9 +0,0 @@
1−module Person where
2−
3− data Person = Person { name :: String, age :: Number }
4−
5− foreign import itoa :: Number -> String
6−
7− showPerson :: Person -> String
8− showPerson = \p -> case p of
9− Person o -> o.name ++ ", aged " ++ itoa(o.age)
examples/passing/Rank2Data.pursdeleted−25
@@ -1,25 +0,0 @@
1−module Rank2Data where
2−
3− data Id = Id forall a. a -> a
4−
5− runId = \id a -> case id of
6− Id f -> f a
7−
8− data Nat = Nat forall r. r -> (r -> r) -> r
9−
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.pursdeleted−19
@@ -1,19 +0,0 @@
1−module Rank2Types where
2−
3− test1 :: (forall a. (a -> a)) -> Number
4− test1 = \f -> f 0
5−
6− foreign import data ST :: * -> * -> *
7−
8− foreign import runST :: forall a. (forall s. ST s a) -> a
9−
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.pursdeleted−6
@@ -1,6 +0,0 @@
1−module Recursion where
2−
3− fib = \n -> case n of
4− 0 -> 1
5− 1 -> 1
6− n -> fib (n - 1) + fib (n - 2)
examples/passing/RedefinedFixity.pursdeleted−14
@@ -1,14 +0,0 @@
1−module M1 where
2−
3−($) f a = f a
4−
5−infixr 1000 $
6−
7−module M2 where
8−
9−import M1
10−
11−module M3 where
12−
13−import M1
14−import M2
examples/passing/TailCall.pursdeleted−10
@@ -1,10 +0,0 @@
1−module TailCall where
2−
3−test n [] = n
4−test n (x:xs) = test (n + x) xs
5−
6−loop x = loop (x + 1)
7−
8−notATailCall = \x ->
9− (\notATailCall -> notATailCall x) (\x -> x)
10−
examples/passing/TopLevelCase.pursdeleted−14
@@ -1,14 +0,0 @@
1−module TopLevelCase where
2−
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)
8−
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.pursdeleted−52
@@ -1,52 +0,0 @@
1−module TypeClasses where
2−
3−class Show a where
4− show :: a -> String
5−
6−instance Show String where
7− show s = s
8−
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−import TypeClasses
46−
47−instance (TypeClasses.Show a) => TypeClasses.Show [a] where
48− show [] = "[]"
49− show (x:xs) = TypeClasses.show x ++ ", " ++ TypeClasses.show xs
50−
51−test6 = show ["testing"]
52−
examples/passing/TypeDecl.pursdeleted−16
@@ -1,16 +0,0 @@
1−module TypeDecl where
2−
3− id :: forall a. (a) -> a
4− id = \x -> x
5−
6− k :: String -> Number -> String
7− k = \x -> \y -> x
8−
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.pursdeleted−33
@@ -1,33 +0,0 @@
1−module TypeSynonyms where
2−
3− type Lens a b =
4− { get :: a -> b
5− , set :: a -> b -> a
6− }
7−
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.pursdeleted−7
@@ -1,7 +0,0 @@
1−module Iota where
2−
3− s = \x -> \y -> \z -> x z (y z)
4−
5− k = \x -> \y -> x
6−
7− iota = \x -> x s k
examples/passing/s.pursdeleted−3
@@ -1,3 +0,0 @@
1−module S where
2−
3− s = \x y z -> x z (y z)
examples/shelltest/Console.jsdeleted−19
@@ -1,19 +0,0 @@
1−// data IO a = \ -> a
2−
3−// ret :: forall a. a -> IO a
4−var ret = function(a) {
5− return function() { return a; };
6−}
7−
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.jsdeleted−7
@@ -1,7 +0,0 @@
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.jsdeleted−5
@@ -1,5 +0,0 @@
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.testdeleted−16
@@ -1,16 +0,0 @@
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
8−
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.jsdeleted−1
@@ -1 +0,0 @@
1−main();
libraries/.gitignoredeleted−1
@@ -1 +0,0 @@
1−*/all.js
libraries/jquery/jquery.pursdeleted−45
@@ -1,45 +0,0 @@
1−module JQuery where
2−
3− import Eff
4−
5− -- An effect type which indicates DOM manipulation
6− foreign import data DOM :: !
7−
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/.gitignoredeleted−1
@@ -1 +0,0 @@
1−jquery.js
libraries/jquery/tests/build.shdeleted−2
@@ -1,2 +0,0 @@
1−psc ../jquery.purs jquery.purs --magic-do --run-main -o jquery.js
2−
libraries/jquery/tests/index.htmldeleted−10
@@ -1,10 +0,0 @@
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.pursdeleted−28
@@ -1,28 +0,0 @@
1−module Main where
2−
3−import Prelude
4−import Eff
5−import Trace
6−import JQuery
7−
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/Makefiledeleted−3
@@ -1,3 +0,0 @@
1−all:
2− ../../dist/build/psc/psc --no-prelude prelude.purs -o all.js
3− cat prelude.js >> all.js
libraries/prelude/prelude.jsdeleted−42
@@ -1,42 +0,0 @@
1−// Arrays
2−
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.pursdeleted−349
@@ -1,349 +0,0 @@
1−module Prelude where
2−
3− id :: forall a. a -> a
4− id = \x -> x
5−
6− flip :: forall a b c. (a -> b -> c) -> b -> a -> c
7− flip = \f -> \b -> \a -> f a b
8−
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 Prelude
325− import Eff
326−
327− foreign import data Trace :: !
328−
329− foreign import trace "function trace(s) { return function() { console.log(s); return {}; }; }" :: forall r. String -> Eff (trace :: Trace | r) {}
330−
331− print :: forall a r. (Prelude.Show a) => a -> Eff (trace :: Trace | r) {}
332− print o = trace (show o)
333−
334−module ST where
335−
336− import Eff
337−
338− foreign import data ST :: * -> !
339−
340− foreign import data STRef :: * -> * -> *
341−
342− foreign import newSTRef :: forall a h r. a -> Eff (st :: ST h | r) (STRef h a)
343−
344− foreign import readSTRef :: forall a h r. STRef h a -> Eff (st :: ST h | r) a
345−
346− foreign import modifySTRef :: forall a h r. (a -> a) -> STRef h a -> Eff (st :: ST h | r) {}
347−
348− foreign import runST :: forall a r. (forall h. Eff (st :: ST h | r) a) -> Eff r a
349−
libraries/prelude/tests/Eff.pursdeleted−41
@@ -1,41 +0,0 @@
1−module Tests where
2−
3−import Prelude
4−import Eff
5−import Errors
6−import Trace
7−
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.yamlnew file+86
@@ -0,0 +1,86 @@
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.hsdeleted−116
@@ -1,116 +0,0 @@
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.hsdeleted−146
@@ -1,146 +0,0 @@
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.cabalnew file+145
@@ -0,0 +1,145 @@
1+cabal-version: 1.12
2+
3+-- This file has been generated from package.yaml by hpack version 0.35.0.
4+--
5+-- see: https://github.com/sol/hpack
6+
7+name: psgo
8+version: 0.1.0.0
9+description: Please see the README on Github at <https://github.com/andyarvanitis/purescript-native#readme>
10+homepage: https://github.com/andyarvanitis/purescript-native#readme
11+bug-reports: https://github.com/andyarvanitis/purescript-native/issues
12+author: Andy Arvanitis
13+maintainer: example@example.com
14+copyright: 2018 Andy Arvanitis
15+license: BSD3
16+license-file: LICENSE
17+build-type: Simple
18+extra-source-files:
19+ README.md
20+ ChangeLog.md
21+ stack.yaml
22+ support/ffi-loader.go
23+ support/go.mod.ffi-loader
24+ support/go.mod.output
25+ support/go.mod.working
26+
27+source-repository head
28+ type: git
29+ location: https://github.com/andyarvanitis/purescript-native
30+
31+library
32+ exposed-modules:
33+ CodeGen.IL
34+ CodeGen.IL.Common
35+ CodeGen.IL.Optimizer
36+ CodeGen.IL.Optimizer.Common
37+ CodeGen.IL.Optimizer.Inliner
38+ CodeGen.IL.Optimizer.MagicDo
39+ CodeGen.IL.Optimizer.TCO
40+ CodeGen.IL.Printer
41+ Tests
42+ other-modules:
43+ Paths_psgo
44+ hs-source-dirs:
45+ src
46+ default-extensions:
47+ ConstraintKinds
48+ DataKinds
49+ DeriveFunctor
50+ EmptyDataDecls
51+ FlexibleContexts
52+ KindSignatures
53+ LambdaCase
54+ MultiParamTypeClasses
55+ NoImplicitPrelude
56+ PatternGuards
57+ PatternSynonyms
58+ RankNTypes
59+ RecordWildCards
60+ OverloadedStrings
61+ ScopedTypeVariables
62+ TupleSections
63+ ViewPatterns
64+ build-depends:
65+ aeson >=1.0 && <1.5
66+ , base >=4.7 && <5
67+ , base-compat >=0.6.0
68+ , bytestring >=0.10.8.2 && <0.11
69+ , containers
70+ , directory
71+ , file-embed
72+ , filemanip
73+ , filepath
74+ , gitrev
75+ , monad-parallel >=0.7.2.2 && <0.8
76+ , mtl >=2.1.0 && <2.3.0
77+ , pattern-arrows >=0.0.2 && <0.1
78+ , process
79+ , protolude >=0.1.6
80+ , purescript
81+ , safe >=0.3.9 && <0.4
82+ , text
83+ , transformers >=0.3.0 && <0.6
84+ default-language: Haskell2010
85+
86+executable psgo
87+ main-is: Main.hs
88+ other-modules:
89+ Paths_psgo
90+ hs-source-dirs:
91+ app
92+ ghc-options: -threaded -rtsopts -with-rtsopts=-N
93+ build-depends:
94+ aeson >=1.0 && <1.5
95+ , base >=4.7 && <5
96+ , base-compat >=0.6.0
97+ , bytestring >=0.10.8.2 && <0.11
98+ , containers
99+ , directory
100+ , file-embed
101+ , filemanip
102+ , filepath
103+ , gitrev
104+ , monad-parallel >=0.7.2.2 && <0.8
105+ , mtl >=2.1.0 && <2.3.0
106+ , pattern-arrows >=0.0.2 && <0.1
107+ , process
108+ , protolude >=0.1.6
109+ , psgo
110+ , purescript
111+ , safe >=0.3.9 && <0.4
112+ , text
113+ , transformers >=0.3.0 && <0.6
114+ default-language: Haskell2010
115+
116+test-suite psgo-test
117+ type: exitcode-stdio-1.0
118+ main-is: Spec.hs
119+ other-modules:
120+ Paths_psgo
121+ hs-source-dirs:
122+ test
123+ ghc-options: -threaded -rtsopts -with-rtsopts=-N
124+ build-depends:
125+ aeson >=1.0 && <1.5
126+ , base >=4.7 && <5
127+ , base-compat >=0.6.0
128+ , bytestring >=0.10.8.2 && <0.11
129+ , containers
130+ , directory
131+ , file-embed
132+ , filemanip
133+ , filepath
134+ , gitrev
135+ , monad-parallel >=0.7.2.2 && <0.8
136+ , mtl >=2.1.0 && <2.3.0
137+ , pattern-arrows >=0.0.2 && <0.1
138+ , process
139+ , protolude >=0.1.6
140+ , psgo
141+ , purescript
142+ , safe >=0.3.9 && <0.4
143+ , text
144+ , transformers >=0.3.0 && <0.6
145+ default-language: Haskell2010
purescript.cabaldeleted−95
@@ -1,95 +0,0 @@
1−name: purescript
2−version: 0.3.2
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
src/CodeGen/IL.hsnew file+321
@@ -0,0 +1,321 @@
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.hsnew file+196
@@ -0,0 +1,196 @@
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.hsnew file+81
@@ -0,0 +1,81 @@
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.hsnew file+18
@@ -0,0 +1,18 @@
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.hsnew file+435
@@ -0,0 +1,435 @@
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.hsnew file+146
@@ -0,0 +1,146 @@
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.hsnew file+141
@@ -0,0 +1,141 @@
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.hsnew file+527
@@ -0,0 +1,527 @@
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.hsdeleted−24
@@ -1,24 +0,0 @@
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.hsdeleted−47
@@ -1,47 +0,0 @@
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.hsdeleted−19
@@ -1,19 +0,0 @@
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.hsdeleted−47
@@ -1,47 +0,0 @@
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.hsdeleted−265
@@ -1,265 +0,0 @@
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−{-# LANGUAGE DoAndIfThenElse #-}
16−
17−module Language.PureScript.CodeGen.JS (
18− module AST,
19− declToJs,
20− moduleToJs
21−) where
22−
23−import Data.Maybe (fromMaybe, mapMaybe)
24−import Data.List (sortBy)
25−import Data.Function (on)
26−
27−import Control.Arrow (second)
28−import Control.Monad (replicateM, forM)
29−
30−import qualified Data.Map as M
31−
32−import Language.PureScript.TypeChecker (Environment(..), NameKind(..))
33−import Language.PureScript.Values
34−import Language.PureScript.Names
35−import Language.PureScript.Scope
36−import Language.PureScript.Declarations
37−import Language.PureScript.Pretty.Common
38−import Language.PureScript.CodeGen.Monad
39−import Language.PureScript.Options
40−import Language.PureScript.CodeGen.JS.AST as AST
41−import Language.PureScript.Types
42−import Language.PureScript.CodeGen.Optimize
43−
44−moduleToJs :: Options -> Module -> Environment -> [JS]
45−moduleToJs opts (Module pname@(ProperName name) decls) env =
46− mapMaybe filterRawDecls decls ++
47− [ JSVariableIntroduction (Ident name) Nothing
48− , JSApp (JSFunction Nothing [Ident name]
49− (JSBlock (concat $ mapMaybe (\decl -> fmap (map $ optimize opts) $ declToJs opts (ModuleName pname) decl env) (sortBy typeClassesLast decls))))
50− [JSAssignment (JSAssignVariable (Ident name))
51− (JSBinary Or (JSVar (Ident name)) (JSObjectLiteral []))]
52− ]
53− where
54− filterRawDecls (ExternDeclaration ForeignImport _ (Just js) _) = Just js
55− filterRawDecls _ = Nothing
56− typeClassesLast (ExternDeclaration TypeClassDictionaryImport _ _ _) (ExternDeclaration TypeClassDictionaryImport _ _ _) = EQ
57− typeClassesLast (ExternDeclaration TypeClassDictionaryImport _ _ _) _ = GT
58− typeClassesLast _ (ExternDeclaration TypeClassDictionaryImport _ _ _) = LT
59− typeClassesLast _ _ = EQ
60−
61−declToJs :: Options -> ModuleName -> Declaration -> Environment -> Maybe [JS]
62−declToJs opts mp (ValueDeclaration ident _ _ val) e =
63− Just [ JSVariableIntroduction ident (Just (valueToJs opts mp e val)),
64− setProperty (identToJs ident) (JSVar ident) mp ]
65−declToJs opts mp (BindingGroupDeclaration vals) e =
66− Just $ concatMap (\(ident, val) ->
67− [ JSVariableIntroduction ident (Just (valueToJs opts mp e val)),
68− setProperty (identToJs ident) (JSVar ident) mp ]
69− ) vals
70−declToJs _ mp (DataDeclaration _ _ ctors) _ =
71− Just $ flip concatMap ctors $ \(pn@(ProperName ctor), maybeTy) ->
72− let
73− ctorJs =
74− case maybeTy of
75− Nothing -> JSVariableIntroduction (Ident ctor) (Just (JSObjectLiteral [ ("ctor", JSStringLiteral (show (Qualified (Just mp) pn))) ]))
76− Just _ -> JSFunction (Just (Ident ctor)) [Ident "value"]
77− (JSBlock [JSReturn
78− (JSObjectLiteral [ ("ctor", JSStringLiteral (show (Qualified (Just mp) pn)))
79− , ("value", JSVar (Ident "value")) ])])
80− in [ ctorJs, setProperty ctor (JSVar (Ident ctor)) mp ]
81−declToJs _ mp (ExternDeclaration importTy ident (Just js) _) _ | importTy /= ForeignImport =
82− Just [ js
83− , setProperty (identToJs ident) (JSVar ident) mp ]
84−declToJs _ _ _ _ = Nothing
85−
86−setProperty :: String -> JS -> ModuleName -> JS
87−setProperty prop val (ModuleName (ProperName moduleName)) = JSAssignment (JSAssignProperty prop (JSAssignVariable (Ident moduleName))) val
88−
89−valueToJs :: Options -> ModuleName -> Environment -> Value -> JS
90−valueToJs _ _ _ (NumericLiteral n) = JSNumericLiteral n
91−valueToJs _ _ _ (StringLiteral s) = JSStringLiteral s
92−valueToJs _ _ _ (BooleanLiteral b) = JSBooleanLiteral b
93−valueToJs opts m e (ArrayLiteral xs) = JSArrayLiteral (map (valueToJs opts m e) xs)
94−valueToJs opts m e (ObjectLiteral ps) = JSObjectLiteral (map (second (valueToJs opts m e)) ps)
95−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)]
96−valueToJs _ m e (Constructor (Qualified Nothing name)) =
97− case M.lookup (m, name) (dataConstructors e) of
98− Just (_, Alias aliasModule aliasIdent) -> qualifiedToJS identToJs (Qualified (Just aliasModule) aliasIdent)
99− _ -> JSVar . Ident . runProperName $ name
100−valueToJs _ _ _ (Constructor name) = qualifiedToJS runProperName name
101−valueToJs opts m e (Block sts) = JSApp (JSFunction Nothing [] (JSBlock (map (statementToJs opts m e) sts))) []
102−valueToJs opts m e (Case values binders) = bindersToJs opts m e binders (map (valueToJs opts m e) values)
103−valueToJs opts m e (IfThenElse cond th el) = JSConditional (valueToJs opts m e cond) (valueToJs opts m e th) (valueToJs opts m e el)
104−valueToJs opts m e (Accessor prop val) = JSAccessor prop (valueToJs opts m e val)
105−valueToJs opts m e (Indexer index val) = JSIndexer (valueToJs opts m e index) (valueToJs opts m e val)
106−valueToJs opts m e (App val args) = JSApp (valueToJs opts m e val) (map (valueToJs opts m e) args)
107−valueToJs opts m e (Abs args val) = JSFunction Nothing args (JSBlock [JSReturn (valueToJs opts m e val)])
108−valueToJs opts m e (TypedValue _ (Abs args val) ty) | optionsPerformRuntimeTypeChecks opts = JSFunction Nothing args (JSBlock $ runtimeTypeChecks args ty ++ [JSReturn (valueToJs opts m e val)])
109−valueToJs opts m e (Unary op val) = JSUnary op (valueToJs opts m e val)
110−valueToJs opts m e (Binary op v1 v2) = JSBinary op (valueToJs opts m e v1) (valueToJs opts m e v2)
111−valueToJs _ m e (Var ident) = varToJs m e ident
112−valueToJs opts m e (TypedValue _ val _) = valueToJs opts m e val
113−valueToJs _ _ _ (TypeClassDictionary _ _) = error "Type class dictionary was not replaced"
114−valueToJs _ _ _ _ = error "Invalid argument to valueToJs"
115−
116−runtimeTypeChecks :: [Ident] -> Type -> [JS]
117−runtimeTypeChecks args ty =
118− let
119− argTys = getFunctionArgumentTypes ty
120− in
121− concat $ zipWith argumentCheck (map JSVar args) argTys
122− where
123− getFunctionArgumentTypes :: Type -> [Type]
124− getFunctionArgumentTypes (Function funArgs _) = funArgs
125− getFunctionArgumentTypes (ForAll _ ty') = getFunctionArgumentTypes ty'
126− getFunctionArgumentTypes _ = []
127− argumentCheck :: JS -> Type -> [JS]
128− argumentCheck val Number = [typeCheck val "number"]
129− argumentCheck val String = [typeCheck val "string"]
130− argumentCheck val Boolean = [typeCheck val "boolean"]
131− argumentCheck val (TypeApp Array _) = [arrayCheck val]
132− argumentCheck val (Object row) =
133− let
134− (pairs, _) = rowToList row
135− in
136− typeCheck val "object" : concatMap (\(prop, ty') -> argumentCheck (JSAccessor prop val) ty') pairs
137− argumentCheck val (Function _ _) = [typeCheck val "function"]
138− argumentCheck val (ForAll _ ty') = argumentCheck val ty'
139− argumentCheck _ _ = []
140− typeCheck :: JS -> String -> JS
141− typeCheck js ty' = JSIfElse (JSBinary NotEqualTo (JSTypeOf js) (JSStringLiteral ty')) (JSBlock [JSThrow (JSStringLiteral $ ty' ++ " expected")]) Nothing
142− arrayCheck :: JS -> JS
143− arrayCheck js = JSIfElse (JSUnary Not (JSApp (JSAccessor "isArray" (JSVar (Ident "Array"))) [js])) (JSBlock [JSThrow (JSStringLiteral "Array expected")]) Nothing
144−
145−varToJs :: ModuleName -> Environment -> Qualified Ident -> JS
146−varToJs m e qual@(Qualified _ ident) = case M.lookup (qualify m qual) (names e) of
147− Just (_, ty) | isExtern ty -> JSVar ident
148− Just (_, Alias aliasModule aliasIdent) -> qualifiedToJS identToJs (Qualified (Just aliasModule) aliasIdent)
149− _ -> case qual of
150− Qualified Nothing _ -> JSVar ident
151− _ -> qualifiedToJS identToJs qual
152− where
153− isExtern (Extern ForeignImport) = True
154− isExtern (Alias m' ident') = case M.lookup (m', ident') (names e) of
155− Just (_, ty') -> isExtern ty'
156− Nothing -> error "Undefined alias in varToJs"
157− isExtern _ = False
158−
159−qualifiedToJS :: (a -> String) -> Qualified a -> JS
160−qualifiedToJS f (Qualified (Just (ModuleName (ProperName m))) a) = JSAccessor (f a) (JSVar (Ident m))
161−qualifiedToJS f (Qualified Nothing a) = JSVar (Ident (f a))
162−
163−bindersToJs :: Options -> ModuleName -> Environment -> [([Binder], Maybe Guard, Value)] -> [JS] -> JS
164−bindersToJs opts m e binders vals = runGen (unusedNames (binders, vals)) $ do
165− valNames <- replicateM (length vals) fresh
166− jss <- forM binders $ \(bs, grd, result) -> go valNames [JSReturn (valueToJs opts m e result)] bs grd
167− return $ JSApp (JSFunction Nothing valNames (JSBlock (concat jss ++ [JSThrow (JSStringLiteral "Failed pattern match")])))
168− vals
169− where
170− go :: [Ident] -> [JS] -> [Binder] -> Maybe Guard -> Gen [JS]
171− go _ done [] Nothing = return done
172− go _ done [] (Just cond) = return [JSIfElse (valueToJs opts m e cond) (JSBlock done) Nothing]
173− go (v:vs) done' (b:bs) grd = do
174− done'' <- go vs done' bs grd
175− binderToJs m e v done'' b
176− go _ _ _ _ = error "Invalid arguments to bindersToJs"
177−
178−binderToJs :: ModuleName -> Environment -> Ident -> [JS] -> Binder -> Gen [JS]
179−binderToJs _ _ _ done NullBinder = return done
180−binderToJs _ _ varName done (StringBinder str) =
181− return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSStringLiteral str)) (JSBlock done) Nothing]
182−binderToJs _ _ varName done (NumberBinder num) =
183− return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSNumericLiteral num)) (JSBlock done) Nothing]
184−binderToJs _ _ varName done (BooleanBinder True) =
185− return [JSIfElse (JSVar varName) (JSBlock done) Nothing]
186−binderToJs _ _ varName done (BooleanBinder False) =
187− return [JSIfElse (JSUnary Not (JSVar varName)) (JSBlock done) Nothing]
188−binderToJs _ _ varName done (VarBinder ident) =
189− return (JSVariableIntroduction ident (Just (JSVar varName)) : done)
190−binderToJs m e varName done (NullaryBinder ctor) =
191− if isOnlyConstructor m e ctor
192− then
193− return done
194− else
195− return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar varName)) (JSStringLiteral (show ((\(mp, nm) -> Qualified (Just mp) nm) $ qualify m ctor)))) (JSBlock done) Nothing]
196−binderToJs m e varName done (UnaryBinder ctor b) = do
197− value <- fresh
198− js <- binderToJs m e value done b
199− let success = JSBlock (JSVariableIntroduction value (Just (JSAccessor "value" (JSVar varName))) : js)
200− if isOnlyConstructor m e ctor
201− then
202− return [success]
203− else
204− return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar varName)) (JSStringLiteral (show ((\(mp, nm) -> Qualified (Just mp) nm) $ qualify m ctor))))
205− success
206− Nothing]
207−binderToJs m e varName done (ObjectBinder bs) = go done bs
208− where
209− go :: [JS] -> [(String, Binder)] -> Gen [JS]
210− go done' [] = return done'
211− go done' ((prop, binder):bs') = do
212− propVar <- fresh
213− done'' <- go done' bs'
214− js <- binderToJs m e propVar done'' binder
215− return (JSVariableIntroduction propVar (Just (JSAccessor prop (JSVar varName))) : js)
216−binderToJs m e varName done (ArrayBinder bs) = do
217− js <- go done 0 bs
218− return [JSIfElse (JSBinary EqualTo (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (Left (fromIntegral $ length bs)))) (JSBlock js) Nothing]
219− where
220− go :: [JS] -> Integer -> [Binder] -> Gen [JS]
221− go done' _ [] = return done'
222− go done' index (binder:bs') = do
223− elVar <- fresh
224− done'' <- go done' (index + 1) bs'
225− js <- binderToJs m e elVar done'' binder
226− return (JSVariableIntroduction elVar (Just (JSIndexer (JSNumericLiteral (Left index)) (JSVar varName))) : js)
227−binderToJs m e varName done (ConsBinder headBinder tailBinder) = do
228− headVar <- fresh
229− tailVar <- fresh
230− js1 <- binderToJs m e headVar done headBinder
231− js2 <- binderToJs m e tailVar js1 tailBinder
232− return [JSIfElse (JSBinary GreaterThan (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (Left 0))) (JSBlock
233− ( JSVariableIntroduction headVar (Just (JSIndexer (JSNumericLiteral (Left 0)) (JSVar varName))) :
234− JSVariableIntroduction tailVar (Just (JSApp (JSAccessor "slice" (JSVar varName)) [JSNumericLiteral (Left 1)])) :
235− js2
236− )) Nothing]
237−binderToJs m e varName done (NamedBinder ident binder) = do
238− js <- binderToJs m e varName done binder
239− return (JSVariableIntroduction ident (Just (JSVar varName)) : js)
240−
241−isOnlyConstructor :: ModuleName -> Environment -> Qualified ProperName -> Bool
242−isOnlyConstructor m e ctor =
243− let (ty, _) = fromMaybe (error "Data constructor not found") $ qualify m ctor `M.lookup` dataConstructors e
244− in numConstructors ty == 1
245− where
246− numConstructors ty = length $ filter (\(ty1, _) -> ((==) `on` typeConstructor) ty ty1) $ M.elems $ dataConstructors e
247− typeConstructor (TypeConstructor qual) = qualify m qual
248− typeConstructor (ForAll _ ty) = typeConstructor ty
249− typeConstructor (Function _ ty) = typeConstructor ty
250− typeConstructor (TypeApp ty _) = typeConstructor ty
251− typeConstructor fn = error $ "Invalid arguments to typeConstructor: " ++ show fn
252−
253−statementToJs :: Options -> ModuleName -> Environment -> Statement -> JS
254−statementToJs opts m e (VariableIntroduction ident value) = JSVariableIntroduction ident (Just (valueToJs opts m e value))
255−statementToJs opts m e (Assignment target value) = JSAssignment (JSAssignVariable target) (valueToJs opts m e value)
256−statementToJs opts m e (While cond sts) = JSWhile (valueToJs opts m e cond) (JSBlock (map (statementToJs opts m e) sts))
257−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))
258−statementToJs opts m e (If ifst) = ifToJs ifst
259− where
260− ifToJs :: IfStatement -> JS
261− ifToJs (IfStatement cond thens elses) = JSIfElse (valueToJs opts m e cond) (JSBlock (map (statementToJs opts m e) thens)) (fmap elseToJs elses)
262− elseToJs :: ElseStatement -> JS
263− elseToJs (Else sts) = JSBlock (map (statementToJs opts m e) sts)
264− elseToJs (ElseIf elif) = ifToJs elif
265−statementToJs opts m e (Return value) = JSReturn (valueToJs opts m e value)
src/Language/PureScript/CodeGen/JS/AST.hsdeleted−56
@@ -1,56 +0,0 @@
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.hsdeleted−32
@@ -1,32 +0,0 @@
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.hsdeleted−251
@@ -1,251 +0,0 @@
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−import Language.PureScript.Pretty.Common (identToJs)
27−import Language.PureScript.Sugar.TypeClasses
28− (mkDictionaryValueName)
29−import Language.PureScript.Types (Type(..))
30−
31−optimize :: Options -> JS -> JS
32−optimize opts =
33− collapseNestedBlocks
34− . tco opts
35− . magicDo opts
36− . removeUnusedVariables
37− . unThunk
38− . etaConvert
39− . inlineVariables
40−
41−replaceIdent :: (Data d) => Ident -> JS -> d -> d
42−replaceIdent var1 js = everywhere (mkT replace)
43− where
44− replace (JSVar var2) | var1 == var2 = js
45− replace other = other
46−
47−replaceIdents :: (Data d) => [(Ident, JS)] -> d -> d
48−replaceIdents vars = everywhere (mkT replace)
49− where
50− replace v@(JSVar var) = fromMaybe v $ lookup var vars
51− replace other = other
52−
53−isReassigned :: (Data d) => Ident -> d -> Bool
54−isReassigned var1 = everything (||) (mkQ False check)
55− where
56− check :: JS -> Bool
57− check (JSFunction _ args _) | var1 `elem` args = True
58− check _ = False
59−
60−isRebound :: (Data d) => JS -> d -> Bool
61−isRebound (JSVar var1) = everything (||) (mkQ False check)
62− where
63− check :: JS -> Bool
64− check (JSFunction _ args _) | var1 `elem` args = True
65− check _ = False
66−isRebound _ = const False
67−
68−isUsed :: (Data d) => Ident -> d -> Bool
69−isUsed var1 = everything (||) (mkQ False check)
70− where
71− check :: JS -> Bool
72− check (JSVar var2) | var1 == var2 = True
73− check (JSAssignment target _) | var1 == targetVariable target = True
74− check _ = False
75− targetVariable :: JSAssignment -> Ident
76− targetVariable (JSAssignVariable var) = var
77− targetVariable (JSAssignProperty _ tgt) = targetVariable tgt
78−
79−shouldInline :: JS -> Bool
80−shouldInline (JSVar _) = True
81−shouldInline (JSNumericLiteral _) = True
82−shouldInline (JSStringLiteral _) = True
83−shouldInline (JSBooleanLiteral _) = True
84−shouldInline (JSAccessor _ val) = shouldInline val
85−shouldInline (JSIndexer index val) = shouldInline index && shouldInline val
86−shouldInline _ = False
87−
88−inlineVariables :: JS -> JS
89−inlineVariables = everywhere (mkT removeFromBlock)
90− where
91− removeFromBlock :: JS -> JS
92− removeFromBlock (JSBlock sts) = JSBlock (go sts)
93− removeFromBlock js = js
94− go :: [JS] -> [JS]
95− go [] = []
96− go (JSVariableIntroduction var (Just js) : sts) | shouldInline js && not (isReassigned var sts) && not (isRebound js sts) = go (replaceIdent var js sts)
97− go (s:sts) = s : go sts
98−
99−removeUnusedVariables :: JS -> JS
100−removeUnusedVariables = everywhere (mkT removeFromBlock)
101− where
102− removeFromBlock :: JS -> JS
103− removeFromBlock (JSBlock sts) = JSBlock (go sts)
104− removeFromBlock js = js
105− go :: [JS] -> [JS]
106− go [] = []
107− go (JSVariableIntroduction var _ : sts) | not (isUsed var sts) = go sts
108− go (s:sts) = s : go sts
109−
110−etaConvert :: JS -> JS
111−etaConvert = everywhere (mkT convert)
112− where
113− convert :: JS -> JS
114− convert (JSBlock [JSReturn (JSApp (JSFunction Nothing idents block@(JSBlock body)) args)])
115− | all shouldInline args && not (or (map (flip isRebound block) args)) = JSBlock (replaceIdents (zip idents args) body)
116− convert js = js
117−
118−unThunk :: JS -> JS
119−unThunk = everywhere (mkT convert)
120− where
121− convert :: JS -> JS
122− convert (JSBlock [JSReturn (JSApp (JSFunction Nothing [] (JSBlock body)) [])]) = JSBlock body
123− convert js = js
124−
125−tco :: Options -> JS -> JS
126−tco opts | optionsTco opts = tco'
127− | otherwise = id
128−
129−tco' :: JS -> JS
130−tco' = everywhere (mkT convert)
131− where
132− tcoLabel :: String
133− tcoLabel = "tco"
134− tcoVar :: Ident -> Ident
135− tcoVar (Ident arg) = Ident $ "__tco_" ++ arg
136− tcoVar _ = error "Invalid name in tcoVar"
137− copyVar :: Ident -> Ident
138− copyVar (Ident arg) = Ident $ "__copy_" ++ arg
139− copyVar _ = error "Invalid name in copyVar"
140− convert :: JS -> JS
141− convert js@(JSVariableIntroduction name (Just fn@(JSFunction _ _ _))) =
142− let
143− (argss, body', replace) = collectAllFunctionArgs [] id fn
144− in case () of
145− _ | isTailCall name body' ->
146− let
147− allArgs = reverse $ concat argss
148− in
149− JSVariableIntroduction name (Just (replace (toLoop name allArgs body')))
150− | otherwise -> js
151− convert js = js
152− collectAllFunctionArgs :: [[Ident]] -> (JS -> JS) -> JS -> ([[Ident]], JS, JS -> JS)
153− collectAllFunctionArgs allArgs f (JSFunction ident args (JSBlock (body@(JSReturn _):_))) =
154− collectAllFunctionArgs (args : allArgs) (\b -> f (JSFunction ident (map copyVar args) (JSBlock [b]))) body
155− collectAllFunctionArgs allArgs f (JSFunction ident args body@(JSBlock _)) =
156− (args : allArgs, body, \b -> f (JSFunction ident (map copyVar args) b))
157− collectAllFunctionArgs allArgs f (JSReturn (JSFunction ident args (JSBlock [body]))) =
158− collectAllFunctionArgs (args : allArgs) (\b -> f (JSReturn (JSFunction ident (map copyVar args) (JSBlock [b])))) body
159− collectAllFunctionArgs allArgs f (JSReturn (JSFunction ident args body@(JSBlock _))) =
160− (args : allArgs, body, \b -> f (JSReturn (JSFunction ident (map copyVar args) b)))
161− collectAllFunctionArgs allArgs f body = (allArgs, body, f)
162− isTailCall :: Ident -> JS -> Bool
163− isTailCall ident js =
164− let
165− numSelfCalls = everything (+) (mkQ 0 countSelfCalls) js
166− numSelfCallsInTailPosition = everything (+) (mkQ 0 countSelfCallsInTailPosition) js
167− numSelfCallsUnderFunctions = everything (+) (mkQ 0 countSelfCallsUnderFunctions) js
168− in
169− numSelfCalls > 0
170− && numSelfCalls == numSelfCallsInTailPosition
171− && numSelfCallsUnderFunctions == 0
172− where
173− countSelfCalls :: JS -> Int
174− countSelfCalls (JSApp (JSVar ident') _) | ident == ident' = 1
175− countSelfCalls _ = 0
176− countSelfCallsInTailPosition :: JS -> Int
177− countSelfCallsInTailPosition (JSReturn ret) | isSelfCall ident ret = 1
178− countSelfCallsInTailPosition _ = 0
179− countSelfCallsUnderFunctions (JSFunction _ _ js') = everything (+) (mkQ 0 countSelfCalls) js'
180− countSelfCallsUnderFunctions _ = 0
181− toLoop :: Ident -> [Ident] -> JS -> JS
182− toLoop ident allArgs js = JSBlock $
183− map (\arg -> JSVariableIntroduction arg (Just (JSVar (copyVar arg)))) allArgs ++
184− [ JSLabel tcoLabel $ JSWhile (JSBooleanLiteral True) (JSBlock [ everywhere (mkT loopify) js ]) ]
185− where
186− loopify :: JS -> JS
187− loopify (JSReturn ret) | isSelfCall ident ret =
188− let
189− allArgumentValues = concat $ collectSelfCallArgs [] ret
190− in
191− JSBlock $ zipWith (\val arg ->
192− JSVariableIntroduction (tcoVar arg) (Just val)) allArgumentValues allArgs
193− ++ map (\arg ->
194− JSAssignment (JSAssignVariable arg) (JSVar (tcoVar arg))) allArgs
195− ++ [ JSContinue tcoLabel ]
196− loopify other = other
197− collectSelfCallArgs :: [[JS]] -> JS -> [[JS]]
198− collectSelfCallArgs allArgumentValues (JSApp fn args') = collectSelfCallArgs (args' : allArgumentValues) fn
199− collectSelfCallArgs allArgumentValues _ = allArgumentValues
200− isSelfCall :: Ident -> JS -> Bool
201− isSelfCall ident (JSApp (JSVar ident') _) | ident == ident' = True
202− isSelfCall ident (JSApp fn _) = isSelfCall ident fn
203− isSelfCall _ _ = False
204−
205−magicDo :: Options -> JS -> JS
206−magicDo opts | optionsMagicDo opts = magicDo'
207− | otherwise = id
208−
209−magicDo' :: JS -> JS
210−magicDo' = everywhere (mkT undo) . everywhere' (mkT convert)
211− where
212− fnName = Ident "__do"
213− convert :: JS -> JS
214− convert (JSApp (JSApp ret [val]) []) | isReturn ret = val
215− convert (JSApp (JSApp bind [m]) [JSFunction Nothing [Ident "_"] (JSBlock [JSReturn ret])]) | isBind bind =
216− JSFunction (Just fnName) [] $ JSBlock [ JSApp m [], JSReturn (JSApp ret []) ]
217− convert (JSApp (JSApp bind [m]) [JSFunction Nothing [arg] (JSBlock [JSReturn ret])]) | isBind bind =
218− JSFunction (Just fnName) [] $ JSBlock [ JSVariableIntroduction arg (Just (JSApp m [])), JSReturn (JSApp ret []) ]
219− convert other = other
220− isBind (JSApp bindPoly [JSApp effDict []]) | isBindPoly bindPoly && isEffDict effDict = True
221− isBind _ = False
222− isReturn (JSApp retPoly [JSApp effDict []]) | isRetPoly retPoly && isEffDict effDict = True
223− isReturn _ = False
224− isBindPoly (JSVar (Op ">>=")) = True
225− isBindPoly (JSAccessor prop (JSVar (Ident "Prelude"))) | prop == identToJs (Op ">>=") = True
226− isBindPoly _ = False
227− isRetPoly (JSVar (Ident "ret")) = True
228− isRetPoly (JSAccessor "ret" (JSVar (Ident "Prelude"))) = True
229− isRetPoly _ = False
230− prelude = ModuleName (ProperName "Prelude")
231− effModule = ModuleName (ProperName "Eff")
232− Right (Ident effDictName) = mkDictionaryValueName
233− effModule
234− (Qualified (Just prelude) (ProperName "Monad"))
235− (TypeConstructor (Qualified (Just effModule) (ProperName "Eff")))
236− isEffDict (JSVar (Ident ident)) | ident == effDictName = True
237− isEffDict (JSAccessor prop (JSVar (Ident "Eff"))) | prop == effDictName = True
238− isEffDict _ = False
239− undo :: JS -> JS
240− undo (JSReturn (JSApp (JSFunction (Just ident) [] body) [])) | ident == fnName = body
241− undo other = other
242−
243−collapseNestedBlocks :: JS -> JS
244−collapseNestedBlocks = everywhere (mkT collapse)
245− where
246− collapse :: JS -> JS
247− collapse (JSBlock sts) = JSBlock (concatMap go sts)
248− collapse js = js
249− go :: JS -> [JS]
250− go (JSBlock sts) = sts
251− go s = [s]
src/Language/PureScript/Declarations.hsdeleted−53
@@ -1,53 +0,0 @@
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.hsdeleted−27
@@ -1,27 +0,0 @@
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.hsdeleted−45
@@ -1,45 +0,0 @@
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.hsdeleted−25
@@ -1,25 +0,0 @@
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.hsdeleted−22
@@ -1,22 +0,0 @@
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.hsdeleted−256
@@ -1,256 +0,0 @@
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.hsdeleted−145
@@ -1,145 +0,0 @@
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.hsdeleted−169
@@ -1,169 +0,0 @@
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.hsdeleted−42
@@ -1,42 +0,0 @@
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.hsdeleted−22
@@ -1,22 +0,0 @@
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.hsdeleted−123
@@ -1,123 +0,0 @@
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 $ return Array
40−
41−parseArrayOf :: P.Parsec String ParseState Type
42−parseArrayOf = squares $ TypeApp Array <$> parseType
43−
44−parseObject :: P.Parsec String ParseState Type
45−parseObject = braces $ Object <$> parseRow
46−
47−parseFunction :: P.Parsec String ParseState Type
48−parseFunction = do
49− args <- lexeme $ parens $ commaSep parsePolyType
50− _ <- lexeme $ P.string "->"
51− resultType <- parseType
52− return $ Function args resultType
53−
54−parseTypeVariable :: P.Parsec String ParseState Type
55−parseTypeVariable = TypeVar <$> identifier
56−
57−parseTypeConstructor :: P.Parsec String ParseState Type
58−parseTypeConstructor = TypeConstructor <$> parseQualified properName
59−
60−parseForAll :: P.Parsec String ParseState Type
61−parseForAll = (mkForAll <$> (P.try (reserved "forall") *> P.many1 (indented *> identifier) <* indented <* dot)
62− <*> parseConstrainedType)
63−
64−parseTypeAtom :: P.Parsec String ParseState Type
65−parseTypeAtom = indented *> P.choice (map P.try
66− [ parseNumber
67− , parseString
68− , parseBoolean
69− , parseArray
70− , parseArrayOf
71− , parseObject
72− , parseFunction
73− , parseTypeVariable
74− , parseTypeConstructor
75− , parseForAll
76− , parens parseRow
77− , parens parseType ])
78−
79−parseConstrainedType :: P.Parsec String ParseState Type
80−parseConstrainedType = do
81− constraints <- P.optionMaybe . P.try $ do
82− constraints <- parens . commaSep1 $ do
83− className <- parseQualified properName
84− indented
85− ty <- parseType
86− return (className, ty)
87− _ <- lexeme $ P.string "=>"
88− return constraints
89− indented
90− ty <- parseType
91− return $ maybe ty (flip ConstrainedType ty) constraints
92−
93−parseAnyType :: P.Parsec String ParseState Type
94−parseAnyType = (P.buildExpressionParser operators . buildPostfixParser postfixTable $ parseTypeAtom) P.<?> "type"
95− where
96− postfixTable :: [Type -> P.Parsec String ParseState Type]
97− postfixTable = [ \x -> TypeApp x <$> P.try (indented *> parseTypeAtom) ]
98− operators = [ [ P.Infix (lexeme (P.try (P.string "->")) >> return (\t1 t2 -> Function [t1] t2)) P.AssocRight ] ]
99−
100−parseType :: P.Parsec String ParseState Type
101−parseType = do
102− ty <- parseAnyType
103− unless (isMonoType ty) $ P.unexpected "polymorphic type"
104− return ty
105−
106−parsePolyType :: P.Parsec String ParseState Type
107−parsePolyType = do
108− ty <- parseAnyType
109− unless (isPolyType ty) $ P.unexpected "polymorphic type"
110− return ty
111−
112−parseNameAndType :: P.Parsec String ParseState t -> P.Parsec String ParseState (String, t)
113−parseNameAndType p = (,) <$> (indented *> identifier <* indented <* lexeme (P.string "::")) <*> p
114−
115−parseRowEnding :: P.Parsec String ParseState Type
116−parseRowEnding = P.option REmpty (TypeVar <$> (lexeme (indented *> P.char '|') *> indented *> identifier))
117−
118−parseRow :: P.Parsec String ParseState Type
119−parseRow = (fromList <$> (commaSep $ parseNameAndType parsePolyType) <*> parseRowEnding) P.<?> "row"
120− where
121− fromList :: [(String, Type)] -> Type -> Type
122− fromList [] r = r
123− fromList ((name, t):ts) r = RCons name t (fromList ts r)
src/Language/PureScript/Parser/Values.hsdeleted−296
@@ -1,296 +0,0 @@
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.hsdeleted−23
@@ -1,23 +0,0 @@
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.hsdeleted−79
@@ -1,79 +0,0 @@
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.hsdeleted−239
@@ -1,239 +0,0 @@
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.hsdeleted−54
@@ -1,54 +0,0 @@
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.hsdeleted−91
@@ -1,91 +0,0 @@
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 = Just $ "[]"
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.hsdeleted−214
@@ -1,214 +0,0 @@
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.hsdeleted−56
@@ -1,56 +0,0 @@
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.hsdeleted−34
@@ -1,34 +0,0 @@
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.hsdeleted−110
@@ -1,110 +0,0 @@
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.hsdeleted−67
@@ -1,67 +0,0 @@
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.hsdeleted−56
@@ -1,56 +0,0 @@
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.hsdeleted−129
@@ -1,129 +0,0 @@
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− let m' = M.fromList (map (\(i, fixity) -> (Qualified (Just moduleName) i, fixity)) fs)
100− collectFixities (M.union m' m) moduleName rest
101−collectFixities m moduleName (_:ds) = collectFixities m moduleName ds
102−
103−globalOp :: String -> Qualified Ident
104−globalOp = Qualified Nothing . Op
105−
106−builtIns :: [(Qualified Ident, Value -> Value -> Value, Precedence, Associativity)]
107−builtIns = [ (globalOp "<", Binary LessThan, 3, Infixl)
108− , (globalOp "<=", Binary LessThanOrEqualTo, 3, Infixl)
109− , (globalOp ">", Binary GreaterThan, 3, Infixl)
110− , (globalOp ">=", Binary GreaterThanOrEqualTo, 3, Infixl)
111− , (globalOp "!!", flip Indexer, 4, Infixl)
112− , (globalOp "*", Binary Multiply, 5, Infixl)
113− , (globalOp "/", Binary Divide, 5, Infixl)
114− , (globalOp "%", Binary Modulus, 5, Infixl)
115− , (globalOp "++", Binary Concat, 6, Infixr)
116− , (globalOp "+", Binary Add, 7, Infixl)
117− , (globalOp "-", Binary Subtract, 7, Infixl)
118− , (globalOp "<<", Binary ShiftLeft, 8, Infixl)
119− , (globalOp ">>", Binary ShiftRight, 8, Infixl)
120− , (globalOp ">>>", Binary ZeroFillShiftRight, 8, Infixl)
121− , (globalOp "==", Binary EqualTo, 9, Infixl)
122− , (globalOp "!=", Binary NotEqualTo, 9, Infixl)
123− , (globalOp "&", Binary BitwiseAnd, 10, Infixl)
124− , (globalOp "^", Binary BitwiseXor, 10, Infixl)
125− , (globalOp "|", Binary BitwiseOr, 10, Infixl)
126− , (globalOp "&&", Binary And, 11, Infixr)
127− , (globalOp "||", Binary Or, 11, Infixr)
128− ]
129−
src/Language/PureScript/Sugar/TypeClasses.hsdeleted−134
@@ -1,134 +0,0 @@
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 = return "array"
126−typeToString _ (TypeVar _) = return "var"
127−typeToString mn (TypeConstructor ty') = return $ qualifiedToString mn ty'
128−typeToString mn (TypeApp ty' (TypeVar _)) = typeToString mn ty'
129−typeToString a b = Left $ "Type class instance must be of the form T a1 ... an " ++ show (a, b)
130−
131−mkDictionaryEntryName :: ModuleName -> Qualified ProperName -> Type -> Ident -> Desugar Ident
132−mkDictionaryEntryName mn name ty ident = do
133− Ident dictName <- lift $ mkDictionaryValueName mn name ty
134− return $ Ident $ dictName ++ "_" ++ identToJs ident
src/Language/PureScript/Sugar/TypeDeclarations.hsdeleted−35
@@ -1,35 +0,0 @@
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.hsdeleted−224
@@ -1,224 +0,0 @@
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− shadowTypeClassInstances env
170− ds <- typeCheckAll currentModule rest
171− return $ d : ds
172− where
173− errorMessage = (("Error in import declaration " ++ show moduleName ++ ":\n") ++)
174− filterModule = filter ((== moduleName) . fst) . M.keys
175− moduleExists env = not (null (filterModule (names env))) || not (null (filterModule (types env)))
176− shadowIdents idents' env =
177− forM_ idents' $ \ident -> do
178− case (moduleName, ident) `M.lookup` names env of
179− Just (_, Alias _ _) -> return ()
180− Just (pt, _) -> do
181− guardWith (show currentModule ++ "." ++ show ident ++ " is already defined") $ (currentModule, ident) `M.notMember` names env
182− modifyEnv (\e -> e { names = M.insert (currentModule, ident) (pt, Alias moduleName ident) (names e) })
183− Nothing -> throwError (show moduleName ++ "." ++ show ident ++ " is undefined")
184− shadowTypes pns env =
185− forM_ pns $ \pn -> do
186− case (moduleName, pn) `M.lookup` types env of
187− Nothing -> throwError (show moduleName ++ "." ++ show pn ++ " is undefined")
188− Just (_, DataAlias _ _) -> return ()
189− Just (k, _) -> do
190− guardWith (show currentModule ++ "." ++ show pn ++ " is already defined") $ (currentModule, pn) `M.notMember` types env
191− modifyEnv (\e -> e { types = M.insert (currentModule, pn) (k, DataAlias moduleName pn) (types e) })
192− let keys = map (snd . fst) . filter (\(_, (fn, _)) -> fn `constructs` pn) . M.toList . dataConstructors $ env
193− forM_ keys $ \dctor -> do
194− case (moduleName, dctor) `M.lookup` dataConstructors env of
195− Just (_, Alias _ _) -> return ()
196− Just (ctorTy, _) -> do
197− guardWith (show currentModule ++ "." ++ show dctor ++ " is already defined") $ (currentModule, dctor) `M.notMember` dataConstructors env
198− modifyEnv (\e -> e { dataConstructors = M.insert (currentModule, dctor) (ctorTy, Alias moduleName (Ident (runProperName dctor))) (dataConstructors e) })
199− Nothing -> throwError (show moduleName ++ "." ++ show dctor ++ " is undefined")
200− shadowTypeClassInstances env = do
201− let instances = filter (\tcd ->
202− let Qualified (Just mn) _ = tcdName tcd in
203− moduleName == mn && tcdType tcd == TCDRegular
204− ) (typeClassDictionaries env)
205− forM_ instances $ \tcd -> do
206− let (Qualified _ ident) = tcdName tcd
207− addTypeClassDictionaries [tcd { tcdName = (Qualified (Just currentModule) ident), tcdType = TCDAlias (tcdName tcd) }]
208− constructs (TypeConstructor (Qualified (Just mn) pn')) pn
209− = mn == moduleName && pn' == pn
210− constructs (ForAll _ ty) pn = ty `constructs` pn
211− constructs (Function _ ty) pn = ty `constructs` pn
212− constructs (TypeApp ty _) pn = ty `constructs` pn
213− constructs fn _ = error $ "Invalid arguments to constructs: " ++ show fn
214−typeCheckAll moduleName (d@(TypeClassDeclaration _ _ _) : rest) = do
215− env <- getEnv
216− ds <- typeCheckAll moduleName rest
217− return $ qualifyAllUnqualifiedNames moduleName env d : ds
218−typeCheckAll moduleName (d@(TypeInstanceDeclaration deps className ty _) : rest) = do
219− env <- getEnv
220− dictName <- Check . lift $ mkDictionaryValueName moduleName className ty
221− addTypeClassDictionaries (qualifyAllUnqualifiedNames moduleName env
222− [TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) className ty (Just deps) TCDRegular])
223− ds <- typeCheckAll moduleName rest
224− return $ qualifyAllUnqualifiedNames moduleName env d : ds
src/Language/PureScript/TypeChecker/Kinds.hsdeleted−141
@@ -1,141 +0,0 @@
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 = return $ FunKind Star Star
99−infer (Object row) = do
100− k <- infer row
101− k ~~ Row Star
102− return Star
103−infer (Function args ret) = do
104− ks <- mapM infer args
105− k <- infer ret
106− k ~~ Star
107− forM_ ks (~~ Star)
108− return Star
109−infer (TypeVar v) = do
110− moduleName <- substCurrentModule <$> ask
111− lookupTypeVariable moduleName (Qualified Nothing (ProperName v))
112−infer (TypeConstructor v) = do
113− env <- liftCheck getEnv
114− moduleName <- substCurrentModule `fmap` ask
115− case M.lookup (qualify moduleName v) (types env) of
116− Nothing -> throwError $ "Unknown type constructor '" ++ show v ++ "'"
117− Just (kind, _) -> return kind
118−infer (TypeApp t1 t2) = do
119− k0 <- fresh
120− k1 <- infer t1
121− k2 <- infer t2
122− k1 ~~ FunKind k2 k0
123− return k0
124−infer (ForAll ident ty) = do
125− k <- fresh
126− moduleName <- substCurrentModule <$> ask
127− bindLocalTypeVariables moduleName [(ProperName ident, k)] $ infer ty
128−infer REmpty = do
129− k <- fresh
130− return $ Row k
131−infer (RCons _ ty row) = do
132− k1 <- infer ty
133− k2 <- infer row
134− k2 ~~ Row k1
135− return $ Row k1
136−infer (ConstrainedType deps ty) = do
137− mapM_ (infer . snd) deps
138− k <- infer ty
139− k ~~ Star
140− return Star
141−infer _ = error "Invalid argument to infer"
src/Language/PureScript/TypeChecker/Monad.hsdeleted−251
@@ -1,251 +0,0 @@
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−import Control.Arrow ((***))
37−
38−import qualified Data.Map as M
39−
40−data NameKind
41− = Value
42− | Extern ForeignImportType
43− | Alias ModuleName Ident
44− | LocalVariable
45− | DataConstructor deriving Show
46−
47−data TypeDeclarationKind
48− = Data
49− | ExternData
50− | TypeSynonym
51− | DataAlias ModuleName ProperName
52− | LocalTypeVariable deriving Show
53−
54−data Environment = Environment
55− { names :: M.Map (ModuleName, Ident) (Type, NameKind)
56− , types :: M.Map (ModuleName, ProperName) (Kind, TypeDeclarationKind)
57− , dataConstructors :: M.Map (ModuleName, ProperName) (Type, NameKind)
58− , typeSynonyms :: M.Map (ModuleName, ProperName) ([String], Type)
59− , typeClassDictionaries :: [TypeClassDictionaryInScope]
60− } deriving (Show)
61−
62−emptyEnvironment :: Environment
63−emptyEnvironment = Environment M.empty M.empty M.empty M.empty []
64−
65−bindNames :: (MonadState CheckState m) => M.Map (ModuleName, Ident) (Type, NameKind) -> m a -> m a
66−bindNames newNames action = do
67− orig <- get
68− modify $ \st -> st { checkEnv = (checkEnv st) { names = newNames `M.union` (names . checkEnv $ st) } }
69− a <- action
70− modify $ \st -> st { checkEnv = (checkEnv st) { names = names . checkEnv $ orig } }
71− return a
72−
73−bindTypes :: (MonadState CheckState m) => M.Map (ModuleName, ProperName) (Kind, TypeDeclarationKind) -> m a -> m a
74−bindTypes newNames action = do
75− orig <- get
76− modify $ \st -> st { checkEnv = (checkEnv st) { types = newNames `M.union` (types . checkEnv $ st) } }
77− a <- action
78− modify $ \st -> st { checkEnv = (checkEnv st) { types = types . checkEnv $ orig } }
79− return a
80−
81−withTypeClassDictionaries :: (MonadState CheckState m) => [TypeClassDictionaryInScope] -> m a -> m a
82−withTypeClassDictionaries entries action = do
83− orig <- get
84− modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = entries ++ (typeClassDictionaries . checkEnv $ st) } }
85− a <- action
86− modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = typeClassDictionaries . checkEnv $ orig } }
87− return a
88−
89−getTypeClassDictionaries :: (Functor m, MonadState CheckState m) => m [TypeClassDictionaryInScope]
90−getTypeClassDictionaries = typeClassDictionaries . checkEnv <$> get
91−
92−bindLocalVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(Ident, Type)] -> m a -> m a
93−bindLocalVariables moduleName bindings action =
94− bindNames (M.fromList $ flip map bindings $ \(name, ty) -> ((moduleName, name), (ty, LocalVariable))) action
95−
96−bindLocalTypeVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(ProperName, Kind)] -> m a -> m a
97−bindLocalTypeVariables moduleName bindings action =
98− bindTypes (M.fromList $ flip map bindings $ \(name, k) -> ((moduleName, name), (k, LocalTypeVariable))) action
99−
100−lookupVariable :: (Functor m, MonadState CheckState m, MonadError String m) => ModuleName -> Qualified Ident -> m Type
101−lookupVariable currentModule (Qualified moduleName var) = do
102− env <- getEnv
103− case M.lookup (fromMaybe currentModule moduleName, var) (names env) of
104− Nothing -> throwError $ show var ++ " is undefined"
105− Just (ty, _) -> return ty
106−
107−lookupTypeVariable :: (Functor m, MonadState CheckState m, MonadError String m) => ModuleName -> Qualified ProperName -> m Kind
108−lookupTypeVariable currentModule (Qualified moduleName name) = do
109− env <- getEnv
110− case M.lookup (fromMaybe currentModule moduleName, name) (types env) of
111− Nothing -> throwError $ "Type variable " ++ show name ++ " is undefined"
112− Just (k, _) -> return k
113−
114−canonicalize :: ModuleName -> Environment -> Qualified Ident -> (ModuleName, Ident)
115−canonicalize _ _ (Qualified (Just mn) i) = (mn, i)
116−canonicalize mn env (Qualified Nothing i) = case (mn, i) `M.lookup` names env of
117− Just (_, Alias mn' i') -> (mn', i')
118− _ -> (mn, i)
119−
120−canonicalizeType :: ModuleName -> Environment -> Qualified ProperName -> (ModuleName, ProperName)
121−canonicalizeType _ _ (Qualified (Just mn) nm) = (mn, nm)
122−canonicalizeType mn env (Qualified Nothing nm) = case (mn, nm) `M.lookup` types env of
123− Just (_, DataAlias mn' pn') -> (mn', pn')
124− _ -> (mn, nm)
125−
126−data CheckState = CheckState { checkEnv :: Environment
127− , checkNextVar :: Int
128− , checkNextDictName :: Int
129− }
130−
131−newtype Check a = Check { unCheck :: StateT CheckState (Either String) a }
132− deriving (Functor, Monad, Applicative, MonadPlus, MonadState CheckState, MonadError String)
133−
134−getEnv :: (Functor m, MonadState CheckState m) => m Environment
135−getEnv = checkEnv <$> get
136−
137−putEnv :: (MonadState CheckState m) => Environment -> m ()
138−putEnv env = modify (\s -> s { checkEnv = env })
139−
140−modifyEnv :: (MonadState CheckState m) => (Environment -> Environment) -> m ()
141−modifyEnv f = modify (\s -> s { checkEnv = f (checkEnv s) })
142−
143−runCheck :: Check a -> Either String (a, Environment)
144−runCheck c = do
145− (a, s) <- flip runStateT (CheckState emptyEnvironment 0 0) $ unCheck c
146− return (a, checkEnv s)
147−
148−guardWith :: (MonadError e m) => e -> Bool -> m ()
149−guardWith _ True = return ()
150−guardWith e False = throwError e
151−
152−rethrow :: (MonadError e m) => (e -> e) -> m a -> m a
153−rethrow f = flip catchError $ \e -> throwError (f e)
154−
155−freshDictionaryName :: Check Int
156−freshDictionaryName = do
157− n <- checkNextDictName <$> get
158− modify $ \s -> s { checkNextDictName = succ (checkNextDictName s) }
159− return n
160−
161−newtype Substitution = Substitution { runSubstitution :: forall t. (Unifiable t) => Unknown t -> t }
162−
163−instance Monoid Substitution where
164− mempty = Substitution unknown
165− s1 `mappend` s2 = Substitution $ \u -> apply s1 (apply s2 (unknown u))
166−
167−data SubstState = SubstState { substSubst :: Substitution }
168−
169−newtype SubstContext = SubstContext { substCurrentModule :: ModuleName } deriving (Show)
170−
171−newtype Subst a = Subst { unSubst :: ReaderT SubstContext (StateT SubstState Check) a }
172− deriving (Functor, Monad, Applicative, MonadPlus, MonadReader SubstContext)
173−
174−instance MonadState CheckState Subst where
175− get = Subst . lift . lift $ get
176− put = Subst . lift . lift . put
177−
178−deriving instance MonadError String Subst
179−
180−liftCheck :: Check a -> Subst a
181−liftCheck = Subst . lift . lift
182−
183−getSubstState :: Subst SubstState
184−getSubstState = Subst . lift $ get
185−
186−runSubst :: SubstContext -> Subst a -> Check (a, Substitution)
187−runSubst context subst = do
188− (a, s) <- flip runStateT (SubstState mempty) . flip runReaderT context . unSubst $ subst
189− return (a, substSubst s)
190−
191−substituteWith :: (Typeable t) => (Unknown t -> t) -> Substitution
192−substituteWith f = Substitution $ \u -> fromMaybe (unknown u) $ do
193− u1 <- cast u
194− cast (f u1)
195−
196−substituteOne :: (Unifiable t) => Unknown t -> t -> Substitution
197−substituteOne u t = substituteWith $ \u1 ->
198− case u1 of
199− u2 | u2 == u -> t
200− | otherwise -> unknown u2
201−
202−replace :: (Unifiable t) => Unknown t -> t -> Subst ()
203−replace u t' = do
204− sub <- substSubst <$> Subst get
205− let t = apply sub t'
206− occursCheck u t
207− let current = apply sub $ unknown u
208− case isUnknown current of
209− Just u1 | u1 == u -> return ()
210− _ -> current ~~ t
211− Subst . modify $ \s -> s { substSubst = substituteOne u t <> substSubst s }
212−
213−class (Typeable t, Data t, Show t) => Unifiable t where
214− unknown :: Unknown t -> t
215− (~~) :: t -> t -> Subst ()
216− isUnknown :: t -> Maybe (Unknown t)
217− apply :: Substitution -> t -> t
218− unknowns :: t -> [Int]
219−
220−instance (Unifiable a) => Unifiable [a] where
221− unknown _ = error "not supported"
222− (~~) = zipWithM_ (~~)
223− isUnknown _ = error "not supported"
224− apply s = map (apply s)
225− unknowns = concatMap unknowns
226−
227−occursCheck :: (Unifiable t) => Unknown s -> t -> Subst ()
228−occursCheck (Unknown u) t =
229− case isUnknown t of
230− Nothing -> guardWith "Occurs check fails" (u `notElem` unknowns t)
231− _ -> return ()
232−
233−fresh' :: Subst Int
234−fresh' = do
235− n <- checkNextVar <$> get
236− modify $ \s -> s { checkNextVar = succ (checkNextVar s) }
237− return n
238−
239−fresh :: (Unifiable t) => Subst t
240−fresh = unknown . Unknown <$> fresh'
241−
242−qualifyAllUnqualifiedNames :: (Data d) => ModuleName -> Environment -> d -> d
243−qualifyAllUnqualifiedNames mn env = everywhere (mkT go)
244− where
245− go :: Type -> Type
246− go (TypeConstructor nm) = TypeConstructor $ qualify' nm
247− go (SaturatedTypeSynonym nm args) = SaturatedTypeSynonym (qualify' nm) args
248− go (ConstrainedType constraints ty) = ConstrainedType (map (qualify' *** id) constraints) ty
249− go other = other
250− qualify' qual = let (mn', pn') = canonicalizeType mn env qual
251− in Qualified (Just mn') pn'
src/Language/PureScript/TypeChecker/Synonyms.hsdeleted−49
@@ -1,49 +0,0 @@
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.hsdeleted−811
@@ -1,811 +0,0 @@
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 (Object r) = Object (apply s r)
57− apply s (Function args ret) = Function (map (apply s) args) (apply s ret)
58− apply s (TypeApp t1 t2) = TypeApp (apply s t1) (apply s t2)
59− apply s (RCons name ty r) = RCons name (apply s ty) (apply s r)
60− apply _ t = t
61− unknowns (TUnknown (Unknown u)) = [u]
62− unknowns (SaturatedTypeSynonym _ tys) = concatMap unknowns tys
63− unknowns (ForAll _ ty) = unknowns ty
64− unknowns (Object r) = unknowns r
65− unknowns (Function args ret) = concatMap unknowns args ++ unknowns ret
66− unknowns (TypeApp t1 t2) = unknowns t1 ++ unknowns t2
67− unknowns (RCons _ ty r) = unknowns ty ++ unknowns r
68− unknowns _ = []
69−
70−unifyTypes :: Type -> Type -> Subst ()
71−unifyTypes t1 t2 = rethrow (\e -> "Error unifying type " ++ prettyPrintType t1 ++ " with type " ++ prettyPrintType t2 ++ ":\n" ++ e) $ do
72− unifyTypes' t1 t2
73− where
74− unifyTypes' (TUnknown u1) (TUnknown u2) | u1 == u2 = return ()
75− unifyTypes' (TUnknown u) t = replace u t
76− unifyTypes' t (TUnknown u) = replace u t
77− unifyTypes' (SaturatedTypeSynonym name args) ty = do
78− ty1 <- expandTypeSynonym name args
79− ty1 `unifyTypes` ty
80− unifyTypes' ty s@(SaturatedTypeSynonym _ _) = s `unifyTypes` ty
81− unifyTypes' (ForAll ident1 ty1) (ForAll ident2 ty2) = do
82− sk <- skolemize ident1 ty1
83− replaced <- replaceVarWithUnknown ident2 ty2
84− sk `unifyTypes` replaced
85− unifyTypes' (ForAll ident ty1) ty2 = do
86− sk <- skolemize ident ty1
87− sk `unifyTypes` ty2
88− unifyTypes' ty f@(ForAll _ _) = f `unifyTypes` ty
89− unifyTypes' Number Number = return ()
90− unifyTypes' String String = return ()
91− unifyTypes' Boolean Boolean = return ()
92− unifyTypes' Array Array = return ()
93− unifyTypes' (Object row1) (Object row2) = row1 ~~ row2
94− unifyTypes' (Function args1 ret1) (Function args2 ret2) = do
95− guardWith "Function applied to incorrect number of args" $ length args1 == length args2
96− zipWithM_ unifyTypes args1 args2
97− ret1 `unifyTypes` ret2
98− unifyTypes' (TypeVar v1) (TypeVar v2) | v1 == v2 = return ()
99− unifyTypes' (TypeConstructor c1) (TypeConstructor c2) = do
100− env <- getEnv
101− moduleName <- substCurrentModule `fmap` ask
102− guardWith ("Cannot unify " ++ show c1 ++ " with " ++ show c2 ++ ".") (typeConstructorsAreEqual env moduleName c1 c2)
103− unifyTypes' (TypeApp t3 t4) (TypeApp t5 t6) = do
104− t3 `unifyTypes` t5
105− t4 `unifyTypes` t6
106− unifyTypes' (Skolem s1) (Skolem s2) | s1 == s2 = return ()
107− unifyTypes' r1@(RCons _ _ _) r2 = unifyRows r1 r2
108− unifyTypes' r1 r2@(RCons _ _ _) = unifyRows r1 r2
109− unifyTypes' r1@REmpty r2 = unifyRows r1 r2
110− unifyTypes' r1 r2@REmpty = unifyRows r1 r2
111− unifyTypes' t3 t4 = throwError $ "Cannot unify " ++ prettyPrintType t3 ++ " with " ++ prettyPrintType t4 ++ "."
112−
113−unifyRows :: Type -> Type -> Subst ()
114−unifyRows r1 r2 =
115− let
116− (s1, r1') = rowToList r1
117− (s2, r2') = rowToList r2
118− int = [ (t1, t2) | (name, t1) <- s1, (name', t2) <- s2, name == name' ]
119− sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ]
120− sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ]
121− in do
122− forM_ int (uncurry (~~))
123− unifyRows' sd1 r1' sd2 r2'
124− where
125− unifyRows' :: [(String, Type)] -> Type -> [(String, Type)] -> Type -> Subst ()
126− unifyRows' [] (TUnknown u) sd r = replace u (rowFromList (sd, r))
127− unifyRows' sd r [] (TUnknown u) = replace u (rowFromList (sd, r))
128− unifyRows' ((name, ty):row) r others u@(TUnknown un) = do
129− occursCheck un ty
130− forM_ row $ \(_, t) -> occursCheck un t
131− u' <- fresh
132− u ~~ RCons name ty u'
133− unifyRows' row r others u'
134− unifyRows' [] REmpty [] REmpty = return ()
135− unifyRows' [] (TypeVar v1) [] (TypeVar v2) | v1 == v2 = return ()
136− unifyRows' [] (Skolem s1) [] (Skolem s2) | s1 == s2 = return ()
137− unifyRows' sd3 r3 sd4 r4 = throwError $ "Cannot unify " ++ prettyPrintRow (rowFromList (sd3, r3)) ++ " with " ++ prettyPrintRow (rowFromList (sd4, r4)) ++ "."
138−
139−typeConstructorsAreEqual :: Environment -> ModuleName -> Qualified ProperName -> Qualified ProperName -> Bool
140−typeConstructorsAreEqual env moduleName = (==) `on` canonicalizeType moduleName env
141−
142−typesOf :: ModuleName -> [(Ident, Value)] -> Check [(Ident, (Value, Type))]
143−typesOf moduleName vals = do
144− tys <- fmap (\(tys, s) -> map (\(ident, (val, ty)) -> (ident, (overTypes (apply s) val, apply s ty))) tys)
145− . runSubst (SubstContext moduleName) $ do
146− let es = map isTyped vals
147− typed = filter (isJust . snd . snd) es
148− untyped = filter (isNothing . snd . snd) es
149− typedDict = map (\(ident, (_, Just ty)) -> (ident, ty)) typed
150− untypedNames <- replicateM (length untyped) fresh
151− let untypedDict = zip (map fst untyped) untypedNames
152− dict = M.fromList (map (\(ident, ty) -> ((moduleName, ident), (ty, LocalVariable))) $ (map (id *** fst) typedDict) ++ untypedDict)
153− forM es $ \e -> do
154− triple@(_, (val, ty)) <- case e of
155− (ident, (val, Just (ty, checkType))) -> do
156− kind <- liftCheck $ kindOf moduleName ty
157− guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
158− ty' <- replaceAllTypeSynonyms ty
159− val' <- bindNames dict $ if checkType then check val ty' else return val
160− return (ident, (val', ty'))
161− (ident, (val, Nothing)) -> do
162− TypedValue _ val' ty <- bindNames dict $ infer val
163− ty ~~ fromMaybe (error "name not found in dictionary") (lookup ident untypedDict)
164− return (ident, (val', ty))
165− when (moduleName == ModuleName (ProperName "Main") && fst e == Ident "main") $ do
166− [eff, a] <- replicateM 2 fresh
167− ty ~~ TypeApp (TypeApp (TypeConstructor (Qualified (Just (ModuleName (ProperName "Eff"))) (ProperName "Eff"))) eff) a
168− escapeCheck val ty
169− return triple
170− forM_ tys $ skolemEscapeCheck . snd . snd
171− forM tys $ \(ident, (val, ty)) -> do
172− val' <- replaceTypeClassDictionaries moduleName val
173− return (ident, (overTypes (desaturateAllTypeSynonyms . setifyAll) $ val'
174− , varIfUnknown . desaturateAllTypeSynonyms . setifyAll $ ty))
175−
176−isTyped :: (Ident, Value) -> (Ident, (Value, Maybe (Type, Bool)))
177−isTyped (name, TypedValue checkType value ty) = (name, (value, Just (ty, checkType)))
178−isTyped (name, value) = (name, (value, Nothing))
179−
180−overTypes :: (Type -> Type) -> Value -> Value
181−overTypes f = everywhere (mkT f)
182−
183−replaceTypeClassDictionaries :: ModuleName -> Value -> Check Value
184−replaceTypeClassDictionaries mn = everywhereM (mkM go)
185− where
186− go (TypeClassDictionary constraint dicts) = entails mn dicts constraint
187− go other = return other
188−
189−entails :: ModuleName -> [TypeClassDictionaryInScope] -> (Qualified ProperName, Type) -> Check Value
190−entails moduleName context goal@(className, ty) = do
191− env <- getEnv
192− case go env goal of
193− [] -> throwError $ "No " ++ show className ++ " instance found for " ++ prettyPrintType ty
194− (dict : _) -> return dict
195− where
196− go env (className', ty') =
197− [ mkDictionary (canonicalizeDictionary tcd) args
198− | tcd <- context
199− , filterModule tcd
200− , typeConstructorsAreEqual env moduleName className' (tcdClassName tcd)
201− , subst <- maybeToList $ typeHeadsAreEqual moduleName env ty' (tcdInstanceType tcd)
202− , args <- solveSubgoals env subst (tcdDependencies tcd) ]
203− solveSubgoals _ _ Nothing = return Nothing
204− solveSubgoals env subst (Just subgoals) = do
205− dict <- mapM (go env) (replaceAllTypeVars subst subgoals)
206− return $ Just dict
207− mkDictionary fnName args = maybe id (flip App) args $ (Var fnName)
208− filterModule (TypeClassDictionaryInScope { tcdName = Qualified (Just mn) _ }) | mn == moduleName = True
209− filterModule (TypeClassDictionaryInScope { tcdName = Qualified Nothing _ }) = True
210− filterModule _ = False
211− canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDRegular, tcdName = nm }) = nm
212− canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDAlias nm }) = nm
213−
214−typeHeadsAreEqual :: ModuleName -> Environment -> Type -> Type -> Maybe [(String, Type)]
215−typeHeadsAreEqual _ _ String String = Just []
216−typeHeadsAreEqual _ _ Number Number = Just []
217−typeHeadsAreEqual _ _ Boolean Boolean = Just []
218−typeHeadsAreEqual _ _ (Skolem s1) (Skolem s2) | s1 == s2 = Just []
219−typeHeadsAreEqual _ _ Array Array = Just []
220−typeHeadsAreEqual m e (TypeConstructor c1) (TypeConstructor c2) | typeConstructorsAreEqual e m c1 c2 = Just []
221−typeHeadsAreEqual m e (TypeApp h1 (TypeVar v)) (TypeApp h2 arg) = (:) (v, arg) <$> typeHeadsAreEqual m e h1 h2
222−typeHeadsAreEqual m e t1@(TypeApp _ _) t2@(TypeApp _ (TypeVar _)) = typeHeadsAreEqual m e t2 t1
223−typeHeadsAreEqual _ _ _ _ = Nothing
224−
225−escapeCheck :: Value -> Type -> Subst ()
226−escapeCheck value ty = do
227− subst <- substSubst <$> getSubstState
228− let visibleUnknowns = nub $ unknowns $ apply subst ty
229− let allUnknowns = findAllTypes value
230− forM_ allUnknowns $ \t -> do
231− let unsolvedUnknowns = nub . unknowns $ apply subst t
232− guardWith "Escape check fails" $ null $ unsolvedUnknowns \\ visibleUnknowns
233−
234−findAllTypes :: Value -> [Type]
235−findAllTypes = everything (++) (mkQ [] go)
236− where
237− go (TypedValue _ _ ty) = [ty]
238− go _ = []
239−
240−skolemEscapeCheck :: Type -> Check ()
241−skolemEscapeCheck ty =
242− case something (mkQ Nothing findSkolems) ty of
243− Nothing -> return ()
244− Just _ -> throwError $ "Skolem variables cannot escape. Consider adding a type signature." ++ show ty
245− where
246− findSkolems (Skolem _) = return ()
247− findSkolems _ = mzero
248−
249−setify :: Type -> Type
250−setify = rowFromList . first (M.toList . M.fromList) . rowToList
251−
252−setifyAll :: (D.Data d) => d -> d
253−setifyAll = everywhere (mkT setify)
254−
255−varIfUnknown :: Type -> Type
256−varIfUnknown ty =
257− let unks = nub $ unknowns ty
258− toName = (:) 't' . show
259− ty' = everywhere (mkT typeToVar) $ ty
260− typeToVar :: Type -> Type
261− typeToVar (TUnknown (Unknown u)) = TypeVar (toName u)
262− typeToVar t = t
263− in mkForAll (sort . map toName $ unks) ty'
264−
265−replaceAllTypeVars :: (D.Data d) => [(String, Type)] -> d -> d
266−replaceAllTypeVars = foldl' (\f (name, ty) -> replaceTypeVars name ty . f) id
267−
268−replaceAllVarsWithUnknowns :: Type -> Subst Type
269−replaceAllVarsWithUnknowns (ForAll ident ty) = replaceVarWithUnknown ident ty >>= replaceAllVarsWithUnknowns
270−replaceAllVarsWithUnknowns ty = return ty
271−
272−replaceVarWithUnknown :: String -> Type -> Subst Type
273−replaceVarWithUnknown ident ty = do
274− tu <- fresh
275− return $ replaceTypeVars ident tu $ ty
276−
277−replaceAllTypeSynonyms :: (Functor m, MonadState CheckState m, MonadReader SubstContext m, MonadError String m) => (D.Data d) => d -> m d
278−replaceAllTypeSynonyms d = do
279− env <- getEnv
280− moduleName <- substCurrentModule <$> ask
281− let syns = map (\((path, name), (args, _)) -> ((path, name), length args)) . M.toList $ typeSynonyms env
282− either throwError return $ saturateAllTypeSynonyms env moduleName syns d
283−
284−desaturateAllTypeSynonyms :: (D.Data d) => d -> d
285−desaturateAllTypeSynonyms = everywhere (mkT replaceSaturatedTypeSynonym)
286− where
287− replaceSaturatedTypeSynonym (SaturatedTypeSynonym name args) = foldl TypeApp (TypeConstructor name) args
288− replaceSaturatedTypeSynonym t = t
289−
290−expandTypeSynonym :: Qualified ProperName -> [Type] -> Subst Type
291−expandTypeSynonym name args = do
292− env <- getEnv
293− moduleName <- substCurrentModule `fmap` ask
294− case M.lookup (canonicalizeType moduleName env name) (typeSynonyms env) of
295− Just (synArgs, body) -> return $ replaceAllTypeVars (zip synArgs args) body
296− Nothing -> error "Type synonym was not defined"
297−
298−ensureNoDuplicateProperties :: (MonadError String m) => [(String, Value)] -> m ()
299−ensureNoDuplicateProperties ps = guardWith "Duplicate property names" $ length (nub . map fst $ ps) == length ps
300−
301−infer :: Value -> Subst Value
302−infer val = rethrow (\e -> "Error inferring type of term " ++ prettyPrintValue val ++ ":\n" ++ e) $ infer' val
303−
304−infer' :: Value -> Subst Value
305−infer' v@(NumericLiteral _) = return $ TypedValue True v Number
306−infer' v@(StringLiteral _) = return $ TypedValue True v String
307−infer' v@(BooleanLiteral _) = return $ TypedValue True v Boolean
308−infer' (ArrayLiteral vals) = do
309− ts <- mapM infer vals
310− els <- fresh
311− forM_ ts $ \(TypedValue _ _ t) -> els ~~ TypeApp Array t
312− return $ TypedValue True (ArrayLiteral ts) els
313−infer' (Unary op val) = do
314− v <- infer val
315− inferUnary op v
316−infer' (Binary op left right) = do
317− v1 <- infer left
318− v2 <- infer right
319− inferBinary op v1 v2
320−infer' (ObjectLiteral ps) = do
321− ensureNoDuplicateProperties ps
322− ts <- mapM (infer . snd) ps
323− let fields = zipWith (\name (TypedValue _ _ t) -> (name, t)) (map fst ps) ts
324− ty = Object $ rowFromList (fields, REmpty)
325− return $ TypedValue True (ObjectLiteral (zip (map fst ps) ts)) ty
326−infer' (ObjectUpdate o ps) = do
327− ensureNoDuplicateProperties ps
328− row <- fresh
329− newVals <- zipWith (\(name, _) t -> (name, t)) ps <$> mapM (infer . snd) ps
330− let newTys = map (\(name, TypedValue _ _ ty) -> (name, ty)) newVals
331− oldTys <- zip (map fst ps) <$> replicateM (length ps) fresh
332− o' <- check o $ Object $ rowFromList (oldTys, row)
333− return $ TypedValue True (ObjectUpdate o' newVals) $ Object $ rowFromList (newTys, row)
334−infer' (Indexer index val) = do
335− el <- fresh
336− index' <- check index Number
337− val' <- check val (TypeApp Array el)
338− return $ TypedValue True (Indexer (TypedValue True index' Number) (TypedValue True val' (TypeApp Array el))) el
339−infer' (Accessor prop val) = do
340− typed@(TypedValue _ _ objTy) <- infer val
341− propTy <- inferProperty objTy prop
342− case propTy of
343− Nothing -> do
344− field <- fresh
345− rest <- fresh
346− objTy `subsumes` Object (RCons prop field rest)
347− return $ TypedValue True (Accessor prop typed) field
348− Just ty -> return $ TypedValue True (Accessor prop typed) ty
349−infer' (Abs args ret) = do
350− ts <- replicateM (length args) fresh
351− moduleName <- substCurrentModule <$> ask
352− bindLocalVariables moduleName (zip args ts) $ do
353− body@(TypedValue _ _ bodyTy) <- infer' ret
354− return $ TypedValue True (Abs args body) $ Function ts bodyTy
355−infer' (App f args) = do
356− f'@(TypedValue _ _ ft) <- infer f
357− ret <- fresh
358− app <- checkFunctionApplication f' ft args ret
359− return $ TypedValue True app ret
360−infer' (Var var) = do
361− moduleName <- substCurrentModule <$> ask
362− ty <- lookupVariable moduleName var
363− ty' <- replaceAllTypeSynonyms ty
364− case ty' of
365− ConstrainedType constraints _ -> do
366− env <- getEnv
367− dicts <- getTypeClassDictionaries
368− return $ TypedValue True (App (Var var) (map (flip TypeClassDictionary dicts) (qualifyAllUnqualifiedNames moduleName env constraints))) ty'
369− _ -> return $ TypedValue True (Var var) ty'
370−infer' (Block ss) = do
371− ret <- fresh
372− (allCodePathsReturn, _, ss') <- checkBlock M.empty ret ss
373− guardWith "Block is missing a return statement" allCodePathsReturn
374− return $ TypedValue True (Block ss') ret
375−infer' v@(Constructor c) = do
376− env <- getEnv
377− moduleName <- substCurrentModule `fmap` ask
378− case M.lookup (qualify moduleName c) (dataConstructors env) of
379− Nothing -> throwError $ "Constructor " ++ show c ++ " is undefined"
380− Just (ty, _) -> do ty' <- replaceAllTypeSynonyms ty
381− return $ TypedValue True v ty'
382−infer' (Case vals binders) = do
383− ts <- mapM infer vals
384− ret <- fresh
385− binders' <- checkBinders (map (\(TypedValue _ _ t) -> t) ts) ret binders
386− return $ TypedValue True (Case ts binders') ret
387−infer' (IfThenElse cond th el) = do
388− cond' <- check cond Boolean
389− v2@(TypedValue _ _ t2) <- infer th
390− v3@(TypedValue _ _ t3) <- infer el
391− t2 ~~ t3
392− return $ TypedValue True (IfThenElse cond' v2 v3) t2
393−infer' (TypedValue checkType val ty) = do
394− moduleName <- substCurrentModule <$> ask
395− kind <- liftCheck $ kindOf moduleName ty
396− guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
397− ty' <- replaceAllTypeSynonyms ty
398− val' <- if checkType then check val ty' else return val
399− return $ TypedValue True val' ty
400−infer' _ = error "Invalid argument to infer"
401−
402−inferProperty :: Type -> String -> Subst (Maybe Type)
403−inferProperty (Object row) prop = do
404− let (props, _) = rowToList row
405− return $ lookup prop props
406−inferProperty (SaturatedTypeSynonym name args) prop = do
407− replaced <- expandTypeSynonym name args
408− inferProperty replaced prop
409−inferProperty (ForAll ident ty) prop = do
410− replaced <- replaceVarWithUnknown ident ty
411− inferProperty replaced prop
412−inferProperty _ _ = return Nothing
413−
414−inferUnary :: UnaryOperator -> Value -> Subst Value
415−inferUnary op (TypedValue _ val valTy) =
416− case fromMaybe (error "Invalid operator") $ lookup op unaryOps of
417− (valTy', resTy) -> do
418− valTy' ~~ valTy
419− return $ TypedValue True (Unary op val) resTy
420−inferUnary _ _ = error "Invalid arguments to inferUnary"
421−
422−checkUnary :: UnaryOperator -> Value -> Type -> Subst Value
423−checkUnary op val res =
424− case fromMaybe (error "Invalid operator") $ lookup op unaryOps of
425− (valTy, resTy) -> do
426− res ~~ resTy
427− val' <- check val valTy
428− return $ Unary op val'
429−
430−unaryOps :: [(UnaryOperator, (Type, Type))]
431−unaryOps = [ (Negate, (Number, Number))
432− , (Not, (Boolean, Boolean))
433− , (BitwiseNot, (Number, Number))
434− ]
435−
436−inferBinary :: BinaryOperator -> Value -> Value -> Subst Value
437−inferBinary op left@(TypedValue _ _ leftTy) right@(TypedValue _ _ rightTy) | isEqualityTest op = do
438− leftTy ~~ rightTy
439− return $ TypedValue True (Binary op left right) Boolean
440−inferBinary op left@(TypedValue _ _ leftTy) right@(TypedValue _ _ rightTy) =
441− case fromMaybe (error "Invalid operator") $ lookup op binaryOps of
442− (valTy, resTy) -> do
443− leftTy ~~ valTy
444− rightTy ~~ valTy
445− return $ TypedValue True (Binary op left right) resTy
446−inferBinary _ _ _ = error "Invalid arguments to inferBinary"
447−
448−checkBinary :: BinaryOperator -> Value -> Value -> Type -> Subst Value
449−checkBinary op left right res | isEqualityTest op = do
450− res ~~ Boolean
451− left'@(TypedValue _ _ t1) <- infer left
452− right'@(TypedValue _ _ t2) <- infer right
453− t1 ~~ t2
454− return $ Binary op left' right'
455−checkBinary op left right res =
456− case fromMaybe (error "Invalid operator") $ lookup op binaryOps of
457− (valTy, resTy) -> do
458− res ~~ resTy
459− left' <- check left valTy
460− right' <- check right valTy
461− return $ Binary op left' right'
462−
463−isEqualityTest :: BinaryOperator -> Bool
464−isEqualityTest EqualTo = True
465−isEqualityTest NotEqualTo = True
466−isEqualityTest _ = False
467−
468−binaryOps :: [(BinaryOperator, (Type, Type))]
469−binaryOps = [ (Add, (Number, Number))
470− , (Subtract, (Number, Number))
471− , (Multiply, (Number, Number))
472− , (Divide, (Number, Number))
473− , (Modulus, (Number, Number))
474− , (BitwiseAnd, (Number, Number))
475− , (BitwiseOr, (Number, Number))
476− , (BitwiseXor, (Number, Number))
477− , (ShiftRight, (Number, Number))
478− , (ZeroFillShiftRight, (Number, Number))
479− , (And, (Boolean, Boolean))
480− , (Or, (Boolean, Boolean))
481− , (Concat, (String, String))
482− , (Modulus, (Number, Number))
483− , (LessThan, (Number, Boolean))
484− , (LessThanOrEqualTo, (Number, Boolean))
485− , (GreaterThan, (Number, Boolean))
486− , (GreaterThanOrEqualTo, (Number, Boolean))
487− ]
488−
489−inferBinder :: Type -> Binder -> Subst (M.Map Ident Type)
490−inferBinder _ NullBinder = return M.empty
491−inferBinder val (StringBinder _) = val ~~ String >> return M.empty
492−inferBinder val (NumberBinder _) = val ~~ Number >> return M.empty
493−inferBinder val (BooleanBinder _) = val ~~ Boolean >> return M.empty
494−inferBinder val (VarBinder name) = return $ M.singleton name val
495−inferBinder val (NullaryBinder ctor) = do
496− env <- getEnv
497− moduleName <- substCurrentModule <$> ask
498− case M.lookup (qualify moduleName ctor) (dataConstructors env) of
499− Just (ty, _) -> do
500− ty `subsumes` val
501− return M.empty
502− _ -> throwError $ "Constructor " ++ show ctor ++ " is not defined"
503−inferBinder val (UnaryBinder ctor binder) = do
504− env <- getEnv
505− moduleName <- substCurrentModule <$> ask
506− case M.lookup (qualify moduleName ctor) (dataConstructors env) of
507− Just (ty, _) -> do
508− fn <- replaceAllVarsWithUnknowns ty
509− case fn of
510− Function [obj] ret -> do
511− val `subsumes` ret
512− inferBinder obj binder
513− _ -> throwError $ "Constructor " ++ show ctor ++ " is not a unary constructor"
514− _ -> throwError $ "Constructor " ++ show ctor ++ " is not defined"
515−inferBinder val (ObjectBinder props) = do
516− row <- fresh
517− rest <- fresh
518− m1 <- inferRowProperties row rest props
519− val ~~ Object row
520− return m1
521− where
522− inferRowProperties :: Type -> Type -> [(String, Binder)] -> Subst (M.Map Ident Type)
523− inferRowProperties nrow row [] = nrow ~~ row >> return M.empty
524− inferRowProperties nrow row ((name, binder):binders) = do
525− propTy <- fresh
526− m1 <- inferBinder propTy binder
527− m2 <- inferRowProperties nrow (RCons name propTy row) binders
528− return $ m1 `M.union` m2
529−inferBinder val (ArrayBinder binders) = do
530− el <- fresh
531− m1 <- M.unions <$> mapM (inferBinder el) binders
532− val ~~ TypeApp Array el
533− return m1
534−inferBinder val (ConsBinder headBinder tailBinder) = do
535− el <- fresh
536− m1 <- inferBinder el headBinder
537− m2 <- inferBinder val tailBinder
538− val ~~ TypeApp Array el
539− return $ m1 `M.union` m2
540−inferBinder val (NamedBinder name binder) = do
541− m <- inferBinder val binder
542− return $ M.insert name val m
543−
544−checkBinders :: [Type] -> Type -> [([Binder], Maybe Guard, Value)] -> Subst [([Binder], Maybe Guard, Value)]
545−checkBinders _ _ [] = return []
546−checkBinders nvals ret ((binders, grd, val):bs) = do
547− moduleName <- substCurrentModule <$> ask
548− m1 <- M.unions <$> zipWithM inferBinder nvals binders
549− r <- bindLocalVariables moduleName (M.toList m1) $ do
550− val' <- check val ret
551− case grd of
552− Nothing -> return (binders, Nothing, val')
553− Just g -> do
554− g' <- check g Boolean
555− return (binders, Just g', val')
556− rs <- checkBinders nvals ret bs
557− return $ r : rs
558−
559−assignVariable :: Ident -> Subst ()
560−assignVariable name = do
561− env <- checkEnv <$> get
562− moduleName <- substCurrentModule <$> ask
563− case M.lookup (moduleName, name) (names env) of
564− Just (_, LocalVariable) -> throwError $ "Variable with name " ++ show name ++ " already exists."
565− _ -> return ()
566−
567−checkStatement :: M.Map Ident Type -> Type -> Statement -> Subst (Bool, M.Map Ident Type, Statement)
568−checkStatement mass _ (VariableIntroduction name val) = do
569− assignVariable name
570− val'@(TypedValue _ _ t) <- infer val
571− return (False, M.insert name t mass, VariableIntroduction name val')
572−checkStatement mass _ (Assignment ident val) = do
573− val'@(TypedValue _ _ t) <- infer val
574− case M.lookup ident mass of
575− Nothing -> throwError $ "No local variable with name " ++ show ident
576− Just ty -> do t ~~ ty
577− return (False, mass, Assignment ident val')
578−checkStatement mass ret (While val inner) = do
579− val' <- check val Boolean
580− (allCodePathsReturn, _, inner') <- checkBlock mass ret inner
581− return (allCodePathsReturn, mass, While val' inner')
582−checkStatement mass ret (If ifst) = do
583− (allCodePathsReturn, ifst') <- checkIfStatement mass ret ifst
584− return (allCodePathsReturn, mass, If ifst')
585−checkStatement mass ret (For ident start end inner) = do
586− moduleName <- substCurrentModule <$> ask
587− assignVariable ident
588− start' <- check start Number
589− end' <- check end Number
590− (allCodePathsReturn, _, inner') <- bindLocalVariables moduleName [(ident, Number)] $ checkBlock mass ret inner
591− return (allCodePathsReturn, mass, For ident start' end' inner')
592−checkStatement mass ret (Return val) = do
593− val' <- check val ret
594− return (True, mass, Return val')
595−
596−checkIfStatement :: M.Map Ident Type -> Type -> IfStatement -> Subst (Bool, IfStatement)
597−checkIfStatement mass ret (IfStatement val thens Nothing) = do
598− val' <- check val Boolean
599− (_, _, thens') <- checkBlock mass ret thens
600− return (False, IfStatement val' thens' Nothing)
601−checkIfStatement mass ret (IfStatement val thens (Just elses)) = do
602− val' <- check val Boolean
603− (allCodePathsReturn1, _, thens') <- checkBlock mass ret thens
604− (allCodePathsReturn2, elses') <- checkElseStatement mass ret elses
605− return (allCodePathsReturn1 && allCodePathsReturn2, IfStatement val' thens' (Just elses'))
606−
607−checkElseStatement :: M.Map Ident Type -> Type -> ElseStatement -> Subst (Bool, ElseStatement)
608−checkElseStatement mass ret (Else elses) = do
609− (allCodePathsReturn, _, elses') <- checkBlock mass ret elses
610− return (allCodePathsReturn, Else elses')
611−checkElseStatement mass ret (ElseIf ifst) = (id *** ElseIf) <$> checkIfStatement mass ret ifst
612−
613−checkBlock :: M.Map Ident Type -> Type -> [Statement] -> Subst (Bool, M.Map Ident Type, [Statement])
614−checkBlock mass _ [] = return (False, mass, [])
615−checkBlock mass ret (s:ss) = do
616− moduleName <- substCurrentModule <$> ask
617− (b1, mass1, s') <- checkStatement mass ret s
618− bindLocalVariables moduleName (M.toList mass1) $ case (b1, ss) of
619− (True, []) -> return (True, mass1, [s'])
620− (True, _) -> throwError "Unreachable code"
621− (False, ss') -> do
622− (b, m, ss'') <- checkBlock mass1 ret ss'
623− return (b, m, s':ss'')
624−
625−skolemize :: String -> Type -> Subst Type
626−skolemize ident ty = do
627− tsk <- Skolem <$> fresh'
628− return $ replaceTypeVars ident tsk ty
629−
630−check :: Value -> Type -> Subst Value
631−check val ty = rethrow errorMessage $ check' val ty
632− where
633− errorMessage msg =
634− "Error checking type of term " ++
635− prettyPrintValue val ++
636− " against type " ++
637− prettyPrintType ty ++
638− ":\n" ++
639− msg
640−
641−check' :: Value -> Type -> Subst Value
642−check' val (ForAll idents ty) = do
643− sk <- skolemize idents ty
644− check val sk
645−check' val (ConstrainedType constraints ty) = do
646− env <- getEnv
647− moduleName <- substCurrentModule <$> ask
648− dictNames <- flip mapM constraints $ \(Qualified _ (ProperName className), _) -> do
649− n <- liftCheck freshDictionaryName
650− return $ Ident $ "__dict_" ++ className ++ "_" ++ show n
651− val' <- withTypeClassDictionaries (zipWith (\name (className, instanceTy) ->
652− TypeClassDictionaryInScope name className instanceTy Nothing TCDRegular) (map (Qualified Nothing) dictNames)
653− (qualifyAllUnqualifiedNames moduleName env constraints)) $
654− check val ty
655− return $ Abs dictNames val'
656−check' val u@(TUnknown _) = do
657− val'@(TypedValue _ _ ty) <- infer val
658− -- Don't unify an unknown with an inferred polytype
659− ty' <- replaceAllVarsWithUnknowns ty
660− ty' ~~ u
661− return val'
662−check' v@(NumericLiteral _) Number = return v
663−check' v@(StringLiteral _) String = return v
664−check' v@(BooleanLiteral _) Boolean = return v
665−check' (Unary op val) ty = checkUnary op val ty
666−check' (Binary op left right) ty = checkBinary op left right ty
667−check' (ArrayLiteral vals) (TypeApp Array ty) = ArrayLiteral <$> forM vals (\val -> check val ty)
668−check' (Indexer index vals) ty = do
669− index' <- check index Number
670− vals' <- check vals (TypeApp Array ty)
671− return $ Indexer index' vals'
672−check' (Abs args ret) (Function argTys retTy) = do
673− moduleName <- substCurrentModule <$> ask
674− guardWith "Incorrect number of function arguments" (length args == length argTys)
675− ret' <- bindLocalVariables moduleName (zip args argTys) $ check ret retTy
676− return $ Abs args ret'
677−check' (App f args) ret = do
678− f'@(TypedValue _ _ ft) <- infer f
679− app <- checkFunctionApplication f' ft args ret
680− return $ app
681−check' (Var var) ty = do
682− moduleName <- substCurrentModule <$> ask
683− ty1 <- lookupVariable moduleName var
684− repl <- replaceAllTypeSynonyms ty1
685− repl `subsumes` ty
686− return $ Var var
687−check' (TypedValue checkType val ty1) ty2 = do
688− moduleName <- substCurrentModule <$> ask
689− kind <- liftCheck $ kindOf moduleName ty1
690− guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
691− ty1 `subsumes` ty2
692− val' <- if checkType then check val ty1 else return val
693− return $ TypedValue True val' ty1
694−check' (Case vals binders) ret = do
695− vals' <- mapM infer vals
696− let ts = map (\(TypedValue _ _ t) -> t) vals'
697− binders' <- checkBinders ts ret binders
698− return $ Case vals' binders'
699−check' (IfThenElse cond th el) ty = do
700− cond' <- check cond Boolean
701− th' <- check th ty
702− el' <- check el ty
703− return $ IfThenElse cond' th' el'
704−check' (ObjectLiteral ps) (Object row) = do
705− ensureNoDuplicateProperties ps
706− ps' <- checkProperties ps row False
707− return $ ObjectLiteral ps'
708−check' (ObjectUpdate obj ps) (Object row) = do
709− ensureNoDuplicateProperties ps
710− us <- zip (map fst ps) <$> replicateM (length ps) fresh
711− let (propsToCheck, rest) = rowToList row
712− propsToRemove = map fst ps
713− remainingProps = filter (\(p, _) -> p `notElem` propsToRemove) propsToCheck
714− obj' <- check obj (Object (rowFromList (us ++ remainingProps, rest)))
715− ps' <- checkProperties ps row True
716− return $ ObjectUpdate obj' ps'
717−check' (Accessor prop val) ty = do
718− rest <- fresh
719− val' <- check val (Object (RCons prop ty rest))
720− return $ Accessor prop val'
721−check' (Block ss) ret = do
722− (allCodePathsReturn, _, ss') <- checkBlock M.empty ret ss
723− guardWith "Block is missing a return statement" allCodePathsReturn
724− return $ Block ss'
725−check' (Constructor c) ty = do
726− env <- getEnv
727− moduleName <- substCurrentModule <$> ask
728− case M.lookup (qualify moduleName c) (dataConstructors env) of
729− Nothing -> throwError $ "Constructor " ++ show c ++ " is undefined"
730− Just (ty1, _) -> do
731− repl <- replaceAllTypeSynonyms ty1
732− repl `subsumes` ty
733− return $ Constructor c
734−check' val (SaturatedTypeSynonym name args) = do
735− ty <- expandTypeSynonym name args
736− check val ty
737−check' val ty = throwError $ prettyPrintValue val ++ " does not have type " ++ prettyPrintType ty
738−
739−checkProperties :: [(String, Value)] -> Type -> Bool -> Subst [(String, Value)]
740−checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where
741− go [] [] REmpty = return []
742− go [] [] u@(TUnknown _) = do u ~~ REmpty
743− return []
744− go [] [] (Skolem _) | lax = return []
745− go [] ((p, _): _) _ | lax = return []
746− | otherwise = throwError $ prettyPrintValue (ObjectLiteral ps) ++ " does not have property " ++ p
747− go ((p,_):_) [] REmpty = throwError $ "Property " ++ p ++ " is not present in closed object type " ++ prettyPrintRow row
748− go ((p,v):ps') [] u@(TUnknown _) = do
749− v'@(TypedValue _ _ ty) <- infer v
750− rest <- fresh
751− u ~~ RCons p ty rest
752− ps'' <- go ps' [] rest
753− return $ (p, v') : ps''
754− go ((p,v):ps') ts r =
755− case lookup p ts of
756− Nothing -> do
757− v'@(TypedValue _ _ ty) <- infer v
758− rest <- fresh
759− r ~~ RCons p ty rest
760− ps'' <- go ps' ts rest
761− return $ (p, v') : ps''
762− Just ty -> do
763− v' <- check v ty
764− ps'' <- go ps' (delete (p, ty) ts) r
765− return $ (p, v') : ps''
766− go _ _ _ = throwError $ prettyPrintValue (ObjectLiteral ps) ++ " does not have type " ++ prettyPrintType (Object row)
767−
768−checkFunctionApplication :: Value -> Type -> [Value] -> Type -> Subst Value
769−checkFunctionApplication fn fnTy args ret = rethrow errorMessage $ checkFunctionApplication' fn fnTy args ret
770− where
771− errorMessage msg = "Error applying function of type "
772− ++ prettyPrintType fnTy
773− ++ " to arguments " ++ intercalate ", " (map prettyPrintValue args)
774− ++ ":\n" ++ msg
775−
776−checkFunctionApplication' :: Value -> Type -> [Value] -> Type -> Subst Value
777−checkFunctionApplication' fn (Function argTys retTy) args ret = do
778− guardWith "Incorrect number of function arguments" (length args == length argTys)
779− args' <- zipWithM check args argTys
780− retTy `subsumes` ret
781− return $ App fn args'
782−checkFunctionApplication' fn (ForAll ident ty) args ret = do
783− replaced <- replaceVarWithUnknown ident ty
784− checkFunctionApplication fn replaced args ret
785−checkFunctionApplication' fn u@(TUnknown _) args ret = do
786− args' <- mapM (\arg -> infer arg >>= \(TypedValue _ v t) -> TypedValue True v <$> replaceAllVarsWithUnknowns t) args
787− let tys = map (\(TypedValue _ _ t) -> t) args'
788− u ~~ Function tys ret
789− return $ App fn args'
790−checkFunctionApplication' fn (SaturatedTypeSynonym name tyArgs) args ret = do
791− ty <- expandTypeSynonym name tyArgs
792− checkFunctionApplication fn ty args ret
793−checkFunctionApplication' fn (ConstrainedType constraints fnTy) args ret = do
794− env <- getEnv
795− dicts <- getTypeClassDictionaries
796− moduleName <- substCurrentModule <$> ask
797− checkFunctionApplication' (App fn (map (flip TypeClassDictionary dicts) (qualifyAllUnqualifiedNames moduleName env constraints))) fnTy args ret
798−checkFunctionApplication' _ fnTy args ret = throwError $ "Applying a function of type "
799− ++ prettyPrintType fnTy
800− ++ " to argument(s) " ++ intercalate ", " (map prettyPrintValue args)
801− ++ " does not yield a value of type " ++ prettyPrintType ret ++ "."
802−
803−subsumes :: Type -> Type -> Subst ()
804−subsumes (ForAll ident ty1) ty2 = do
805− replaced <- replaceVarWithUnknown ident ty1
806− replaced `subsumes` ty2
807−subsumes (Function args1 ret1) (Function args2 ret2) = do
808− zipWithM_ subsumes args2 args1
809− ret1 `subsumes` ret2
810−subsumes ty1 ty2 = ty1 ~~ ty2
811−
src/Language/PureScript/Types.hsdeleted−76
@@ -1,76 +0,0 @@
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
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 (Object ps) = all isPolyType (map snd . fst $ rowToList ps)
58−isPolyType (Function args ret) = all isPolyType args && isPolyType ret
59−isPolyType (TypeApp t1 t2) = isMonoType t1 && isMonoType t2
60−isPolyType (SaturatedTypeSynonym _ args) = all isPolyType args
61−isPolyType (ForAll _ ty) = isPolyType ty
62−isPolyType _ = True
63−
64−mkForAll :: [String] -> Type -> Type
65−mkForAll = flip . foldl . flip $ ForAll
66−
67−unit :: Type
68−unit = Object REmpty
69−
70−replaceTypeVars :: (Data d) => String -> Type -> d -> d
71−replaceTypeVars name t = everywhereBut (mkQ False isShadowed) (mkT replaceTypeVar)
72− where
73− replaceTypeVar (TypeVar v) | v == name = t
74− replaceTypeVar other = other
75− isShadowed (ForAll v _) | v == name = True
76− isShadowed _ = False
src/Language/PureScript/Unknown.hsdeleted−24
@@ -1,24 +0,0 @@
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.hsdeleted−120
@@ -1,120 +0,0 @@
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 TypeClassDictionaryType
79− = TCDRegular
80− | TCDAlias (Qualified Ident) deriving (Show, Eq, Data, Typeable)
81−
82−data TypeClassDictionaryInScope
83− = TypeClassDictionaryInScope { tcdName :: Qualified Ident
84− , tcdClassName :: Qualified ProperName
85− , tcdInstanceType :: Type
86− , tcdDependencies :: Maybe [(Qualified ProperName, Type)]
87− , tcdType :: TypeClassDictionaryType
88− } deriving (Show, Data, Typeable)
89−
90−data DoNotationElement
91− = DoNotationValue Value
92− | DoNotationBind Binder Value
93− | DoNotationLet Binder Value deriving (Show, Data, Typeable)
94−
95−data Statement
96− = VariableIntroduction Ident Value
97− | Assignment Ident Value
98− | While Value [Statement]
99− | For Ident Value Value [Statement]
100− | If IfStatement
101− | Return Value deriving (Show, Data, Typeable)
102−
103−data IfStatement = IfStatement Value [Statement] (Maybe ElseStatement) deriving (Show, Data, Typeable)
104−
105−data ElseStatement
106− = Else [Statement]
107− | ElseIf IfStatement deriving (Show, Data, Typeable)
108−
109−data Binder
110− = NullBinder
111− | BooleanBinder Bool
112− | StringBinder String
113− | NumberBinder (Either Integer Double)
114− | VarBinder Ident
115− | NullaryBinder (Qualified ProperName)
116− | UnaryBinder (Qualified ProperName) Binder
117− | ObjectBinder [(String, Binder)]
118− | ArrayBinder [Binder]
119− | ConsBinder Binder Binder
120− | NamedBinder Ident Binder deriving (Show, Data, Typeable)
src/Tests.hsnew file+141
@@ -0,0 +1,141 @@
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.nixnew file+23
@@ -0,0 +1,23 @@
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.yamlnew file+24
@@ -0,0 +1,24 @@
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.gonew file+30
@@ -0,0 +1,30 @@
1+package ffi_loader
2+
3+// Load PureScript standard library FFI packages. Comment out the ones you don't need for
4+// faster/smaller builds.
5+
6+import (
7+ _ "github.com/purescript-native/go-ffi/purescript-arrays"
8+ _ "github.com/purescript-native/go-ffi/purescript-assert"
9+ _ "github.com/purescript-native/go-ffi/purescript-console"
10+ _ "github.com/purescript-native/go-ffi/purescript-effect"
11+ _ "github.com/purescript-native/go-ffi/purescript-enums"
12+ _ "github.com/purescript-native/go-ffi/purescript-exceptions"
13+ _ "github.com/purescript-native/go-ffi/purescript-foldable-traversable"
14+ _ "github.com/purescript-native/go-ffi/purescript-functions"
15+ _ "github.com/purescript-native/go-ffi/purescript-globals"
16+ _ "github.com/purescript-native/go-ffi/purescript-integers"
17+ _ "github.com/purescript-native/go-ffi/purescript-lazy"
18+ _ "github.com/purescript-native/go-ffi/purescript-math"
19+ _ "github.com/purescript-native/go-ffi/purescript-partial"
20+ _ "github.com/purescript-native/go-ffi/purescript-prelude"
21+ _ "github.com/purescript-native/go-ffi/purescript-random"
22+ _ "github.com/purescript-native/go-ffi/purescript-refs"
23+ _ "github.com/purescript-native/go-ffi/purescript-st"
24+ _ "github.com/purescript-native/go-ffi/purescript-strings"
25+ _ "github.com/purescript-native/go-ffi/purescript-unfoldable"
26+)
27+
28+// Add your own FFI packages here.
29+
30+import ()
support/go.mod.ffi-loadernew file+2
@@ -0,0 +1,2 @@
1+module $PROJECT/purescript-native/ffi-loader
2+
support/go.mod.outputnew file+2
@@ -0,0 +1,2 @@
1+module $PROJECT/purescript-native/output
2+
support/go.mod.workingnew file+1
@@ -0,0 +1 @@
1+module $PROJECT/example
test/Spec.hsnew file+2
@@ -0,0 +1,2 @@
1+main :: IO ()
2+main = putStrLn "Test suite not yet implemented"
tests/Main.hsdeleted−71
@@ -1,71 +0,0 @@
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