git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
swap
355eb9b3893 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−789
@@ -1,802 +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−
21−## Experimental Features
22
23
23−- Modules
24+* [Haskell Stack](https://docs.haskellstack.org/en/stable/README/) (if you're running macOS 10.14.5+, you can use pre-built binaries from [here](https://github.com/andyarvanitis/purescript-native/releases/))
24−- Rank N Types
25
25
26−## Try It!
26+#### Requirements for using PureScript + purescript-native
27
27
28−Try PureScript in the browser [here](http://tryps.functorial.com/).
28+* A recent version (0.13+) of [purescript](https://github.com/purescript/purescript/releases).
29
29
30−## License
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.
31
34
32−See the `LICENSE` file
33
35
34−## Contributing
36+#### For more information and a Getting Started guide, please see
35−
37+* [`pscpp`](https://github.com/andyarvanitis/purescript-native/blob/cpp/README-cpp.md)
36−Contributions are always encouraged! Please see `CONTRIBUTING.md` for guidelines.
38+* [`psgo`](https://github.com/andyarvanitis/purescript-native/blob/golang/README-go.md)
37−
38−Join the discussion on FreeNode at [irc://irc.freenode.net#purescript](irc://irc.freenode.net#purescript).
39−
40−## Installation
41−
42−Install the Haskell Plaform, then `cabal install`
43−
44−## Usage
45−
46−The `psc` executable takes a list of PureScript source files as arguments and by default writes out its errors or output to the console.
47−
48−The following options are supported:
49−
50− -s --stdin
51− Read input from standard input instead of from files
52−
53− -o --output
54− Write the generated Javascript to the specified file
55−
56− -e --foreign imports
57− Write a list of foreign imports declarations to the specified file in addition to generating Javascript output
58−
59−## 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−foreign import console :: { log :: String -> {} }
81−
82−main = \ -> console.log "Hello, World!"
83−```
84−
85−which compiles to the following Javascript:
86−
87−```javascript
88−function main() {
89− console.log("Hello, World!");
90−}
91−```
92−
93−## Another Example
94−
95−The following code defines a `Person` data type and a function to generate a string representation for a `Person`:
96−
97−```haskell
98−data Person = Person { name :: String, age :: Number }
99−
100−foreign import numberToString :: Number -> String
101−
102−showPerson :: Person -> String
103−showPerson (Person o) = o.name ++ ", aged " ++ numberToString(o.age)
104−```
105−
106−Line by line, this reads as follows:
107−
108−- `Person` is a data type with one constructor, also called `Person`
109− - The `Person` constructor takes an object with two properties, `name` which is a `String`, and `age` which is a `Number`
110−- The `numberToString` function is written in Javascript, and converts a `Number` to its `String` representation
111−- The `showPerson` function takes a `Person` and returns a `String`
112−- `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.
113−
114−The generated Javascript looks like this:
115−
116−```javascript
117−var Person = function (value) {
118− return { ctor: 'Person', value: value };
119−};
120−
121−function showPerson(_1) {
122− if (_1.ctor === "Person") {
123− return _1.value.name + ", aged " + numberToString(_1.value.age);
124− };
125− throw "Failed pattern match";
126−};
127−
128−```
129−
130−## Type System
131−
132−The type system defines the following types:
133−
134−- Primitive Types
135− - Number
136− - String
137− - Boolean
138−- Arrays
139− - E.g. `[String]`, `[[Number]]`
140−- Records
141− - E.g. `{ foo :: String, bar :: Number }`
142−- Tagged Unions
143− - E.g. `data Foo a = Foo | Bar String`
144−- Functions
145− - E.g. `Number -> String`
146− - E.g. `(Number, Number) -> Number`
147− - Functions can have zero or more arguments
148−- Polymorphic types
149− - E.g. `forall a. a -> a`
150−
151−## Primitive Types
152−
153−The three primitive types `String`, `Number` and `Boolean` correspond to their Javascript equivalents at runtime.
154−
155−PureScript supports the same binary and unary operations on primitive types as Javascript, with the following exceptions:
156−
157−- String concatenation is denoted `++` to differentiate it from numeric addition, `+`
158−- PureScript's `==` and `!=` correspond to Javascript's strong equality tests `===` and `!==`
159−
160−Examples:
161−
162−```haskell
163−num = 1 + 2 * 3
164−str = "Hello, " ++ "World!"
165−bool = 1 > 2 || true
166−```
167−
168−## Arrays
169−
170−PureScript arrays correspond to Javascript arrays at runtime, but all elements must have the same type.
171−
172−Array literals look like Javascript array literals: `[1, 2, 3]`
173−
174−Array elements can be read using array index notation `arr !! index`
175−
176−## Records
177−
178−PureScript records correspond to Javascript objects.
179−
180−Record literals look like Javascript object literals: `{ foo: "Foo" }`
181−
182−Properties can be read by using dot notation: `o.foo`
183−
184−## Tagged Unions
185−
186−Tagged unions consist of one or more constructors, each of which takes zero or one arguments.
187−
188−Tagged unions can only be created using their constructors, and deconstructed through pattern matching (see later).
189−
190−For example:
191−
192−```haskell
193−data Foo a = Foo | Bar String
194−
195−runFoo Foo = "It's a Foo"
196−runFoo (Bar s) = "It's a Bar. The string is " ++ s
197−
198−test = runFoo Foo ++ runFoo (Bar "Test")
199−```
200−
201−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.
202−
203−`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.
204−
205−## Functions
206−
207−Functions in PureScript can have zero or more arguments in general, just like in Javascript.
208−
209−Functions are introduced by using a backslash followed by a list of argument names:
210−
211−```haskell
212−test1 = \a b -> a + b
213−```
214−
215−which would correspond to the Javascript
216−
217−```javascript
218−function test1(a) {
219− return function (b) {
220− return a + b;
221− }
222−}
223−```
224−
225−Multiple argument functions can be introduced by wrapping the arguments in parentheses, and separating them with commas:
226−
227−```haskell
228−test1 = \(a, b) -> a + b
229−```
230−
231−which generates
232−
233−```javascript
234−function test1(a, b) {
235− return a + b;
236−}
237−```
238−
239−In the case of a function with no arguments, the parentheses may be omitted, as follows:
240−
241−```haskell
242−test2 = \ -> 100
243−```
244−
245−which would correspond to the Javascript `function test2() { return 100; }`
246−
247−Multiple-argument and single-argument syntax can be mixed, as follows:
248−
249−```haskell
250−test3 = \a (b, c) d -> a + b + c + d
251−```
252−
253−which generates
254−
255−```javascript
256−function test3(a) {
257− return function (b, c) {
258− return function (d) {
259− return a + b + c + d;
260− }
261− }
262−}
263−```
264−
265−Functions are applied by providing their arguments inside parentheses:
266−
267−```haskell
268−test1(1, 2, 3)
269−test2()
270−```
271−
272−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:
273−
274−```haskell
275−-- has type Number -> Number -> Number -> Number
276−addThree = \a b c -> a + b + c
277−
278−-- has type Number -> Number -> Number
279−addThree 1
280−
281−-- has type Number -> Number
282−addThree 1 2
283−
284−-- has type Number
285−addThree 1 2 3
286−```
287−
288−## Polymorphic Types
289−
290−Expressions defined at the top level may have polymorphic types.
291−
292−Here is an example:
293−
294−```haskell
295−identity x = x
296−```
297−
298−`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.
299−
300−A type annotation can also be provided:
301−
302−```haskell
303−identity :: forall a. a -> a
304−identity x = x
305−```
306−
307−Functions may also be polymorphic in row types or type variables with other kinds (see "Kind System"):
308−
309−```haskell
310−addProps o = o.foo + o.bar
311−```
312−
313−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*.
314−
315−So, the following compiles:
316−
317−```haskell
318−addProps { foo: 1, bar: 2, baz: 3 }
319−```
320−
321−but the following does not:
322−
323−```haskell
324−addProps { foo: 1 }
325−```
326−
327−since the `bar` property is missing.
328−
329−Again, a type annotation can be provided if necessary.
330−
331−## Rank N Types (Experimental Feature)
332−
333−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.
334−
335−In most cases, a type annotation is necessary when using this feature.
336−
337−As an example, we can pass a polymorphic function as an argument to another function:
338−
339−```haskell
340−poly :: (forall a. a -> a) -> Boolean
341−poly f = (f 0 < 1) == f true
342−```
343−
344−Notice that the polymorphic function's type argument is instantiated to both `Number` and `Boolean`.
345−
346−An argument to `poly` must indeed be polymorphic. For example, the following fails:
347−
348−```haskell
349−test = poly (\n -> n + 1)
350−```
351−
352−since the skolemized type variable `a` does not unify with `Number`.
353−
354−## Type Inference
355−
356−All types can be inferred, but annotations can optionally be provided.
357−
358−## Kind System
359−
360−There are two primitive kinds, the kind `*` of types and the kind `#` of rows. Higher kinded types are also supported. That is, a type variable can refer to not only a type or a row, but a type constructor, or row constructor etc.
361−
362−## Whitespace
363−
364−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.
365−
366−That is, the following is valid:
367−
368−```haskell
369−foo = bar(x) +
370− baz(x)
371−```
372−
373−But this is not:
374−
375−```haskell
376−foo = bar(x) +
377−baz(x)
378−```
379−
380−## Blocks
381−
382−Blocks are collections of statements wrapped in braces `{ ... }`. Blocks must return a value of the same type on every branch of execution.
383−
384−The following types of statement are supported:
385−
386−- Variable introduction
387−- Variable assignment
388−- For loops
389−- For-each loops
390−- While loops
391−- If-Then-Else statements
392−- Naked expressions
393−
394−Here is an example of a power function defined using a block:
395−
396−```haskell
397−pow n p = {
398− var m = n;
399− for (i <- 0 until p) {
400− m = m * n;
401− }
402− return m;
403− }
404−```
405−
406−Blocks enable local mutation of their variables, but mutation is not allowed in general. The type system prevents mutable variables from escaping their scope.
407−
408−That is, while the example above is valid, the following does not compile:
409−
410−```haskell
411−incr n = {
412− n = n + 1;
413− return n;
414− }
415−```
416−
417−The variable `n` is not mutable, and so the assignment in the first line of the `do` block is not allowed.
418−
419−This function can be rewritten as follows:
420−
421−```haskell
422−incr n = {
423− var m = n;
424− m = m + 1;
425− return m;
426− }
427−```
428−
429−## For Loops
430−
431−For loops look like this:
432−
433−```haskell
434−total = {
435− var n = 0;
436− for (i <- 0 until 10) {
437− n = n + i;
438− }
439− return n;
440− }
441−```
442−
443−The bounds `0` and `10` are inclusive and exclusive respectively.
444−
445−## For-Each Loops
446−
447−For each loops loop over the elements in an array using the `Object.forEach` method. A polyfill may be required for some browsers:
448−
449−```haskell
450−total arr = {
451− var n = 0;
452− foreach (i in arr) {
453− n = n + i;
454− }
455− return n;
456− }
457−```
458−
459−## While Loops
460−
461−The syntax of a while loop is similar to a foreach loop:
462−
463−```haskell
464−log2 n = {
465− var count = 0;
466− var m = n;
467− while (m > 1) {
468− m = m / 2;
469− count = count + 1;
470− }
471− return count;
472− }
473−```
474−
475−## If-Then-Else Statements
476−
477−Else branches are optional, and may contain further `if` statements, just as in Javascript:
478−
479−```haskell
480−collatz n = {
481− var count = 0;
482− var m = n;
483− while (m > 1) {
484− if (m % 2 == 0) {
485− m = m / 2;
486− } else {
487− m = m * 3 + 1;
488− }
489− count = count + 1;
490− }
491− return count;
492− }
493−```
494−
495−## Naked Expressions as Statements
496−
497−Any expression with the empty type `{ }` can be used as a statement in a block. For example, method calls which return `{ }`:
498−
499−```haskell
500−example n m = {
501− console.log "Adding two numbers"
502− return n + m;
503− }
504−```
505−
506−## If-Then-Else Expressions
507−
508−The `if`, `then` and `else` keywords can also be used to create conditional expressions. In this case, the `else` block is always required.
509−
510−For example,
511−
512−```haskell
513−conditional = if 2 > 1 then "ok" else "oops"
514−```
515−
516−## Pattern Matching
517−
518−Pattern matching deconstructs a value to bring zero or more expressions into scope. Pattern matches are introduced with the `case` keyword.
519−
520−Pattern matches have the following general form
521−
522−```haskell
523−case value of
524− pattern -> result
525− -- ...
526− pattern -> result
527−```
528−
529−Pattern matching can also be used in the declaration of functions, as we have already seen:
530−
531−```haskell
532−fn pattern_1 ... pattern_n = result
533−```
534−
535−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,
536−
537−```haskell
538−example x (y, z) w = x * y + z * w
539−```
540−
541−The following pattern types are supported:
542−
543−- Wildcard pattern
544−- Literal patterns
545−- Variable pattern
546−- Array patterns
547−- Cons patterns
548−- Record patterns
549−- Named patterns
550−- Guards
551−
552−Patterns need not be exhaustive. A pattern match failed exception will be thrown at runtime if no pattern matches the input.
553−
554−## Wildcard Patterns
555−
556−The wilcard `_` matches any input and brings nothing into scope:
557−
558−```haskell
559−case x of
560− _ -> 0
561−```
562−
563−## Literal Patterns
564−
565−Literal patterns are provided to match on primitives:
566−
567−```haskell
568−case booleanValue of
569− true -> 0
570− false -> 1
571−
572−case stringValue of
573− "Foo" -> 0
574− _ -> 1
575−
576−case numericValue of
577− 0 -> 0
578− _ -> 1
579−```
580−
581−## Variable Pattern
582−
583−A variable pattern matches any input and binds that input to its name:
584−
585−```haskell
586−case foo(x) of
587− result -> bar(result)
588−```
589−
590−## Array Patterns
591−
592−Array patterns match an input which is an array, and bring its elements into scope.
593−
594−For example:
595−
596−```haskell
597−f = \arr -> case arr of
598− [x] -> x
599− [x, y] -> x * y + f xs
600− _ -> 0
601−```
602−
603−Here, the first pattern only matches arrays of length one, and brings the first element of the array into scope.
604−
605−The second pattern matches arrays with two elements, and brings the first and second elements into scope.
606−
607−## Cons Patterns
608−
609−The head and tail of a non-empty array can be matched by using a cons pattern:
610−
611−```haskell
612−add = \arr -> case arr of
613− [] -> 0
614− x : xs -> x + add xs
615−```
616−
617−`:` associates to the right:
618−
619−```haskell
620−addPairs = \arr -> case arr of
621− x : y : xs -> x * y + addPairs xs
622− _ -> 0
623−```
624−
625−## Record Patterns
626−
627−Record patterns match an input which is a record, and bring its properties into scope.
628−
629−```haskell
630−f = \o -> case o of
631− { foo = "Foo" } -> o.bar
632− _ -> 0
633−```
634−
635−## Nested Patterns
636−
637−The patterns above can be combined to create larger patterns.
638−
639−For example:
640−
641−```haskell
642−f = \o -> case o of
643− { arr = x : _, take = "car" } -> x
644− { arr = _ : x : _, take = "cadr" } -> x
645− _ -> 0
646−```
647−
648−## Named Patterns
649−
650−Named patterns bring additional names into scope when using nested patterns. Any pattern can be named by using the `@` symbol:
651−
652−```haskell
653−f = \arr -> case arr of
654− a@(_ : _ : _) -> true
655− a -> false
656−```
657−
658−Here, in the first pattern, any array with two or more elements will be matched and bound to the variable `a`.
659−
660−## Guards
661−
662−Guards are used to impose additional constraints inside a pattern using boolean-valued expressions, and are introduced with a pipe after the pattern:
663−
664−```haskell
665−evens = \arr -> case arr of
666− [] -> 0
667− x : xs | x % 2 == 0 -> 1 + evens xs
668− _ : xs -> evens xs
669−```
670−
671−When defining a function, guards appear after all patterns:
672−
673−```haskell
674−greater x y | x > y = true
675−greater _ _ = false
676−```
677−
678−## Type Synonyms
679−
680−For convenience, it is possible to declare a synonym for a type using the `type` keyword. Type synonyms can include type arguments.
681−
682−For example:
683−
684−```haskell
685−type Foo = { foo :: Number, bar Number }
686−
687−addFoo :: Foo -> Number
688−addFoo = \o -> o.foo + o.bar
689−```
690−## Record Updates
691−
692−Properties on records can be updated using the following syntax: `o { key = value, ..., key = value }`
693−
694−For example, the following function increments the `foo` property on its argument:
695−
696−```haskell
697−incr = \o -> o { foo = o.foo + 1 }
698−```
699−
700−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
701−
702−```haskell
703−Object.prototype.extend = function(o, p) {
704− return $.extend({}, o, p);
705−};
706−```
707−
708−## Operators
709−
710−In addition to the standard operators, user-defined infix operators can be created by enclosing names in parentheses:
711−
712−E.g. to create a synonym for string concatenation:
713−
714−```haskell
715−(<>) = \s1 s2 -> s1 ++ s2
716−
717−greeting = "Hello" <> "World!"
718−```
719−
720−Regular functions can be used as operators by enclosing their names in backticks:
721−
722−```haskell
723−foo = \x y -> x * y + y
724−
725−test = 10 `foo` 20
726−```
727−
728−Fixity declarations can associate a precedence level, which is a natural number, to a user-defined operator, and specify which way it associates:
729−
730−```haskell
731−infixl 5 <>
732−infixr 7 %%
733−```
734−
735−## Modules
736−
737−Simple modules are supported by the `module` keyword.
738−
739−Introduce a module as follows, with a list of indented declarations:
740−
741−```haskell
742−module A where
743−
744− foo = \x -> x
745−```
746−
747−Modules may be nested:
748−
749−```haskell
750−module A where
751−
752− foo = \x -> x
753−
754− module B where
755−
756− bar = \y -> y
757−```
758−
759−Names may be qualified by using a dot:
760−
761−```
762−foo = A.foo
763−bar = A.B.bar
764−```
765−
766−All the names in a module can be aliased using the `import` declaration:
767−
768−```haskell
769−import A
770−```
771−
772−You can also limit which names are going to be aliased:
773−
774−```haskell
775−import A.B (bar)
776−```
777−
778−## Foreign Function Interface
779−
780−The `foreign import` keyword declares a value which is defined in Javascript, and its type:
781−
782−```haskell
783−foreign import pow :: (Number, Number) -> Number
784−```
785−
786−To declare a new type with no constructors, use `foreign import data` and provide the kind:
787−
788−```haskell
789−foreign import data IO :: * -> *
790−
791−foreign import console :: {
792− log :: String -> IO {}
793−}
794−```
795−
796−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:
797−
798−```haskell
799−foreign import member "length" length :: forall a. [a] -> Number
800−```
801
39
802
40
41+---
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+}
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/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/TypeError.pursdeleted−3
@@ -1,3 +0,0 @@
1−module TypeError where
2−
3− test = x ++ "A"
examples/passing/Arrays.pursdeleted−22
@@ -1,22 +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−
22−
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−10
@@ -1,10 +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
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/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/Foreach.pursdeleted−9
@@ -1,9 +0,0 @@
1−module Foreach where
2−
3− sum = \ns -> {
4− var total = 0;
5− foreach (n in ns) {
6− total = total + n;
7− }
8− return total;
9− }
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/MethodCall.pursdeleted−8
@@ -1,8 +0,0 @@
1−module MethodCall where
2−
3− foreign import foo :: () -> {}
4−
5− test = {
6− foo();
7− return 0;
8− }
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/Operators.pursdeleted−44
@@ -1,44 +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]
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/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/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/Foreach.jsdeleted−1
@@ -1 +0,0 @@
1−console.log(Foreach.sum([1,2,3,4,5]));
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−23
@@ -1,23 +0,0 @@
1−# Maybe
2−mkdir -p tests && ../../dist/build/psc/psc ../passing/Maybe.purs -o tests/Maybe.js && cat tests/Maybe.js Maybe.js | nodejs
3−<<<
4−>>>
5−{ ctor: '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−
17−# Foreach
18−mkdir -p tests && ../../dist/build/psc/psc ../passing/Foreach.purs -o tests/Foreach.js && cat tests/Foreach.js Foreach.js | nodejs
19−<<<
20−>>>
21−15
22−>>>2
23−>>>= 0
examples/shelltest/runMain.jsdeleted−1
@@ -1 +0,0 @@
1−main();
libraries/.gitignoredeleted−1
@@ -1 +0,0 @@
1−*/all.js
libraries/jquery/Makefiledeleted−4
@@ -1,4 +0,0 @@
1−all:
2− ../../dist/build/psc/psc jquery.purs example.purs -o all.js
3− cat jquery.js >> all.js
4− echo "main()" >> all.js
libraries/jquery/example.pursdeleted−10
@@ -1,10 +0,0 @@
1−module Example where
2−
3− import JQuery
4−
5− main = {
6− var div = create "<div>";
7− div = div `appendText` "Hello World!" `css` { color: "#FF0000" };
8− div = div `appendTo` select "body";
9− return { };
10− }
libraries/jquery/jquery.jsdeleted−7
@@ -1,7 +0,0 @@
1−function select(s) { return $(s); }
2−function create(s) { return $(s); }
3−function attr(j, a) { return j.attr(o); }
4−function css(j, a) { return j.css(o); }
5−function append(j1, j2) { return j1.append(j2); }
6−function appendTo(j1, j2) { return j1.appendTo(j2); }
7−function appendText(j1, s) { return j1.append(s); }
libraries/jquery/jquery.pursdeleted−25
@@ -1,25 +0,0 @@
1−module JQuery where
2−
3− -- The jQuery wrapper type
4− foreign import data JQuery :: *
5−
6− -- Wrapper function for jQuery selection $('..')
7− foreign import select :: String -> JQuery
8−
9− -- Wrapper function for jQuery creation e.g. $('<div>')
10− foreign import create :: String -> JQuery
11−
12− -- .attr({ ... })
13− foreign import attr :: forall attr. JQuery -> { | attr } -> JQuery
14−
15− -- .css({ ... })
16− foreign import css :: forall css. JQuery -> { | css } -> JQuery
17−
18− -- .append(...)
19− foreign import append :: JQuery -> JQuery -> JQuery
20−
21− -- .appendTo(...)
22− foreign import appendTo :: JQuery -> JQuery -> JQuery
23−
24− -- .append(...)
25− foreign import appendText :: JQuery -> String -> JQuery
libraries/prelude/Makefiledeleted−3
@@ -1,3 +0,0 @@
1−all:
2− ../../dist/build/psc/psc prelude.purs -o all.js
3− cat prelude.js >> all.js
libraries/prelude/prelude.jsdeleted−65
@@ -1,65 +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−
43−function map(f) {
44− return function(xs) {
45− var ys = [];
46− for (var i = 0; i < xs.length; i++) {
47− ys[i] = f(xs[i]);
48− }
49− return ys;
50− };
51−}
52−
53−function filter(xs) {
54− return function (p) {
55− var ys = [];
56− var j = 0;
57− for (var i = 0; i < xs.length; i++) {
58− var x = xs[i];
59− if (p(x)) {
60− ys[j++] = x;
61− }
62− }
63− return ys;
64− };
65−}
libraries/prelude/prelude.pursdeleted−269
@@ -1,269 +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− (<|) :: forall a b c. (b -> c) -> (a -> b) -> a -> c
16− (<|) = flip (|>)
17−
18−module Maybe where
19−
20− data Maybe a = Nothing | Just a
21−
22− maybe :: forall a b. b -> (a -> b) -> Maybe a -> b
23− maybe b _ Nothing = b
24− maybe _ f (Just a) = f a
25−
26− fromMaybe :: forall a. a -> Maybe a -> a
27− fromMaybe a = maybe a Prelude.id
28−
29− bindMaybe :: forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
30− bindMaybe m f = maybe Nothing f m
31−
32−module Either where
33−
34− data Either a b = Left a | Right b
35−
36− either :: forall a b c. (a -> c) -> (b -> c) -> Either a b -> c
37− either f _ (Left a) = f a
38− either _ g (Right b) = g b
39−
40− bindEither :: forall e a b. Either e a -> (a -> Either e b) -> Either e b
41− bindEither = either (\e _ -> Left e) (\a f -> f a)
42−
43−module Arrays where
44−
45− import Maybe
46−
47− head :: forall a. [a] -> a
48− head (x : _) = x
49−
50− headSafe :: forall a. [a] -> Maybe a
51− headSafe (x : _) = Just x
52− headSafe _ = Nothing
53−
54− tail :: forall a. [a] -> [a]
55− tail (_ : xs) = xs
56−
57− tailSafe :: forall a. [a] -> Maybe [a]
58− tailSafe (_ : xs) = Just xs
59− tailSafe _ = Nothing
60−
61− foreign import map :: forall a b. (a -> b) -> [a] -> [b]
62−
63− foldr :: forall a b. (a -> b -> a) -> a -> [b] -> a
64− foldr f a (b : bs) = f (foldr f a bs) b
65− foldr _ a [] = a
66−
67− foldl :: forall a b. (a -> b -> b) -> b -> [a] -> b
68− foldl f b as = {
69− var result = b;
70− foreach (a in as) {
71− result = f a result;
72− }
73− return result;
74− }
75−
76− foreign import member "length" length :: forall a. [a] -> Number
77−
78− foreign import indexOf :: forall a. [a] -> a -> Number
79−
80− foreign import lastIndexOf :: forall a. [a] -> a -> Number
81−
82− foreign import concat :: forall a. [a] -> [a] -> [a]
83−
84− foreign import join :: [String] -> String
85−
86− foreign import joinWith :: [String] -> String -> String
87−
88− foreign import push :: forall a. [a] -> a -> [a]
89−
90− foreign import reverse :: forall a. [a] -> [a]
91−
92− foreign import shift :: forall a. [a] -> [a]
93−
94− foreign import slice :: forall a. Number -> Number -> [a] -> [a]
95−
96− foreign import sort :: forall a. [a] -> [a]
97−
98− foreign import splice :: forall a. Number -> Number -> [a] -> [a] -> [a]
99−
100− cons :: forall a. a -> [a] -> [a]
101− cons a = concat [a]
102−
103− concatMap :: forall a b. [a] -> (a -> [b]) -> [b]
104− concatMap as f = {
105− var result = [];
106− foreach (a in as) {
107− result = result `concat` f a;
108− }
109− return result;
110− }
111−
112− foreign import filter :: forall a. [a] -> (a -> Boolean) -> [a]
113−
114− empty :: forall a. [a] -> Boolean
115− empty [] = true
116− empty _ = false
117−
118− range :: Number -> Number -> [Number]
119− range lo hi = {
120− var ns = [];
121− for (n <- lo until hi) {
122− ns = push ns n;
123− }
124− return ns;
125− }
126−
127− zipWith :: forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
128− zipWith f (a:as) (b:bs) = cons (f a b) (zipWith f as bs)
129− zipWith _ _ _ = []
130−
131− any :: forall a. (a -> Boolean) -> [a] -> Boolean
132− any p as = {
133− for (i <- 0 until length as) {
134− if (p (as !! i)) {
135− return true;
136− }
137− }
138− return false;
139− }
140−
141− all :: forall a. (a -> Boolean) -> [a] -> Boolean
142− all p as = {
143− for (i <- 0 until length as) {
144− if (!(p (as !! i))) {
145− return false;
146− }
147− }
148− return true;
149− }
150−
151−module Tuple where
152−
153− import Arrays
154−
155− type Tuple a b = { fst :: a, snd :: b }
156−
157− curry :: forall a b c. (Tuple a b -> c) -> a -> b -> c
158− curry f a b = f { fst: a, snd: b }
159−
160− uncurry :: forall a b c. (a -> b -> c) -> Tuple a b -> c
161− uncurry f t = f t.fst t.snd
162−
163− tuple :: forall a b. a -> b -> Tuple a b
164− tuple = curry Prelude.id
165−
166− zip :: forall a b. [a] -> [b] -> [Tuple a b]
167− zip = zipWith tuple
168−
169− unzip :: forall a b. [Tuple a b] -> Tuple [a] [b]
170− unzip (t:ts) = case unzip ts of
171− { fst = as, snd = bs } -> tuple (cons t.fst as) (cons t.snd bs)
172− unzip [] = tuple [] []
173−
174−module String where
175−
176− foreign import member "length" lengthS :: String -> Number
177−
178− foreign import charAt :: Number -> String -> String
179−
180− foreign import indexOfS :: String -> String -> Number
181−
182− foreign import lastIndexOfS :: String -> String -> Number
183−
184− foreign import localeCompare :: String -> String -> Number
185−
186− foreign import replace :: String -> String -> String -> String
187−
188− foreign import sliceS :: Number -> Number -> String -> String
189−
190− foreign import split :: String -> String -> [String]
191−
192− foreign import substr :: Number -> Number -> String -> String
193−
194− foreign import substring :: Number -> Number -> String -> String
195−
196− foreign import toLower :: String -> String
197−
198− foreign import toUpper :: String -> String
199−
200− foreign import trim :: String -> String
201−
202−module Regex where
203−
204− foreign import data Regex :: *
205−
206− foreign import regex :: String -> String -> Regex
207−
208− foreign import test :: Regex -> String -> Boolean
209−
210− foreign import match :: Regex -> String -> [String]
211−
212− foreign import replaceR :: Regex -> String -> String -> String
213−
214− foreign import search :: Regex -> String -> Number
215−
216−module Global where
217−
218− foreign import nan :: Number
219−
220− foreign import infinity :: Number
221−
222− foreign import toExponential :: Number -> String
223−
224− foreign import toFixed :: Number -> Number -> String
225−
226− foreign import toPrecision :: Number -> Number -> String
227−
228− foreign import numberToString :: Number -> String
229−
230− foreign import isNaN :: Number -> Boolean
231−
232− foreign import isFinite :: Number -> Boolean
233−
234− foreign import parseFloat :: String -> Number
235−
236− foreign import parseInt :: String -> Number
237−
238− foreign import encodeURIComponent :: String -> String
239−
240− foreign import decodeURIComponent :: String -> String
241−
242− foreign import encodeURI :: String -> String
243−
244− foreign import decodeURI :: String -> String
245−
246−module Math where
247−
248− type Math =
249− { abs :: Number -> Number
250− , acos :: Number -> Number
251− , asin :: Number -> Number
252− , atan :: Number -> Number
253− , atan2 :: (Number, Number) -> Number
254− , aceil :: Number -> Number
255− , cos :: Number -> Number
256− , exp :: Number -> Number
257− , floor :: Number -> Number
258− , log :: Number -> Number
259− , max :: (Number, Number) -> Number
260− , pow :: (Number, Number) -> Number
261− , random :: () -> Number
262− , round :: Number -> Number
263− , sin :: Number -> Number
264− , sqrt :: Number -> Number
265− , tan :: Number -> Number
266− }
267−
268− foreign import math :: Math
269−
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
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−63
@@ -1,63 +0,0 @@
1−name: purescript
2−version: 0.2.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−
16−library
17− build-depends: base >=4 && <5, cmdtheline -any, containers -any,
18− directory -any, filepath -any, mtl -any, parsec -any, syb -any,
19− transformers -any, utf8-string -any
20− exposed-modules: Language.PureScript.TypeDeclarations
21− Language.PureScript.BindingGroups Language.PureScript.Scope
22− Data.Generics.Extras Language.PureScript
23− Language.PureScript.CodeGen Language.PureScript.CodeGen.Externs
24− Language.PureScript.CodeGen.JS Language.PureScript.CodeGen.JS.AST
25− Language.PureScript.CodeGen.Monad Language.PureScript.Declarations
26− Language.PureScript.Kinds Language.PureScript.Names
27− Language.PureScript.Operators Language.PureScript.Optimize
28− Language.PureScript.Parser Language.PureScript.Parser.Common
29− Language.PureScript.Parser.Declarations
30− Language.PureScript.Parser.Kinds Language.PureScript.Parser.State
31− Language.PureScript.Parser.Types Language.PureScript.Parser.Values
32− Language.PureScript.Pretty Language.PureScript.Pretty.Common
33− Language.PureScript.Pretty.JS Language.PureScript.Pretty.Kinds
34− Language.PureScript.Pretty.Types Language.PureScript.Pretty.Values
35− Language.PureScript.TypeChecker
36− Language.PureScript.TypeChecker.Kinds
37− Language.PureScript.TypeChecker.Monad
38− Language.PureScript.TypeChecker.Synonyms
39− Language.PureScript.TypeChecker.Types Language.PureScript.Types
40− Language.PureScript.Unknown Language.PureScript.Values Main
41− Language.PureScript.CaseDeclarations
42− exposed: True
43− buildable: True
44− hs-source-dirs: src
45−
46−executable psc
47− build-depends: base >=4 && <5, cmdtheline -any, containers -any,
48− directory -any, filepath -any, mtl -any, parsec -any,
49− purescript -any, syb -any, transformers -any, utf8-string -any
50− main-is: Main.hs
51− buildable: True
52− hs-source-dirs: src
53− other-modules:
54− ghc-options: -Wall -O2 -fno-warn-unused-do-bind
55−
56−test-suite tests
57− build-depends: base >=4 && <5, cmdtheline -any, containers -any,
58− directory -any, filepath -any, mtl -any, parsec -any,
59− purescript -any, syb -any, transformers -any, utf8-string -any
60− type: exitcode-stdio-1.0
61− main-is: Main.hs
62− buildable: True
63− hs-source-dirs: tests
release.mddeleted−86
@@ -1,86 +0,0 @@
1−## 0.2.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
9−
10−- RankNTypes
11−
12− This experimental feature allows polymorphic types (introduced with `forall`) to appear on the left of a function arrow, or as the type of a record field, etc. For example:
13−
14− rank2 :: (forall a. a -> a) -> Number
15− rank2 = \f -> if f true then f 1 else f 2
16−
17−- Modules
18−- Polymorphic Object Update
19−
20− Records now support member update in which the type of the field changes during the update. For example:
21−
22− data Wrap a = Wrap a
23−
24− update = \o -> o { prop = Wrap o.prop }
25−
26−### Enhancements
27−
28−- Naked expressions as statements
29−
30− Naked expressions of type `{}` can now be used as statements.
31−
32−- Split code generation into `AST -> JS` and `JS -> String`
33−
34− JavaScript generation is now split into the generation of a JavaScript AST, and the pretty-printing of that AST. This enables some optimizations, and a better JavaScript pretty-printer.
35−
36−- Syntactic sugar for introducing curried functions
37−
38− Single-argument functions and multiple-argument functions can now be introduced in the same way:
39−
40− test = \a (b, c) d -> a + b + c + d
41−
42−- JavaScript optimizations
43−
44− Some basic dead-variable elimination, inlining and eta-conversion are now performed on the generated JavaScript.
45−
46−- Generate formatted Javascript
47−
48− The generated JavaScript is now formatted to be more readable. In particular, newlines get generated, and the correct indentation is used.
49−
50−- More valid infix operators
51−
52− The colon and period characters are now valid in infix operator names.
53−
54−### Syntax Changes
55−
56−- Avoid 'do' keyword for blocks
57−
58− `do` will be used later for Haskell-like monad comprehensions, so its previous use in introducing blocks of statements is now invalid. The `do` keyword is still reserved.
59−
60−- Member foreign import syntax
61−
62− A small syntactic addition to the FFI, to support a common use case.
63−
64−- Make FFI syntax match Haskell
65−
66− Use `foreign import` instead of `extern`.
67−
68−- Make record declaration syntax match Haskell
69−- Simplify array binders
70−
71− There are now two types of array binders: cons binders `x : xs -> ...` and array binders `[x, y, z] -> ...` instead of the previously confusing `[x:xs]`.
72−
73−- Array indexing syntax is ambiguous
74−
75− Array elements are now accessed using the `!!` operator: `arr !! 0` etc.
76−
77−### Bug Fixes
78−
79−- Allow guards access to current scope
80−
81−### Libraries
82−
83−- Prelude
84−
85− There is now a basic prelude in the `libraries/prelude` folder.
86−
src/CodeGen/IL.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−42
@@ -1,42 +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.Optimize as P
27−import Language.PureScript.Operators as P
28−import Language.PureScript.CaseDeclarations as P
29−import Language.PureScript.TypeDeclarations as P
30−import Language.PureScript.BindingGroups as P
31−
32−import Data.List (intercalate)
33−import Control.Monad (forM_, (>=>))
34−
35−compile :: [Module] -> Either String (String, String, Environment)
36−compile ms = do
37− bracketted <- rebracket ms
38− desugared <- desugarCasesModule >=> desugarTypeDeclarationsModule >=> (return . createBindingGroupsModule) $ bracketted
39− (_, env) <- runCheck $ forM_ desugared $ \(Module moduleName decls) -> typeCheckAll (ModuleName moduleName) decls
40− let js = prettyPrintJS . map optimize . concatMap (flip moduleToJs env) $ desugared
41− let exts = intercalate "\n" . map (flip moduleToPs env) $ desugared
42− return (js, exts, env)
src/Language/PureScript/BindingGroups.hsdeleted−98
@@ -1,98 +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.BindingGroups (
16− createBindingGroups,
17− createBindingGroupsModule
18−) where
19−
20−import Data.Data
21−import Data.Graph
22−import Data.Generics
23−import Data.List (nub, intersect)
24−
25−import Language.PureScript.Declarations
26−import Language.PureScript.Names
27−import Language.PureScript.Values
28−import Language.PureScript.Types
29−
30−createBindingGroupsModule :: [Module] -> [Module]
31−createBindingGroupsModule = map $ \(Module name ds) -> Module name (createBindingGroups ds)
32−
33−createBindingGroups :: [Declaration] -> [Declaration]
34−createBindingGroups ds =
35− let
36− values = filter isValueDecl ds
37− dataDecls = filter isDataDecl ds
38− nonValues = filter (\d -> not (isValueDecl d) && not (isDataDecl d)) ds
39− allProperNames = map getProperName dataDecls
40− dataVerts = map (\d -> (d, getProperName d, usedProperNames d `intersect` allProperNames)) dataDecls
41− dataBindingGroupDecls = map toDataBindingGroup $ stronglyConnComp dataVerts
42− allIdents = map getIdent values
43− valueVerts = map (\d -> (d, getIdent d, usedIdents d `intersect` allIdents)) values
44− bindingGroupDecls = map toBindingGroup $ stronglyConnComp valueVerts
45− in
46− dataBindingGroupDecls ++ nonValues ++ bindingGroupDecls
47−
48−usedIdents :: (Data d) => d -> [Ident]
49−usedIdents = nub . everything (++) (mkQ [] namesV `extQ` namesS)
50− where
51− namesV :: Value -> [Ident]
52− namesV (Var (Qualified Nothing name)) = [name]
53− namesV _ = []
54− namesS :: Statement -> [Ident]
55− namesS (VariableIntroduction name _) = [name]
56− namesS _ = []
57−
58−usedProperNames :: (Data d) => d -> [ProperName]
59−usedProperNames = nub . everything (++) (mkQ [] names)
60− where
61− names :: Type -> [ProperName]
62− names (TypeConstructor (Qualified Nothing name)) = [name]
63− names _ = []
64−
65−isValueDecl :: Declaration -> Bool
66−isValueDecl (ValueDeclaration _ _ _ _) = True
67−isValueDecl _ = False
68−
69−isDataDecl :: Declaration -> Bool
70−isDataDecl (DataDeclaration _ _ _) = True
71−isDataDecl _ = False
72−
73−getIdent :: Declaration -> Ident
74−getIdent (ValueDeclaration ident _ _ _) = ident
75−getIdent _ = error "Expected ValueDeclaration"
76−
77−getProperName :: Declaration -> ProperName
78−getProperName (DataDeclaration pn _ _) = pn
79−getProperName _ = error "Expected DataDeclaration"
80−
81−toBindingGroup :: SCC Declaration -> Declaration
82−toBindingGroup (AcyclicSCC d) = d
83−toBindingGroup (CyclicSCC [d]) = d
84−toBindingGroup (CyclicSCC ds') = BindingGroupDeclaration $ map fromValueDecl ds'
85−
86−toDataBindingGroup :: SCC Declaration -> Declaration
87−toDataBindingGroup (AcyclicSCC d) = d
88−toDataBindingGroup (CyclicSCC [d]) = d
89−toDataBindingGroup (CyclicSCC ds') = DataBindingGroupDeclaration $ map fromDataDecl ds'
90−
91−fromValueDecl :: Declaration -> (Ident, Value)
92−fromValueDecl (ValueDeclaration ident [] Nothing val) = (ident, val)
93−fromValueDecl (ValueDeclaration _ _ _ _) = error "Binders should have been desugared"
94−fromValueDecl _ = error "Expected ValueDeclaration"
95−
96−fromDataDecl :: Declaration -> (ProperName, [String], [(ProperName, Maybe PolyType)])
97−fromDataDecl (DataDeclaration pn args ctors) = (pn, args, ctors)
98−fromDataDecl _ = error "Expected DataDeclaration"
src/Language/PureScript/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.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/CodeGen.hsdeleted−18
@@ -1,18 +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
src/Language/PureScript/CodeGen/Externs.hsdeleted−49
@@ -1,49 +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 _ _ (ExternMemberDeclaration member name ty) =
44− return $ "foreign import member " ++ show member ++ " " ++ show name ++ " :: " ++ prettyPrintType ty
45−declToPs _ _ (ExternDataDeclaration name kind) =
46− return $ "foreign import data " ++ show name ++ " :: " ++ prettyPrintKind kind
47−declToPs _ _ (TypeSynonymDeclaration name args ty) =
48− return $ "type " ++ show name ++ " " ++ unwords args ++ " = " ++ prettyPrintType ty
49−declToPs _ _ _ = []
src/Language/PureScript/CodeGen/JS.hsdeleted−195
@@ -1,195 +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−module Language.PureScript.CodeGen.JS (
16− module AST,
17− declToJs,
18− moduleToJs
19−) where
20−
21−import Data.Maybe (mapMaybe)
22−import qualified Data.Map as M
23−import Control.Arrow (second)
24−import Control.Monad (replicateM, forM)
25−
26−import Language.PureScript.TypeChecker (Environment, names)
27−import Language.PureScript.Values
28−import Language.PureScript.Names
29−import Language.PureScript.Scope
30−import Language.PureScript.Declarations
31−import Language.PureScript.Pretty.Common
32−import Language.PureScript.CodeGen.Monad
33−import Language.PureScript.CodeGen.JS.AST as AST
34−import Language.PureScript.TypeChecker.Monad (NameKind(..))
35−
36−moduleToJs :: Module -> Environment -> [JS]
37−moduleToJs (Module pname@(ProperName name) decls) env =
38− [ JSVariableIntroduction (Ident name) Nothing
39− , JSApp (JSFunction Nothing [Ident name]
40− (JSBlock (concat $ mapMaybe (\decl -> declToJs (ModuleName pname) decl env) decls)))
41− [JSAssignment (JSAssignVariable (Ident name))
42− (JSBinary Or (JSVar (Ident name)) (JSObjectLiteral []))]
43− ]
44−
45−declToJs :: ModuleName -> Declaration -> Environment -> Maybe [JS]
46−declToJs mp (ValueDeclaration ident _ _ (Abs args ret)) e =
47− Just [ JSFunction (Just ident) args (JSBlock [JSReturn (valueToJs mp e ret)]),
48− setProperty (identToJs ident) (JSVar ident) mp ]
49−declToJs mp (ValueDeclaration ident _ _ val) e =
50− Just [ JSVariableIntroduction ident (Just (valueToJs mp e val)),
51− setProperty (identToJs ident) (JSVar ident) mp ]
52−declToJs mp (BindingGroupDeclaration vals) e =
53− Just $ concatMap (\(ident, val) ->
54− [ JSVariableIntroduction ident (Just (valueToJs mp e val)),
55− setProperty (identToJs ident) (JSVar ident) mp ]
56− ) vals
57−declToJs mp (ExternMemberDeclaration member ident _) _ =
58− Just [ JSFunction (Just ident) [Ident "value"] (JSBlock [JSReturn (JSAccessor member (JSVar (Ident "value")))]),
59− setProperty (show ident) (JSVar ident) mp ]
60−declToJs mp (DataDeclaration _ _ ctors) _ =
61− Just $ flip concatMap ctors $ \(pn@(ProperName ctor), maybeTy) ->
62− let
63− ctorJs =
64− case maybeTy of
65− Nothing -> JSVariableIntroduction (Ident ctor) (Just (JSObjectLiteral [ ("ctor", JSStringLiteral (show (Qualified (Just mp) pn))) ]))
66− Just _ -> JSFunction (Just (Ident ctor)) [Ident "value"]
67− (JSBlock [JSReturn
68− (JSObjectLiteral [ ("ctor", JSStringLiteral (show (Qualified (Just mp) pn)))
69− , ("value", JSVar (Ident "value")) ])])
70− in [ ctorJs, setProperty ctor (JSVar (Ident ctor)) mp ]
71−declToJs _ _ _ = Nothing
72−
73−setProperty :: String -> JS -> ModuleName -> JS
74−setProperty prop val (ModuleName (ProperName moduleName)) = JSAssignment (JSAssignProperty prop (JSAssignVariable (Ident moduleName))) val
75−
76−valueToJs :: ModuleName -> Environment -> Value -> JS
77−valueToJs _ _ (NumericLiteral n) = JSNumericLiteral n
78−valueToJs _ _ (StringLiteral s) = JSStringLiteral s
79−valueToJs _ _ (BooleanLiteral b) = JSBooleanLiteral b
80−valueToJs m e (ArrayLiteral xs) = JSArrayLiteral (map (valueToJs m e) xs)
81−valueToJs m e (ObjectLiteral ps) = JSObjectLiteral (map (second (valueToJs m e)) ps)
82−valueToJs m e (ObjectUpdate o ps) = JSApp (JSAccessor "extend" (JSVar (Ident "Object"))) [ valueToJs m e o, JSObjectLiteral (map (second (valueToJs m e)) ps)]
83−valueToJs _ _ (Constructor name) = qualifiedToJS runProperName name
84−valueToJs m e (Block sts) = JSApp (JSFunction Nothing [] (JSBlock (map (statementToJs m e) sts))) []
85−valueToJs m e (Case values binders) = runGen (bindersToJs m e binders (map (valueToJs m e) values))
86−valueToJs m e (IfThenElse cond th el) = JSConditional (valueToJs m e cond) (valueToJs m e th) (valueToJs m e el)
87−valueToJs m e (Accessor prop val) = JSAccessor prop (valueToJs m e val)
88−valueToJs m e (Indexer index val) = JSIndexer (valueToJs m e index) (valueToJs m e val)
89−valueToJs m e (App val args) = JSApp (valueToJs m e val) (map (valueToJs m e) args)
90−valueToJs m e (Abs args val) = JSFunction Nothing args (JSBlock [JSReturn (valueToJs m e val)])
91−valueToJs m e (Unary op val) = JSUnary op (valueToJs m e val)
92−valueToJs m e (Binary op v1 v2) = JSBinary op (valueToJs m e v1) (valueToJs m e v2)
93−valueToJs m e (Var ident) = varToJs m e ident
94−valueToJs m e (TypedValue val _) = valueToJs m e val
95−valueToJs _ _ _ = error "Invalid argument to valueToJs"
96−
97−varToJs :: ModuleName -> Environment -> Qualified Ident -> JS
98−varToJs m e qual@(Qualified _ ident) = case M.lookup (qualify m qual) (names e) of
99− Just (_, ty) | isExtern ty -> JSVar ident
100− Just (_, Alias aliasModule aliasIdent) -> qualifiedToJS identToJs (Qualified (Just aliasModule) aliasIdent)
101− _ -> qualifiedToJS identToJs qual
102− where
103− isExtern Extern = True
104− isExtern (Alias m' ident') = case M.lookup (m', ident') (names e) of
105− Just (_, ty') -> isExtern ty'
106− Nothing -> error "Undefined alias in varToJs"
107− isExtern _ = False
108−
109−qualifiedToJS :: (a -> String) -> Qualified a -> JS
110−qualifiedToJS f (Qualified (Just (ModuleName (ProperName m))) a) = JSAccessor (f a) (JSVar (Ident m))
111−qualifiedToJS f (Qualified Nothing a) = JSVar (Ident (f a))
112−
113−bindersToJs :: ModuleName -> Environment -> [([Binder], Maybe Guard, Value)] -> [JS] -> Gen JS
114−bindersToJs m e binders vals = do
115− setNextName $ firstUnusedName (binders, vals)
116− valNames <- replicateM (length vals) fresh
117− jss <- forM binders $ \(bs, grd, result) -> go valNames [JSReturn (valueToJs m e result)] bs grd
118− return $ JSApp (JSFunction Nothing (map Ident valNames) (JSBlock (concat jss ++ [JSThrow (JSStringLiteral "Failed pattern match")])))
119− vals
120− where
121− go :: [String] -> [JS] -> [Binder] -> Maybe Guard -> Gen [JS]
122− go _ done [] Nothing = return done
123− go _ done [] (Just cond) = return [JSIfElse (valueToJs m e cond) (JSBlock done) Nothing]
124− go (v:vs) done' (b:bs) grd = do
125− done'' <- go vs done' bs grd
126− binderToJs m e v done'' b
127− go _ _ _ _ = error "Invalid arguments to bindersToJs"
128−
129−binderToJs :: ModuleName -> Environment -> String -> [JS] -> Binder -> Gen [JS]
130−binderToJs _ _ _ done NullBinder = return done
131−binderToJs _ _ varName done (StringBinder str) =
132− return [JSIfElse (JSBinary EqualTo (JSVar (Ident varName)) (JSStringLiteral str)) (JSBlock done) Nothing]
133−binderToJs _ _ varName done (NumberBinder num) =
134− return [JSIfElse (JSBinary EqualTo (JSVar (Ident varName)) (JSNumericLiteral num)) (JSBlock done) Nothing]
135−binderToJs _ _ varName done (BooleanBinder True) =
136− return [JSIfElse (JSVar (Ident varName)) (JSBlock done) Nothing]
137−binderToJs _ _ varName done (BooleanBinder False) =
138− return [JSIfElse (JSUnary Not (JSVar (Ident varName))) (JSBlock done) Nothing]
139−binderToJs _ _ varName done (VarBinder ident) =
140− return (JSVariableIntroduction ident (Just (JSVar (Ident varName))) : done)
141−binderToJs m _ varName done (NullaryBinder ctor) =
142− return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar (Ident varName))) (JSStringLiteral (show ((\(mp, nm) -> Qualified (Just mp) nm) $ qualify m ctor)))) (JSBlock done) Nothing]
143−binderToJs m e varName done (UnaryBinder ctor b) = do
144− value <- fresh
145− js <- binderToJs m e value done b
146− return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar (Ident varName))) (JSStringLiteral (show ((\(mp, nm) -> Qualified (Just mp) nm) $ qualify m ctor)))) (JSBlock (JSVariableIntroduction (Ident value) (Just (JSAccessor "value" (JSVar (Ident varName)))) : js)) Nothing]
147−binderToJs m e varName done (ObjectBinder bs) = go done bs
148− where
149− go :: [JS] -> [(String, Binder)] -> Gen [JS]
150− go done' [] = return done'
151− go done' ((prop, binder):bs') = do
152− propVar <- fresh
153− done'' <- go done' bs'
154− js <- binderToJs m e propVar done'' binder
155− return (JSVariableIntroduction (Ident propVar) (Just (JSAccessor prop (JSVar (Ident varName)))) : js)
156−binderToJs m e varName done (ArrayBinder bs) = do
157− js <- go done 0 bs
158− return [JSIfElse (JSBinary EqualTo (JSAccessor "length" (JSVar (Ident varName))) (JSNumericLiteral (Left (fromIntegral $ length bs)))) (JSBlock js) Nothing]
159− where
160− go :: [JS] -> Integer -> [Binder] -> Gen [JS]
161− go done' _ [] = return done'
162− go done' index (binder:bs') = do
163− elVar <- fresh
164− done'' <- go done' (index + 1) bs'
165− js <- binderToJs m e elVar done'' binder
166− return (JSVariableIntroduction (Ident elVar) (Just (JSIndexer (JSNumericLiteral (Left index)) (JSVar (Ident varName)))) : js)
167−binderToJs m e varName done (ConsBinder headBinder tailBinder) = do
168− headVar <- fresh
169− tailVar <- fresh
170− js1 <- binderToJs m e headVar done headBinder
171− js2 <- binderToJs m e tailVar js1 tailBinder
172− return [JSIfElse (JSBinary GreaterThan (JSAccessor "length" (JSVar (Ident varName))) (JSNumericLiteral (Left 0))) (JSBlock
173− ( JSVariableIntroduction (Ident headVar) (Just (JSIndexer (JSNumericLiteral (Left 0)) (JSVar (Ident varName)))) :
174− JSVariableIntroduction (Ident tailVar) (Just (JSApp (JSAccessor "slice" (JSVar (Ident varName))) [JSNumericLiteral (Left 1)])) :
175− js2
176− )) Nothing]
177−binderToJs m e varName done (NamedBinder ident binder) = do
178− js <- binderToJs m e varName done binder
179− return (JSVariableIntroduction ident (Just (JSVar (Ident varName))) : js)
180−
181−statementToJs :: ModuleName -> Environment -> Statement -> JS
182−statementToJs m e (VariableIntroduction ident value) = JSVariableIntroduction ident (Just (valueToJs m e value))
183−statementToJs m e (Assignment target value) = JSAssignment (JSAssignVariable target) (valueToJs m e value)
184−statementToJs m e (While cond sts) = JSWhile (valueToJs m e cond) (JSBlock (map (statementToJs m e) sts))
185−statementToJs m e (For ident start end sts) = JSFor ident (valueToJs m e start) (valueToJs m e end) (JSBlock (map (statementToJs m e) sts))
186−statementToJs m e (ForEach ident arr sts) = JSApp (JSAccessor "forEach" (valueToJs m e arr)) [JSFunction Nothing [ident] (JSBlock (map (statementToJs m e) sts))]
187−statementToJs m e (If ifst) = ifToJs ifst
188− where
189− ifToJs :: IfStatement -> JS
190− ifToJs (IfStatement cond thens elses) = JSIfElse (valueToJs m e cond) (JSBlock (map (statementToJs m e) thens)) (fmap elseToJs elses)
191− elseToJs :: ElseStatement -> JS
192− elseToJs (Else sts) = JSBlock (map (statementToJs m e) sts)
193− elseToJs (ElseIf elif) = ifToJs elif
194−statementToJs m e (ValueStatement val) = valueToJs m e val
195−statementToJs m e (Return value) = JSReturn (valueToJs m e value)
src/Language/PureScript/CodeGen/JS/AST.hsdeleted−51
@@ -1,51 +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 deriving (Show, Data, Typeable)
46−
47−data JSAssignment
48− = JSAssignVariable Ident
49− | JSAssignProperty String JSAssignment deriving (Show, Data, Typeable)
50−
51−
src/Language/PureScript/CodeGen/Monad.hsdeleted−37
@@ -1,37 +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−
22−newtype Gen a = Gen { unGen :: State Int a } deriving (Functor, Applicative, Monad, MonadState Int, MonadFix)
23−
24−runGen :: Gen a -> a
25−runGen = flip evalState 0 . unGen
26−
27−fresh :: Gen String
28−fresh = do
29− n <- get
30− modify (+ 1)
31− return $ '_' : show n
32−
33−getNextName :: Gen Int
34−getNextName = get
35−
36−setNextName :: Int -> Gen ()
37−setNextName = put
src/Language/PureScript/Declarations.hsdeleted−46
@@ -1,46 +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−
24−import qualified Data.Data as D
25−
26−type Precedence = Integer
27−
28−data Associativity = Infixl | Infixr deriving (Show, D.Data, D.Typeable)
29−
30−data Fixity = Fixity Associativity Precedence deriving (Show, D.Data, D.Typeable)
31−
32−data Module = Module ProperName [Declaration] deriving (Show, D.Data, D.Typeable)
33−
34−data Declaration
35− = DataDeclaration ProperName [String] [(ProperName, Maybe PolyType)]
36− | DataBindingGroupDeclaration [(ProperName, [String], [(ProperName, Maybe PolyType)])]
37− | TypeSynonymDeclaration ProperName [String] PolyType
38− | TypeDeclaration Ident PolyType
39− | ValueDeclaration Ident [[Binder]] (Maybe Guard) Value
40− | BindingGroupDeclaration [(Ident, Value)]
41− | ExternDeclaration Ident PolyType
42− | ExternMemberDeclaration String Ident PolyType
43− | ExternDataDeclaration ProperName Kind
44− | FixityDeclaration Fixity String
45− | ImportDeclaration ModuleName (Maybe [Either Ident ProperName])
46− deriving (Show, D.Data, D.Typeable)
src/Language/PureScript/Kinds.hsdeleted−26
@@ -1,26 +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− | Row
26− | 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/Operators.hsdeleted−125
@@ -1,125 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.Operators
4−-- Copyright : (c) Phil Freeman 2013
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−--
13−-----------------------------------------------------------------------------
14−
15−{-# LANGUAGE Rank2Types #-}
16−
17−module Language.PureScript.Operators (
18− rebracket
19−) where
20−
21−import Language.PureScript.Names
22−import Language.PureScript.Declarations
23−import Language.PureScript.Values
24−
25−import 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 ms = forM ms $ \(Module name ds) -> do
38− m <- collectFixities (ModuleName name) ds
39− let opTable = customOperatorTable m
40− ds' <- G.everywhereM' (G.mkM (matchOperators (ModuleName name) opTable)) ds
41− return $ Module name $ G.everywhere (G.mkT removeParens) ds'
42−
43−removeParens :: Value -> Value
44−removeParens (Parens val) = val
45−removeParens val = val
46−
47−customOperatorTable :: M.Map (Qualified Ident) Fixity -> [[(Qualified Ident, Value -> Value -> Value, Associativity)]]
48−customOperatorTable fixities =
49− let
50− applyUserOp name t1 t2 = App (App (Var name) [t1]) [t2]
51− userOps = map (\(name, Fixity a p) -> (name, applyUserOp name, p, a)) . M.toList $ fixities
52− sorted = sortBy (compare `on` (\(_, _, p, _) -> p)) (userOps ++ builtIns)
53− groups = groupBy ((==) `on` (\(_, _, p, _) -> p)) sorted
54− in
55− map (map (\(name, f, _, a) -> (name, f, a))) groups
56−
57−type Chain = [Either Value (Qualified Ident)]
58−
59−matchOperators :: ModuleName -> [[(Qualified Ident, Value -> Value -> Value, Associativity)]] -> Value -> Either String Value
60−matchOperators moduleName ops val = G.everywhereM' (G.mkM parseChains) val
61− where
62− parseChains :: Value -> Either String Value
63− parseChains b@(BinaryNoParens _ _ _) = bracketChain (extendChain b)
64− parseChains other = return other
65− extendChain :: Value -> Chain
66− extendChain (BinaryNoParens name l r) = Left l : Right name : extendChain r
67− extendChain other = [Left other]
68− bracketChain :: Chain -> Either String Value
69− bracketChain = either (Left . show) Right . P.parse (P.buildExpressionParser opTable parseValue <* P.eof) "operator expression"
70− opTable = map (map (\(name, f, a) -> P.Infix (P.try (matchOp moduleName name) >> return f) (toAssoc a))) ops
71− ++ [[P.Infix (P.try (parseOp >>= \ident -> return (\t1 t2 -> App (App (Var ident) [t1]) [t2]))) P.AssocLeft]]
72−
73−toAssoc :: Associativity -> P.Assoc
74−toAssoc Infixl = P.AssocLeft
75−toAssoc Infixr = P.AssocRight
76−
77−parseValue :: P.Parsec Chain () Value
78−parseValue = P.token show (const (P.initialPos "")) (either Just (const Nothing)) P.<?> "expression"
79−
80−parseOp :: P.Parsec Chain () (Qualified Ident)
81−parseOp = P.token show (const (P.initialPos "")) (either (const Nothing) Just) P.<?> "operator"
82−
83−matchOp :: ModuleName -> Qualified Ident -> P.Parsec Chain () ()
84−matchOp moduleName op = do
85− ident <- parseOp
86− guard (qualify moduleName ident == qualify moduleName op)
87−
88−collectFixities :: ModuleName -> [Declaration] -> Either String (M.Map (Qualified Ident) Fixity)
89−collectFixities = go M.empty
90− where
91− go :: M.Map (Qualified Ident) Fixity -> ModuleName -> [Declaration] -> Either String (M.Map (Qualified Ident) Fixity)
92− go m _ [] = return m
93− go 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− go (M.insert qual fixity m) moduleName rest
97− go m moduleName (_:ds) = go m moduleName ds
98−
99−globalOp :: String -> Qualified Ident
100−globalOp = Qualified Nothing . Op
101−
102−builtIns :: [(Qualified Ident, Value -> Value -> Value, Precedence, Associativity)]
103−builtIns = [ (globalOp "<", Binary LessThan, 3, Infixl)
104− , (globalOp "<=", Binary LessThanOrEqualTo, 3, Infixl)
105− , (globalOp ">", Binary GreaterThan, 3, Infixl)
106− , (globalOp ">=", Binary GreaterThanOrEqualTo, 3, Infixl)
107− , (globalOp "!!", flip Indexer, 4, Infixl)
108− , (globalOp "*", Binary Multiply, 5, Infixl)
109− , (globalOp "/", Binary Divide, 5, Infixl)
110− , (globalOp "%", Binary Modulus, 5, Infixl)
111− , (globalOp "++", Binary Concat, 6, Infixr)
112− , (globalOp "+", Binary Add, 7, Infixl)
113− , (globalOp "-", Binary Subtract, 7, Infixl)
114− , (globalOp "<<", Binary ShiftLeft, 8, Infixl)
115− , (globalOp ">>", Binary ShiftRight, 8, Infixl)
116− , (globalOp ">>>", Binary ZeroFillShiftRight, 8, Infixl)
117− , (globalOp "==", Binary EqualTo, 9, Infixl)
118− , (globalOp "!=", Binary NotEqualTo, 9, Infixl)
119− , (globalOp "&", Binary BitwiseAnd, 10, Infixl)
120− , (globalOp "^", Binary BitwiseXor, 10, Infixl)
121− , (globalOp "|", Binary BitwiseOr, 10, Infixl)
122− , (globalOp "&&", Binary And, 11, Infixr)
123− , (globalOp "||", Binary Or, 11, Infixr)
124− ]
125−
src/Language/PureScript/Optimize.hsdeleted−103
@@ -1,103 +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.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−
26−optimize :: JS -> JS
27−optimize = removeUnusedVariables . unThunk . etaConvert . inlineVariables
28−
29−replaceIdent :: (Data d) => Ident -> JS -> d -> d
30−replaceIdent var1 js = everywhere (mkT replace)
31− where
32− replace (JSVar var2) | var1 == var2 = js
33− replace other = other
34−
35−replaceIdents :: (Data d) => [(Ident, JS)] -> d -> d
36−replaceIdents vars = everywhere (mkT replace)
37− where
38− replace v@(JSVar var) = fromMaybe v $ lookup var vars
39− replace other = other
40−
41−isReassigned :: (Data d) => Ident -> d -> Bool
42−isReassigned var1 = everything (||) (mkQ False check)
43− where
44− check :: JS -> Bool
45− check (JSAssignment (JSAssignVariable var2) _) | var1 == var2 = True
46− check _ = False
47−
48−isUsed :: (Data d) => Ident -> d -> Bool
49−isUsed var1 = everything (||) (mkQ False check)
50− where
51− check :: JS -> Bool
52− check (JSVar var2) | var1 == var2 = True
53− check (JSAssignment target _) | var1 == targetVariable target = True
54− check _ = False
55− targetVariable :: JSAssignment -> Ident
56− targetVariable (JSAssignVariable var) = var
57− targetVariable (JSAssignProperty _ tgt) = targetVariable tgt
58−
59−shouldInline :: JS -> Bool
60−shouldInline (JSVar _) = True
61−shouldInline (JSNumericLiteral _) = True
62−shouldInline (JSStringLiteral _) = True
63−shouldInline (JSBooleanLiteral _) = True
64−shouldInline (JSAccessor _ val) = shouldInline val
65−shouldInline (JSIndexer index val) = shouldInline index && shouldInline val
66−shouldInline _ = False
67−
68−inlineVariables :: JS -> JS
69−inlineVariables = everywhere (mkT removeFromBlock)
70− where
71− removeFromBlock :: JS -> JS
72− removeFromBlock (JSBlock sts) = JSBlock (go sts)
73− removeFromBlock js = js
74− go :: [JS] -> [JS]
75− go [] = []
76− go (JSVariableIntroduction var (Just js) : sts) | shouldInline js && not (isReassigned var sts) = go (replaceIdent var js sts)
77− go (s:sts) = s : go sts
78−
79−removeUnusedVariables :: JS -> JS
80−removeUnusedVariables = everywhere (mkT removeFromBlock)
81− where
82− removeFromBlock :: JS -> JS
83− removeFromBlock (JSBlock sts) = JSBlock (go sts)
84− removeFromBlock js = js
85− go :: [JS] -> [JS]
86− go [] = []
87− go (JSVariableIntroduction var _ : sts) | not (isUsed var sts) = go sts
88− go (s:sts) = s : go sts
89−
90−etaConvert :: JS -> JS
91−etaConvert = everywhere (mkT convert)
92− where
93− convert :: JS -> JS
94− convert (JSBlock [JSReturn (JSApp (JSFunction Nothing idents (JSBlock body)) args)])
95− | all shouldInline args = JSBlock (replaceIdents (zip idents args) body)
96− convert js = js
97−
98−unThunk :: JS -> JS
99−unThunk = everywhere (mkT convert)
100− where
101− convert :: JS -> JS
102− convert (JSBlock [JSReturn (JSApp (JSFunction Nothing [] (JSBlock body)) [])]) = JSBlock body
103− convert js = js
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−252
@@ -1,252 +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−
75−builtInOperators :: [String]
76−builtInOperators = [ "~", "-", "<=", ">=", "<", ">", "*", "/", "%", "++", "+", "<<", ">>>", ">>"
77− , "==", "!=", "&&", "||", "&", "^", "|", "!!", "!" ]
78−
79−reservedOpNames :: [String]
80−reservedOpNames = builtInOperators ++ [ "->", "=", "." ]
81−
82−identStart :: P.Parsec String u Char
83−identStart = P.lower <|> P.oneOf "_$"
84−
85−properNameStart :: P.Parsec String u Char
86−properNameStart = P.upper
87−
88−identLetter :: P.Parsec String u Char
89−identLetter = P.alphaNum <|> P.oneOf "_'"
90−
91−opStart :: P.Parsec String u Char
92−opStart = P.oneOf ":.!#%&*+/<=>?@^|~"
93−
94−opLetter :: P.Parsec String u Char
95−opLetter = P.oneOf ":.#$%&*+./<=>?@^|"
96−
97−langDef :: PT.GenLanguageDef String u Identity
98−langDef = PT.LanguageDef
99− { PT.reservedNames = reservedNames
100− , PT.reservedOpNames = reservedOpNames
101− , PT.commentStart = "{-"
102− , PT.commentEnd = "-}"
103− , PT.commentLine = "--"
104− , PT.nestedComments = True
105− , PT.identStart = identStart
106− , PT.identLetter = identLetter
107− , PT.opStart = opStart
108− , PT.opLetter = opLetter
109− , PT.caseSensitive = True
110− }
111−
112−tokenParser :: PT.GenTokenParser String u Identity
113−tokenParser = PT.makeTokenParser langDef
114−
115−lexeme :: P.Parsec String u a -> P.Parsec String u a
116−lexeme = PT.lexeme tokenParser
117−
118−identifier :: P.Parsec String u String
119−identifier = PT.identifier tokenParser
120−
121−reserved :: String -> P.Parsec String u ()
122−reserved = PT.reserved tokenParser
123−
124−reservedOp :: String -> P.Parsec String u ()
125−reservedOp = PT.reservedOp tokenParser
126−
127−operator :: P.Parsec String u String
128−operator = PT.operator tokenParser
129−
130−stringLiteral :: P.Parsec String u String
131−stringLiteral = PT.stringLiteral tokenParser
132−
133−whiteSpace :: P.Parsec String u ()
134−whiteSpace = PT.whiteSpace tokenParser
135−
136−semi :: P.Parsec String u String
137−semi = PT.semi tokenParser
138−
139−colon :: P.Parsec String u String
140−colon = PT.colon tokenParser
141−
142−dot :: P.Parsec String u String
143−dot = PT.dot tokenParser
144−
145−comma :: P.Parsec String u String
146−comma = PT.comma tokenParser
147−
148−tick :: P.Parsec String u Char
149−tick = lexeme $ P.char '`'
150−
151−pipe :: P.Parsec String u Char
152−pipe = lexeme $ P.char '|'
153−
154−natural :: P.Parsec String u Integer
155−natural = PT.natural tokenParser
156−
157−squares :: P.Parsec String ParseState a -> P.Parsec String ParseState a
158−squares = P.between (lexeme $ P.char '[') (lexeme $ indented *> P.char ']') . (indented *>)
159−
160−parens :: P.Parsec String ParseState a -> P.Parsec String ParseState a
161−parens = P.between (lexeme $ P.char '(') (lexeme $ indented *> P.char ')') . (indented *>)
162−
163−braces :: P.Parsec String ParseState a -> P.Parsec String ParseState a
164−braces = P.between (lexeme $ P.char '{') (lexeme $ indented *> P.char '}') . (indented *>)
165−
166−angles :: P.Parsec String ParseState a -> P.Parsec String ParseState a
167−angles = P.between (lexeme $ P.char '<') (lexeme $ indented *> P.char '>') . (indented *>)
168−
169−sepBy :: P.Parsec String ParseState a -> P.Parsec String ParseState sep -> P.Parsec String ParseState [a]
170−sepBy p s = P.sepBy (indented *> p) (indented *> s)
171−
172−sepBy1 :: P.Parsec String ParseState a -> P.Parsec String ParseState sep -> P.Parsec String ParseState [a]
173−sepBy1 p s = P.sepBy1 (indented *> p) (indented *> s)
174−
175−semiSep :: P.Parsec String ParseState a -> P.Parsec String ParseState [a]
176−semiSep = flip sepBy semi
177−
178−semiSep1 :: P.Parsec String ParseState a -> P.Parsec String ParseState [a]
179−semiSep1 = flip sepBy1 semi
180−
181−commaSep :: P.Parsec String ParseState a -> P.Parsec String ParseState [a]
182−commaSep = flip sepBy comma
183−
184−commaSep1 :: P.Parsec String ParseState a -> P.Parsec String ParseState [a]
185−commaSep1 = flip sepBy1 comma
186−
187−properName :: P.Parsec String u ProperName
188−properName = lexeme $ ProperName <$> P.try ((:) <$> P.upper <*> many (PT.identLetter langDef) P.<?> "name")
189−
190−parseQualified :: P.Parsec String ParseState a -> P.Parsec String ParseState (Qualified a)
191−parseQualified parser = qual
192− where
193− qual = (Qualified <$> (Just . ModuleName <$> P.try (properName <* delimiter)) <*> parser)
194− <|> (Qualified Nothing <$> P.try parser)
195− delimiter = indented *> dot
196−
197−integerOrFloat :: P.Parsec String u (Either Integer Double)
198−integerOrFloat = (Left <$> P.try (PT.natural tokenParser) <|>
199− Right <$> P.try (PT.float tokenParser)) P.<?> "number"
200−
201−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
202−augment p q f = flip (maybe id $ flip f) <$> p <*> P.optionMaybe q
203−
204−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
205−fold first more combine = do
206− a <- first
207− bs <- P.many more
208− return $ foldl combine a bs
209−
210−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
211−buildPostfixParser fs first = do
212− a <- first
213− go a
214− where
215− go a = do
216− maybeA <- P.optionMaybe $ P.choice (map ($ a) fs)
217− case maybeA of
218− Nothing -> return a
219− Just a' -> go a'
220−
221−operatorOrBuiltIn :: P.Parsec String u String
222−operatorOrBuiltIn = P.try operator <|> P.choice (map (\s -> P.try (reservedOp s) >> return s) builtInOperators)
223−
224−parseIdent :: P.Parsec String ParseState Ident
225−parseIdent = (Ident <$> identifier) <|> (Op <$> parens operatorOrBuiltIn)
226−
227−parseIdentInfix :: P.Parsec String ParseState (Qualified Ident)
228−parseIdentInfix = (P.between tick tick (parseQualified (Ident <$> identifier))) <|> parseQualified (Op <$> operatorOrBuiltIn)
229−
230−mark :: P.Parsec String ParseState a -> P.Parsec String ParseState a
231−mark p = do
232− current <- indentationLevel <$> P.getState
233− pos <- P.sourceColumn <$> P.getPosition
234− P.modifyState $ \st -> st { indentationLevel = pos }
235− a <- p
236− P.modifyState $ \st -> st { indentationLevel = current }
237− return a
238−
239−checkIndentation :: (P.Column -> P.Column -> Bool) -> P.Parsec String ParseState ()
240−checkIndentation rel = do
241− col <- P.sourceColumn <$> P.getPosition
242− current <- indentationLevel <$> P.getState
243− guard (col `rel` current)
244−
245−indented :: P.Parsec String ParseState ()
246−indented = checkIndentation (>) P.<?> "indentation"
247−
248−same :: P.Parsec String ParseState ()
249−same = checkIndentation (==) P.<?> "no indentation"
250−
251−runIndentParser :: P.Parsec String ParseState a -> String -> Either P.ParseError a
252−runIndentParser p = P.runParser p (ParseState 0) ""
src/Language/PureScript/Parser/Declarations.hsdeleted−116
@@ -1,116 +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 Control.Applicative
22−import qualified Text.Parsec as P
23−
24−import Language.PureScript.Names
25−import Language.PureScript.Parser.State
26−import Language.PureScript.Parser.Common
27−import Language.PureScript.Declarations
28−import Language.PureScript.Parser.Values
29−import Language.PureScript.Parser.Types
30−import Language.PureScript.Parser.Kinds
31−import Language.PureScript.Values
32−
33−parseDataDeclaration :: P.Parsec String ParseState Declaration
34−parseDataDeclaration = do
35− reserved "data"
36− name <- indented *> properName
37− tyArgs <- many (indented *> identifier)
38− lexeme $ indented *> P.char '='
39− ctors <- sepBy1 ((,) <$> properName <*> P.optionMaybe (indented *> parsePolyType)) pipe
40− return $ DataDeclaration name tyArgs ctors
41−
42−parseTypeDeclaration :: P.Parsec String ParseState Declaration
43−parseTypeDeclaration =
44− TypeDeclaration <$> P.try (parseIdent <* lexeme (indented *> P.string "::"))
45− <*> parsePolyType
46−
47−parseTypeSynonymDeclaration :: P.Parsec String ParseState Declaration
48−parseTypeSynonymDeclaration =
49− TypeSynonymDeclaration <$> (P.try (reserved "type") *> indented *> properName)
50− <*> many (indented *> identifier)
51− <*> (lexeme (indented *> P.char '=') *> parsePolyType)
52−
53−parseValueDeclaration :: P.Parsec String ParseState Declaration
54−parseValueDeclaration =
55− ValueDeclaration <$> parseIdent
56− <*> P.many parseTopLevelBinder
57− <*> P.optionMaybe parseGuard
58− <*> ((lexeme (indented *> P.char '=')) *> parseValue)
59−
60−parseTopLevelBinder :: P.Parsec String ParseState [Binder]
61−parseTopLevelBinder = return <$> P.try parseBinderNoParens <|> parens (commaSep parseBinder)
62−
63−parseExternDeclaration :: P.Parsec String ParseState Declaration
64−parseExternDeclaration = P.try (reserved "foreign") *> indented *> (reserved "import") *> indented *>
65− (ExternDataDeclaration <$> (P.try (reserved "data") *> indented *> properName)
66− <*> (lexeme (indented *> P.string "::") *> parseKind)
67− <|> ExternDeclaration <$> parseIdent
68− <*> (lexeme (indented *> P.string "::") *> parsePolyType)
69− <|> ExternMemberDeclaration <$> (P.try (reserved "member") *> indented *> stringLiteral)
70− <*> (indented *> parseIdent)
71− <*> (lexeme (indented *> P.string "::") *> parsePolyType))
72−
73−parseAssociativity :: P.Parsec String ParseState Associativity
74−parseAssociativity =
75− (P.try (reserved "infixl") >> return Infixl) <|>
76− (P.try (reserved "infixr") >> return Infixr)
77−
78−parseFixity :: P.Parsec String ParseState Fixity
79−parseFixity = Fixity <$> parseAssociativity <*> (indented *> natural)
80−
81−parseFixityDeclaration :: P.Parsec String ParseState Declaration
82−parseFixityDeclaration = do
83− fixity <- parseFixity
84− indented
85− name <- operator
86− return $ FixityDeclaration fixity name
87−
88−parseImportDeclaration :: P.Parsec String ParseState Declaration
89−parseImportDeclaration = do
90− reserved "import"
91− indented
92− moduleName <- ModuleName <$> properName
93− idents <- P.optionMaybe $ parens $ commaSep1 (Left <$> parseIdent <|> Right <$> properName)
94− return $ ImportDeclaration moduleName idents
95−
96−parseDeclaration :: P.Parsec String ParseState Declaration
97−parseDeclaration = P.choice
98− [ parseDataDeclaration
99− , parseTypeDeclaration
100− , parseTypeSynonymDeclaration
101− , parseValueDeclaration
102− , parseExternDeclaration
103− , parseFixityDeclaration
104− , parseImportDeclaration ] P.<?> "declaration"
105−
106−parseModule :: P.Parsec String ParseState Module
107−parseModule = do
108− reserved "module"
109− indented
110− name <- properName
111− lexeme $ P.string "where"
112− decls <- mark (P.many (same *> parseDeclaration))
113− return $ Module name decls
114−
115−parseModules :: P.Parsec String ParseState [Module]
116−parseModules = whiteSpace *> mark (P.many (same *> parseModule)) <* P.eof
src/Language/PureScript/Parser/Kinds.hsdeleted−41
@@ -1,41 +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−parseRow :: P.Parsec String ParseState Kind
30−parseRow = const Row <$> lexeme (P.char '#')
31−
32−parseTypeAtom :: P.Parsec String ParseState Kind
33−parseTypeAtom = indented *> P.choice (map P.try
34− [ parseStar
35− , parseRow
36− , parens parseKind ])
37−
38−parseKind :: P.Parsec String ParseState Kind
39−parseKind = P.buildExpressionParser operators parseTypeAtom P.<?> "kind"
40− where
41− operators = [ [ P.Infix (lexeme (P.try (P.string "->")) >> return FunKind) P.AssocRight ] ]
src/Language/PureScript/Parser/State.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−104
@@ -1,104 +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 $ Array <$> parseType
40−
41−parseObject :: P.Parsec String ParseState Type
42−parseObject = braces $ Object <$> parseRow
43−
44−parseFunction :: P.Parsec String ParseState Type
45−parseFunction = do
46− args <- lexeme $ parens $ commaSep parsePolyType
47− lexeme $ P.string "->"
48− resultType <- parseType
49− return $ Function args resultType
50−
51−parseTypeVariable :: P.Parsec String ParseState Type
52−parseTypeVariable = TypeVar <$> identifier
53−
54−parseTypeConstructor :: P.Parsec String ParseState Type
55−parseTypeConstructor = TypeConstructor <$> parseQualified properName
56−
57−parseForAll :: P.Parsec String ParseState Type
58−parseForAll = (mkForAll <$> (P.try (reserved "forall") *> P.many1 (indented *> identifier) <* indented <* dot)
59− <*> parseType)
60−
61−parseTypeAtom :: P.Parsec String ParseState Type
62−parseTypeAtom = indented *> P.choice (map P.try
63− [ parseNumber
64− , parseString
65− , parseBoolean
66− , parseArray
67− , parseObject
68− , parseFunction
69− , parseTypeVariable
70− , parseTypeConstructor
71− , parseForAll
72− , parens parseType ])
73−
74−parseAnyType :: P.Parsec String ParseState Type
75−parseAnyType = (P.buildExpressionParser operators . buildPostfixParser postfixTable $ parseTypeAtom) P.<?> "type"
76− where
77− postfixTable :: [Type -> P.Parsec String ParseState Type]
78− postfixTable = [ \x -> TypeApp x <$> P.try (indented *> parseTypeAtom) ]
79− operators = [ [ P.Infix (lexeme (P.try (P.string "->")) >> return (\t1 t2 -> Function [t1] t2)) P.AssocRight ] ]
80−
81−parseType :: P.Parsec String ParseState Type
82−parseType = do
83− ty <- parseAnyType
84− unless (isMonoType ty) $ P.unexpected "polymorphic type"
85− return ty
86−
87−parsePolyType :: P.Parsec String ParseState PolyType
88−parsePolyType = do
89− ty <- parseAnyType
90− unless (isPolyType ty) $ P.unexpected "polymorphic type"
91− return ty
92−
93−parseNameAndType :: P.Parsec String ParseState (String, Type)
94−parseNameAndType = (,) <$> (indented *> identifier <* indented <* lexeme (P.string "::")) <*> parsePolyType
95−
96−parseRowEnding :: P.Parsec String ParseState Row
97−parseRowEnding = P.option REmpty (RowVar <$> (lexeme (indented *> P.char '|') *> indented *> identifier))
98−
99−parseRow :: P.Parsec String ParseState Row
100−parseRow = (fromList <$> (commaSep parseNameAndType) <*> parseRowEnding) P.<?> "row"
101− where
102− fromList :: [(String, Type)] -> Row -> Row
103− fromList [] r = r
104− fromList ((name, t):ts) r = RCons name t (fromList ts r)
src/Language/PureScript/Parser/Values.hsdeleted−284
@@ -1,284 +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−) where
21−
22−import Language.PureScript.Values
23−import Language.PureScript.Parser.State
24−import qualified Language.PureScript.Parser.Common as C
25−import Control.Applicative
26−import qualified Text.Parsec as P
27−import Text.Parsec.Expr
28−import Language.PureScript.Parser.Types
29−
30−booleanLiteral :: P.Parsec String ParseState Bool
31−booleanLiteral = (C.reserved "true" >> return True) P.<|> (C.reserved "false" >> return False)
32−
33−parseNumericLiteral :: P.Parsec String ParseState Value
34−parseNumericLiteral = NumericLiteral <$> C.integerOrFloat
35−
36−parseStringLiteral :: P.Parsec String ParseState Value
37−parseStringLiteral = StringLiteral <$> C.stringLiteral
38−
39−parseBooleanLiteral :: P.Parsec String ParseState Value
40−parseBooleanLiteral = BooleanLiteral <$> booleanLiteral
41−
42−parseArrayLiteral :: P.Parsec String ParseState Value
43−parseArrayLiteral = ArrayLiteral <$> C.squares (C.commaSep parseValue)
44−
45−parseObjectLiteral :: P.Parsec String ParseState Value
46−parseObjectLiteral = ObjectLiteral <$> C.braces (C.commaSep parseIdentifierAndValue)
47−
48−parseIdentifierAndValue :: P.Parsec String ParseState (String, Value)
49−parseIdentifierAndValue = (,) <$> (C.indented *> C.identifier <* C.indented <* C.colon)
50− <*> (C.indented *> parseValue)
51−
52−parseAbs :: P.Parsec String ParseState Value
53−parseAbs = do
54− C.lexeme $ P.char '\\'
55− args <- P.many (C.indented *> (P.try singleArg <|> manyArgs))
56− C.lexeme $ C.indented *> P.string "->"
57− value <- parseValue
58− return $ toFunction args value
59− where
60− manyArgs :: P.Parsec String ParseState (Value -> Value)
61− manyArgs = do
62− args <- C.parens (C.commaSep C.parseIdent)
63− return $ Abs args
64− singleArg :: P.Parsec String ParseState (Value -> Value)
65− singleArg = Abs . return <$> C.parseIdent
66− toFunction :: [Value -> Value] -> Value -> Value
67− toFunction [] value = Abs [] value
68− toFunction args value = foldr (($)) value args
69−
70−parseVar :: P.Parsec String ParseState Value
71−parseVar = Var <$> C.parseQualified C.parseIdent
72−
73−parseConstructor :: P.Parsec String ParseState Value
74−parseConstructor = Constructor <$> C.parseQualified C.properName
75−
76−parseCase :: P.Parsec String ParseState Value
77−parseCase = Case <$> P.between (P.try (C.reserved "case")) (C.indented *> C.reserved "of") (return <$> parseValue)
78− <*> (C.indented *> C.mark (P.many (C.same *> C.mark parseCaseAlternative)))
79−
80−parseCaseAlternative :: P.Parsec String ParseState ([Binder], Maybe Guard, Value)
81−parseCaseAlternative = (,,) <$> (return <$> parseBinder)
82− <*> P.optionMaybe parseGuard
83− <*> (C.lexeme (P.string "->") *> parseValue)
84− P.<?> "case alternative"
85−
86−parseIfThenElse :: P.Parsec String ParseState Value
87−parseIfThenElse = IfThenElse <$> (P.try (C.reserved "if") *> C.indented *> parseValue)
88− <*> (C.indented *> C.reserved "then" *> C.indented *> parseValue)
89− <*> (C.indented *> C.reserved "else" *> C.indented *> parseValue)
90−
91−parseBlock :: P.Parsec String ParseState Value
92−parseBlock = Block <$> parseManyStatements
93−
94−parseManyStatements :: P.Parsec String ParseState [Statement]
95−parseManyStatements = (do
96− C.lexeme $ P.char '{'
97− C.indented
98− sts <- C.mark (P.many (C.same *> C.mark parseStatement))
99− C.lexeme (P.char '}')
100− return sts) P.<?> "block"
101−
102−parseValueAtom :: P.Parsec String ParseState Value
103−parseValueAtom = P.choice
104− [ P.try parseNumericLiteral
105− , P.try parseStringLiteral
106− , P.try parseBooleanLiteral
107− , parseArrayLiteral
108− , P.try parseObjectLiteral
109− , parseAbs
110− , P.try parseConstructor
111− , P.try parseVar
112− , parseBlock
113− , parseCase
114− , parseIfThenElse
115− , Parens <$> C.parens parseValue ]
116−
117−parsePropertyUpdate :: P.Parsec String ParseState (String, Value)
118−parsePropertyUpdate = do
119− name <- C.lexeme C.identifier
120− C.lexeme $ C.indented *> P.char '='
121− value <- C.indented *> parseValue
122− return (name, value)
123−
124−parseAccessor :: Value -> P.Parsec String ParseState Value
125−parseAccessor (Constructor _) = P.unexpected "constructor"
126−parseAccessor obj = P.try $ Accessor <$> (C.indented *> C.dot *> P.notFollowedBy C.opLetter *> C.indented *> C.identifier) <*> pure obj
127−
128−parseValue :: P.Parsec String ParseState Value
129−parseValue =
130− (buildExpressionParser operators
131− . C.buildPostfixParser postfixTable2
132− $ indexersAndAccessors) P.<?> "expression"
133− where
134− indexersAndAccessors = C.buildPostfixParser postfixTable1 parseValueAtom
135− postfixTable1 = [ parseAccessor
136− , \v -> P.try $ flip ObjectUpdate <$> (C.indented *> C.braces (C.commaSep1 (C.indented *> parsePropertyUpdate))) <*> pure v ]
137− postfixTable2 = [ \v -> P.try (C.indented *> indexersAndAccessors >>= \t2 -> return (\t1 -> App t1 [t2])) <*> pure v
138− , \v -> P.try $ flip App <$> (C.indented *> C.parens (C.commaSep parseValue)) <*> pure v
139− , \v -> flip TypedValue <$> (P.try (C.lexeme (C.indented *> P.string "::")) *> parsePolyType) <*> pure v ]
140− operators = [ [ Prefix $ C.lexeme (P.try $ C.indented *> C.reservedOp "!") >> return (Unary Not)
141− , Prefix $ C.lexeme (P.try $ C.indented *> C.reservedOp "~") >> return (Unary BitwiseNot)
142− , Prefix $ C.lexeme (P.try $ C.indented *> C.reservedOp "-") >> return (Unary Negate)
143− , Prefix $ C.lexeme (P.try $ C.indented *> C.reservedOp "+") >> return id ]
144− , [ Infix (C.lexeme (P.try (C.indented *> C.parseIdentInfix P.<?> "operator") >>= \ident ->
145− return (BinaryNoParens ident))) AssocRight ]
146− ]
147−
148−parseVariableIntroduction :: P.Parsec String ParseState Statement
149−parseVariableIntroduction = do
150− C.reserved "var"
151− name <- C.indented *> C.parseIdent
152− C.lexeme $ C.indented *> P.char '='
153− value <- parseValue
154− C.indented *> C.semi
155− return $ VariableIntroduction name value
156−
157−parseAssignment :: P.Parsec String ParseState Statement
158−parseAssignment = do
159− tgt <- P.try $ do
160− tgt <- C.parseIdent
161− C.lexeme $ C.indented *> P.char '='
162− return tgt
163− value <- parseValue
164− C.indented *> C.semi
165− return $ Assignment tgt value
166−
167−parseWhile :: P.Parsec String ParseState Statement
168−parseWhile = While <$> (C.reserved "while" *> C.indented *> C.parens parseValue)
169− <*> (C.indented *> parseManyStatements)
170−
171−parseFor :: P.Parsec String ParseState Statement
172−parseFor = For <$> (C.reserved "for" *> C.indented *> C.lexeme (P.char '(') *> C.indented *> C.parseIdent)
173− <*> (C.indented *> C.lexeme (P.string "<-") *> parseValue)
174− <*> (C.indented *> C.reserved "until" *> parseValue <* C.indented <* C.lexeme (P.char ')'))
175− <*> parseManyStatements
176−
177−parseForEach :: P.Parsec String ParseState Statement
178−parseForEach = ForEach <$> (C.reserved "foreach" *> C.indented *> C.lexeme (P.char '(') *> C.indented *> C.parseIdent)
179− <*> (C.indented *> C.reserved "in" *> parseValue <* C.lexeme (P.char ')'))
180− <*> parseManyStatements
181−
182−parseIf :: P.Parsec String ParseState Statement
183−parseIf = If <$> parseIfStatement
184−
185−parseIfStatement :: P.Parsec String ParseState IfStatement
186−parseIfStatement =
187− IfStatement <$> (C.reserved "if" *> C.indented *> C.parens parseValue)
188− <*> parseManyStatements
189− <*> P.optionMaybe parseElseStatement
190−
191−parseElseStatement :: P.Parsec String ParseState ElseStatement
192−parseElseStatement = C.reserved "else" >> (ElseIf <$> parseIfStatement
193− <|> Else <$> parseManyStatements)
194−
195−parseValueStatement :: P.Parsec String ParseState Statement
196−parseValueStatement = ValueStatement <$> (parseValue <* C.semi)
197−
198−parseReturn :: P.Parsec String ParseState Statement
199−parseReturn = Return <$> (C.reserved "return" *> parseValue <* C.indented <* C.semi)
200−
201−parseStatement :: P.Parsec String ParseState Statement
202−parseStatement = P.choice
203− [ parseVariableIntroduction
204− , parseAssignment
205− , parseWhile
206− , parseFor
207− , parseForEach
208− , parseIf
209− , parseValueStatement
210− , parseReturn ] P.<?> "statement"
211−
212−parseStringBinder :: P.Parsec String ParseState Binder
213−parseStringBinder = StringBinder <$> C.stringLiteral
214−
215−parseBooleanBinder :: P.Parsec String ParseState Binder
216−parseBooleanBinder = BooleanBinder <$> booleanLiteral
217−
218−parseNumberBinder :: P.Parsec String ParseState Binder
219−parseNumberBinder = NumberBinder <$> C.integerOrFloat
220−
221−parseVarBinder :: P.Parsec String ParseState Binder
222−parseVarBinder = VarBinder <$> C.parseIdent
223−
224−parseNullaryBinder :: P.Parsec String ParseState Binder
225−parseNullaryBinder = NullaryBinder <$> C.lexeme (C.parseQualified C.properName)
226−
227−parseUnaryBinder :: P.Parsec String ParseState Binder
228−parseUnaryBinder = UnaryBinder <$> C.lexeme (C.parseQualified C.properName) <*> (C.indented *> parseBinder)
229−
230−parseObjectBinder :: P.Parsec String ParseState Binder
231−parseObjectBinder = ObjectBinder <$> C.braces (C.commaSep (C.indented *> parseIdentifierAndBinder))
232−
233−parseArrayBinder :: P.Parsec String ParseState Binder
234−parseArrayBinder = C.squares $ ArrayBinder <$> (C.commaSep (C.indented *> parseBinder))
235−
236−parseNamedBinder :: P.Parsec String ParseState Binder
237−parseNamedBinder = NamedBinder <$> (C.parseIdent <* C.indented <* C.lexeme (P.char '@'))
238− <*> (C.indented *> parseBinder)
239−
240−parseNullBinder :: P.Parsec String ParseState Binder
241−parseNullBinder = C.lexeme (P.char '_') *> P.notFollowedBy C.identLetter *> return NullBinder
242−
243−parseIdentifierAndBinder :: P.Parsec String ParseState (String, Binder)
244−parseIdentifierAndBinder = do
245− name <- C.lexeme C.identifier
246− C.lexeme $ C.indented *> P.char '='
247− binder <- C.indented *> parseBinder
248− return (name, binder)
249−
250−parseBinderAtom :: P.Parsec String ParseState Binder
251−parseBinderAtom = P.choice (map P.try
252− [ parseNullBinder
253− , parseStringBinder
254− , parseBooleanBinder
255− , parseNumberBinder
256− , parseNamedBinder
257− , parseVarBinder
258− , parseUnaryBinder
259− , parseNullaryBinder
260− , parseObjectBinder
261− , parseArrayBinder
262− , C.parens parseBinder ]) P.<?> "binder"
263−
264−parseBinder :: P.Parsec String ParseState Binder
265−parseBinder = (buildExpressionParser operators parseBinderAtom) P.<?> "expression"
266− where
267− operators = [ [ Infix ( C.lexeme (P.try $ C.indented *> C.reservedOp ":") >> return ConsBinder) AssocRight ] ]
268−
269−parseBinderNoParens :: P.Parsec String ParseState Binder
270−parseBinderNoParens = P.choice (map P.try
271− [ parseNullBinder
272− , parseStringBinder
273− , parseBooleanBinder
274− , parseNumberBinder
275− , parseNamedBinder
276− , parseVarBinder
277− , parseNullaryBinder
278− , parseObjectBinder
279− , parseArrayBinder
280− , C.parens parseBinder ]) P.<?> "binder"
281−
282−parseGuard :: P.Parsec String ParseState Guard
283−parseGuard = C.indented *> C.pipe *> C.indented *> parseValue
284−
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−224
@@ -1,224 +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 _ = mzero
122−
123−targetToJs :: JSAssignment -> String
124−targetToJs (JSAssignVariable ident) = identToJs ident
125−targetToJs (JSAssignProperty prop target) = targetToJs target ++ "." ++ prop
126−
127−conditional :: Pattern PrinterState JS ((JS, JS), JS)
128−conditional = mkPattern match
129− where
130− match (JSConditional cond th el) = Just ((th, el), cond)
131− match _ = Nothing
132−
133−accessor :: Pattern PrinterState JS (String, JS)
134−accessor = mkPattern match
135− where
136− match (JSAccessor prop val) = Just (prop, val)
137− match _ = Nothing
138−
139−indexer :: Pattern PrinterState JS (String, JS)
140−indexer = mkPattern' match
141− where
142− match (JSIndexer index val) = (,) <$> prettyPrintJS' index <*> pure val
143− match _ = mzero
144−
145−lam :: Pattern PrinterState JS ((Maybe Ident, [Ident]), JS)
146−lam = mkPattern match
147− where
148− match (JSFunction name args ret) = Just ((name, args), ret)
149− match _ = Nothing
150−
151−app :: Pattern PrinterState JS (String, JS)
152−app = mkPattern' match
153− where
154− match (JSApp val args) = do
155− jss <- mapM prettyPrintJS' args
156− return (intercalate ", " jss, val)
157− match _ = mzero
158−
159−unary :: UnaryOperator -> String -> Operator PrinterState JS String
160−unary op str = Wrap match (++)
161− where
162− match :: Pattern PrinterState JS (String, JS)
163− match = mkPattern match'
164− where
165− match' (JSUnary op' val) | op' == op = Just (str, val)
166− match' _ = Nothing
167−
168−binary :: BinaryOperator -> String -> Operator PrinterState JS String
169−binary op str = AssocR match (\v1 v2 -> v1 ++ " " ++ str ++ " " ++ v2)
170− where
171− match :: Pattern PrinterState JS (JS, JS)
172− match = mkPattern match'
173− where
174− match' (JSBinary op' v1 v2) | op' == op = Just (v1, v2)
175− match' _ = Nothing
176−
177−prettyPrintJS1 :: JS -> String
178−prettyPrintJS1 = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyPrintJS'
179−
180−prettyPrintJS :: [JS] -> String
181−prettyPrintJS sts = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) $ do
182− jss <- forM sts prettyPrintJS'
183− indentString <- currentIndent
184− return $ intercalate "\n" $ map (++ "; ") $ map (indentString ++) jss
185−
186−prettyPrintJS' :: JS -> StateT PrinterState Maybe String
187−prettyPrintJS' = A.runKleisli $ runPattern matchValue
188− where
189− matchValue :: Pattern PrinterState JS String
190− matchValue = buildPrettyPrinter operators (literals <+> fmap parens matchValue)
191− operators :: OperatorTable PrinterState JS String
192− operators =
193− OperatorTable [ [ Wrap accessor $ \prop val -> val ++ "." ++ prop ]
194− , [ Wrap indexer $ \index val -> val ++ "[" ++ index ++ "]" ]
195− , [ Wrap app $ \args val -> val ++ "(" ++ args ++ ")" ]
196− , [ Wrap lam $ \(name, args) ret -> "function "
197− ++ maybe "" identToJs name
198− ++ "(" ++ intercalate ", " (map identToJs args) ++ ") "
199− ++ ret ]
200− , [ Wrap conditional $ \(th, el) cond -> cond ++ " ? " ++ prettyPrintJS1 th ++ " : " ++ prettyPrintJS1 el ]
201− , [ binary LessThan "<" ]
202− , [ binary LessThanOrEqualTo "<=" ]
203− , [ binary GreaterThan ">" ]
204− , [ binary GreaterThanOrEqualTo ">=" ]
205− , [ unary Not "!" ]
206− , [ unary BitwiseNot "~" ]
207− , [ unary Negate "-" ]
208− , [ binary Multiply "*" ]
209− , [ binary Divide "/" ]
210− , [ binary Modulus "%" ]
211− , [ binary Concat "+" ]
212− , [ binary Add "+" ]
213− , [ binary Subtract "-" ]
214− , [ binary ShiftLeft "<<" ]
215− , [ binary ShiftRight ">>" ]
216− , [ binary ZeroFillShiftRight ">>>" ]
217− , [ binary EqualTo "===" ]
218− , [ binary NotEqualTo "!==" ]
219− , [ binary BitwiseAnd "&" ]
220− , [ binary BitwiseXor "^" ]
221− , [ binary BitwiseOr "|" ]
222− , [ binary And "&&" ]
223− , [ binary Or "||" ]
224− ]
src/Language/PureScript/Pretty/Kinds.hsdeleted−47
@@ -1,47 +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 Row = Just "#"
31− match (KUnknown (Unknown u)) = Just $ 'u' : show u
32− match _ = Nothing
33−
34−funKind :: Pattern () Kind (Kind, Kind)
35−funKind = mkPattern match
36− where
37− match (FunKind arg ret) = Just (arg, ret)
38− match _ = Nothing
39−
40−prettyPrintKind :: Kind -> String
41−prettyPrintKind = fromMaybe (error "Incomplete pattern") . pattern matchKind ()
42− where
43− matchKind :: Pattern () Kind String
44− matchKind = buildPrettyPrinter operators (typeLiterals <+> fmap parens matchKind)
45− operators :: OperatorTable () Kind String
46− operators =
47− OperatorTable [ [ AssocR funKind $ \arg ret -> arg ++ " -> " ++ ret ] ]
src/Language/PureScript/Pretty/Types.hsdeleted−88
@@ -1,88 +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 ty) = Just $ "[" ++ prettyPrintType ty ++ "]"
35− match (Object row) = Just $ "{ " ++ prettyPrintRow 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 (SaturatedTypeSynonym name args) = Just $ show name ++ "<" ++ intercalate "," (map prettyPrintType args) ++ ">"
41− match (ForAll ident ty) = Just $ "forall " ++ ident ++ ". " ++ prettyPrintType ty
42− match _ = Nothing
43−
44−prettyPrintRow :: Row -> String
45−prettyPrintRow = (\(tys, rest) -> intercalate ", " (map (uncurry nameAndTypeToPs) tys) ++ tailToPs rest) . toList []
46− where
47− nameAndTypeToPs :: String -> Type -> String
48− nameAndTypeToPs name ty = name ++ " :: " ++ prettyPrintType ty
49− tailToPs :: Row -> String
50− tailToPs REmpty = ""
51− tailToPs (RUnknown (Unknown u)) = " | u" ++ show u
52− tailToPs (RowVar var) = " | " ++ var
53− tailToPs (RSkolem s) = " | s" ++ show s
54− tailToPs _ = error "Invalid row tail"
55− toList :: [(String, Type)] -> Row -> ([(String, Type)], Row)
56− toList tys (RCons name ty row) = toList ((name, ty):tys) row
57− toList tys r = (tys, r)
58−
59−typeApp :: Pattern () Type (Type, Type)
60−typeApp = mkPattern match
61− where
62− match (TypeApp f x) = Just (f, x)
63− match _ = Nothing
64−
65−singleArgumentFunction :: Pattern () Type (Type, Type)
66−singleArgumentFunction = mkPattern match
67− where
68− match (Function [arg] ret) = Just (arg, ret)
69− match _ = Nothing
70−
71−function :: Pattern () Type ([Type], Type)
72−function = mkPattern match
73− where
74− match (Function args ret) = Just (args, ret)
75− match _ = Nothing
76−
77−prettyPrintType :: Type -> String
78−prettyPrintType = fromMaybe (error "Incomplete pattern") . pattern matchType ()
79− where
80− matchType :: Pattern () Type String
81− matchType = buildPrettyPrinter operators (typeLiterals <+> fmap parens matchType)
82− operators :: OperatorTable () Type String
83− operators =
84− OperatorTable [ [ AssocL typeApp $ \f x -> f ++ " " ++ x ]
85− , [ AssocR singleArgumentFunction $ \arg ret -> arg ++ " -> " ++ ret
86− , Wrap function $ \args ret -> "(" ++ intercalate ", " (map prettyPrintType args) ++ ") -> " ++ ret
87− ]
88− ]
src/Language/PureScript/Pretty/Values.hsdeleted−210
@@ -1,210 +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 _ = Nothing
44−
45−prettyPrintCaseAlternative :: ([Binder], Maybe Guard, Value) -> String
46−prettyPrintCaseAlternative (binders, grd, val) = "(" ++ intercalate ", " (map prettyPrintBinder binders) ++ ") " ++
47− (maybe "" (("| " ++) . prettyPrintValue) grd) ++ " -> " ++ prettyPrintValue val
48−
49−ifThenElse :: Pattern () Value ((Value, Value), Value)
50−ifThenElse = mkPattern match
51− where
52− match (IfThenElse cond th el) = Just ((th, el), cond)
53− match _ = Nothing
54−
55−accessor :: Pattern () Value (String, Value)
56−accessor = mkPattern match
57− where
58− match (Accessor prop val) = Just (prop, val)
59− match _ = Nothing
60−
61−indexer :: Pattern () Value (Value, Value)
62−indexer = mkPattern match
63− where
64− match (Indexer index val) = Just (index, val)
65− match _ = Nothing
66−
67−objectUpdate :: Pattern () Value ([String], Value)
68−objectUpdate = mkPattern match
69− where
70− match (ObjectUpdate o ps) = Just (flip map ps $ \(key, val) -> key ++ " = " ++ prettyPrintValue val, o)
71− match _ = Nothing
72−
73−app :: Pattern () Value (String, Value)
74−app = mkPattern match
75− where
76− match (App val args) = Just (intercalate "," (map prettyPrintValue args), val)
77− match _ = Nothing
78−
79−lam :: Pattern () Value ([String], Value)
80−lam = mkPattern match
81− where
82− match (Abs args val) = Just (map show args, val)
83− match _ = Nothing
84−
85−typed :: Pattern () Value (PolyType, Value)
86−typed = mkPattern match
87− where
88− match (TypedValue val ty) = Just (ty, val)
89− match _ = Nothing
90−
91−unary :: UnaryOperator -> String -> Operator () Value String
92−unary op str = Wrap match (++)
93− where
94− match :: Pattern () Value (String, Value)
95− match = mkPattern match'
96− where
97− match' (Unary op' val) | op' == op = Just (str, val)
98− match' _ = Nothing
99−
100−binary :: BinaryOperator -> String -> Operator () Value String
101−binary op str = AssocR match (\v1 v2 -> v1 ++ " " ++ str ++ " " ++ v2)
102− where
103− match :: Pattern () Value (Value, Value)
104− match = mkPattern match'
105− where
106− match' (Binary op' v1 v2) | op' == op = Just (v1, v2)
107− match' _ = Nothing
108−
109−prettyPrintValue :: Value -> String
110−prettyPrintValue = fromMaybe (error "Incomplete pattern") . pattern matchValue ()
111− where
112− matchValue :: Pattern () Value String
113− matchValue = buildPrettyPrinter operators (literals <+> fmap parens matchValue)
114− operators :: OperatorTable () Value String
115− operators =
116− OperatorTable [ [ Wrap accessor $ \prop val -> val ++ "." ++ prop ]
117− , [ Wrap objectUpdate $ \ps val -> val ++ "{ " ++ intercalate ", " ps ++ " }" ]
118− , [ Wrap app $ \args val -> val ++ "(" ++ args ++ ")" ]
119− , [ Split lam $ \args val -> "\\" ++ intercalate ", " args ++ " -> " ++ prettyPrintValue val ]
120− , [ Wrap ifThenElse $ \(th, el) cond -> cond ++ " ? " ++ prettyPrintValue th ++ " : " ++ prettyPrintValue el ]
121− , [ Wrap typed $ \ty val -> val ++ " :: " ++ prettyPrintType ty ]
122− , [ AssocR indexer (\index val -> val ++ " !! " ++ index) ]
123− , [ binary LessThan "<" ]
124− , [ binary LessThanOrEqualTo "<=" ]
125− , [ binary GreaterThan ">" ]
126− , [ binary GreaterThanOrEqualTo ">=" ]
127− , [ unary Not "!" ]
128− , [ unary BitwiseNot "~" ]
129− , [ unary Negate "-" ]
130− , [ binary Multiply "*" ]
131− , [ binary Divide "/" ]
132− , [ binary Modulus "%" ]
133− , [ binary Concat "++" ]
134− , [ binary Add "+" ]
135− , [ binary Subtract "-" ]
136− , [ binary ShiftLeft "<<" ]
137− , [ binary ShiftRight ">>" ]
138− , [ binary ZeroFillShiftRight ">>>" ]
139− , [ binary EqualTo "==" ]
140− , [ binary NotEqualTo "!=" ]
141− , [ binary BitwiseAnd "&" ]
142− , [ binary BitwiseXor "^" ]
143− , [ binary BitwiseOr "|" ]
144− , [ binary And "&&" ]
145− , [ binary Or "||" ]
146− ]
147−
148−prettyPrintBinderAtom :: Pattern () Binder String
149−prettyPrintBinderAtom = mkPattern match
150− where
151− match :: Binder -> Maybe String
152− match NullBinder = Just "_"
153− match (StringBinder str) = Just $ show str
154− match (NumberBinder num) = Just $ either show show num
155− match (BooleanBinder True) = Just "true"
156− match (BooleanBinder False) = Just "false"
157− match (VarBinder ident) = Just $ show ident
158− match (NullaryBinder ctor) = Just $ show ctor
159− match (UnaryBinder ctor b) = Just $ show ctor ++ " " ++ prettyPrintBinder b
160− match (ObjectBinder bs) = Just $ "{ " ++ intercalate ", " (map (uncurry prettyPrintObjectPropertyBinder) bs) ++ " }"
161− match (ArrayBinder bs) = Just $ "[ " ++ intercalate ", " (map prettyPrintBinder bs) ++ " ]"
162− match (NamedBinder ident binder) = Just $ show ident ++ "@" ++ prettyPrintBinder binder
163− match _ = Nothing
164−
165−prettyPrintBinder :: Binder -> String
166−prettyPrintBinder = fromMaybe (error "Incomplete pattern") . pattern matchBinder ()
167− where
168− matchBinder :: Pattern () Binder String
169− matchBinder = buildPrettyPrinter operators (prettyPrintBinderAtom <+> fmap parens matchBinder)
170− operators :: OperatorTable () Binder String
171− operators =
172− OperatorTable [ [ AssocR matchConsBinder (\b1 b2 -> b1 ++ " : " ++ b2) ] ]
173−
174−matchConsBinder :: Pattern () Binder (Binder, Binder)
175−matchConsBinder = mkPattern match'
176− where
177− match' (ConsBinder b1 b2) = Just (b1, b2)
178− match' _ = Nothing
179−
180−prettyPrintObjectPropertyBinder :: String -> Binder -> String
181−prettyPrintObjectPropertyBinder key binder = key ++ ": " ++ prettyPrintBinder binder
182−
183−prettyPrintObjectProperty :: String -> Value -> String
184−prettyPrintObjectProperty key value = key ++ ": " ++ prettyPrintValue value
185−
186−prettyPrintStatement :: Statement -> String
187−prettyPrintStatement (VariableIntroduction ident value) = "var " ++ show ident ++ " = " ++ prettyPrintValue value
188−prettyPrintStatement (Assignment target value) = show target ++ " = " ++ prettyPrintValue value
189−prettyPrintStatement (While cond sts) = "while " ++ prettyPrintValue cond ++ ": {" ++ intercalate ";" (map prettyPrintStatement sts) ++ " }"
190−prettyPrintStatement (For ident start end sts) = "for " ++ show ident
191− ++ " <- " ++ prettyPrintValue start
192− ++ " until " ++ prettyPrintValue end ++ ": {"
193− ++ intercalate "; " (map prettyPrintStatement sts) ++ " }"
194−prettyPrintStatement (ForEach ident arr sts) = "foreach " ++ show ident
195− ++ " in " ++ prettyPrintValue arr ++ ": {"
196− ++ intercalate "; " (map prettyPrintStatement sts) ++ " }"
197−prettyPrintStatement (If ifst) = prettyPrintIfStatement ifst
198−prettyPrintStatement (ValueStatement val) = prettyPrintValue val
199−prettyPrintStatement (Return value) = "return " ++ prettyPrintValue value
200−
201−prettyPrintIfStatement :: IfStatement -> String
202−prettyPrintIfStatement (IfStatement cond thens elst) =
203− "if "
204− ++ prettyPrintValue cond ++ ": {"
205− ++ intercalate "; " (map prettyPrintStatement thens) ++ " }"
206− ++ maybe "" prettyPrintElseStatement elst
207−
208−prettyPrintElseStatement :: ElseStatement -> String
209−prettyPrintElseStatement (Else sts) = "else: {" ++ intercalate "; " (map prettyPrintStatement sts) ++ " }"
210−prettyPrintElseStatement (ElseIf ifst) = "else " ++ prettyPrintIfStatement ifst
src/Language/PureScript/Scope.hsdeleted−75
@@ -1,75 +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− firstUnusedName
19−) where
20−
21−import Data.Data
22−import Data.List ((\\), nub)
23−import Data.Generics (extQ, mkQ, everything)
24−
25−import Language.PureScript.Values
26−import Language.PureScript.Names
27−import Language.PureScript.CodeGen.JS.AST
28−import Data.Maybe (mapMaybe)
29−
30−usedNames :: (Data d) => d -> [Ident]
31−usedNames val = nub $ everything (++) (mkQ [] namesV `extQ` namesS `extQ` namesB `extQ` namesJS) val
32− where
33− namesV :: Value -> [Ident]
34− namesV (Abs args _) = args
35− namesV (Var (Qualified Nothing name)) = [name]
36− namesV _ = []
37− namesS :: Statement -> [Ident]
38− namesS (VariableIntroduction name _) = [name]
39− namesS (For name _ _ _) = [name]
40− namesS _ = []
41− namesB :: Binder -> [Ident]
42− namesB (VarBinder name) = [name]
43− namesB _ = []
44− namesJS :: JS -> [Ident]
45− namesJS (JSVar name) = [name]
46− namesJS (JSFunction (Just name) args _) = name : args
47− namesJS (JSFunction Nothing args _) = args
48− namesJS (JSVariableIntroduction name _) = [name]
49− namesJS (JSFor name _ _ _) = [name]
50− namesJS _ = []
51−
52−unusedNames :: (Data d) => d -> [Ident]
53−unusedNames val =
54− let
55− allNames = usedNames val
56− varNames = map (Ident . ('_' :) . show) ([1..] :: [Int])
57− in
58− varNames \\ allNames
59−
60−firstUnusedName :: (Data d) => d -> Int
61−firstUnusedName val =
62− let
63− allNames = usedNames val
64− varNames = mapMaybe toUnknown allNames
65− in
66− 1 + maximum (0 : varNames)
67− where
68− toUnknown :: Ident -> Maybe Int
69− toUnknown (Ident ('_' : s)) = readMaybe s
70− toUnknown _ = Nothing
71−
72−readMaybe :: String -> Maybe Int
73−readMaybe s = case reads s of
74− [(n, "")] -> Just n
75− _ -> Nothing
src/Language/PureScript/TypeChecker.hsdeleted−198
@@ -1,198 +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.Kinds
36−import Language.PureScript.Declarations
37−
38−addDataType :: ModuleName -> ProperName -> [String] -> [(ProperName, Maybe Type)] -> Kind -> Check ()
39−addDataType moduleName name args dctors ctorKind = do
40− env <- getEnv
41− putEnv $ env { types = M.insert (moduleName, name) (ctorKind, Data) (types env) }
42− forM_ dctors $ \(dctor, maybeTy) ->
43− rethrow (("Error in data constructor " ++ show name ++ ":\n") ++) $
44− addDataConstructor moduleName name args dctor maybeTy
45−
46−addDataConstructor :: ModuleName -> ProperName -> [String] -> ProperName -> Maybe Type -> Check ()
47−addDataConstructor moduleName name args dctor maybeTy = do
48− env <- getEnv
49− dataConstructorIsNotDefined moduleName dctor
50− let retTy = foldl TypeApp (TypeConstructor (Qualified (Just moduleName) name)) (map TypeVar args)
51− let dctorTy = maybe retTy (\ty -> Function [ty] retTy) maybeTy
52− let polyType = mkForAll args dctorTy
53− putEnv $ env { dataConstructors = M.insert (moduleName, dctor) polyType (dataConstructors env) }
54−
55−addTypeSynonym :: ModuleName -> ProperName -> [String] -> Type -> Kind -> Check ()
56−addTypeSynonym moduleName name args ty kind = do
57− env <- getEnv
58− putEnv $ env { types = M.insert (moduleName, name) (kind, TypeSynonym) (types env)
59− , typeSynonyms = M.insert (moduleName, name) (args, ty) (typeSynonyms env) }
60−
61−typeIsNotDefined :: ModuleName -> ProperName -> Check ()
62−typeIsNotDefined moduleName name = do
63− env <- getEnv
64− guardWith (show name ++ " is already defined") $
65− not $ M.member (moduleName, name) (types env)
66−
67−dataConstructorIsNotDefined :: ModuleName -> ProperName -> Check ()
68−dataConstructorIsNotDefined moduleName dctor = do
69− env <- getEnv
70− guardWith (show dctor ++ " is already defined") $
71− not $ M.member (moduleName, dctor) (dataConstructors env)
72−
73−valueIsNotDefined :: ModuleName -> Ident -> Check ()
74−valueIsNotDefined moduleName name = do
75− env <- getEnv
76− case M.lookup (moduleName, name) (names env) of
77− Just _ -> throwError $ show name ++ " is already defined"
78− Nothing -> return ()
79−
80−addValue :: ModuleName -> Ident -> Type -> Check ()
81−addValue moduleName name ty = do
82− env <- getEnv
83− putEnv (env { names = M.insert (moduleName, name) (ty, Value) (names env) })
84−
85−typeCheckAll :: ModuleName -> [Declaration] -> Check ()
86−typeCheckAll _ [] = return ()
87−typeCheckAll moduleName (DataDeclaration name args dctors : rest) = do
88− rethrow (("Error in type constructor " ++ show name ++ ":\n") ++) $ do
89− typeIsNotDefined moduleName name
90− ctorKind <- kindsOf moduleName name args (mapMaybe snd dctors)
91− addDataType moduleName name args dctors ctorKind
92− typeCheckAll moduleName rest
93−typeCheckAll moduleName (DataBindingGroupDeclaration tys : rest) = do
94− rethrow (("Error in data binding group " ++ show (map (\(name, _, _) -> name) tys) ++ ":\n") ++) $ do
95− forM_ tys $ \(name, _, _) ->
96− typeIsNotDefined moduleName name
97− ks <- kindsOfAll moduleName (map (\(name, args, dctors) -> (name, args, mapMaybe snd dctors)) tys)
98− forM (zip tys ks) $ \((name, args, dctors), ctorKind) ->
99− addDataType moduleName name args dctors ctorKind
100− typeCheckAll moduleName rest
101−typeCheckAll moduleName (TypeSynonymDeclaration name args ty : rest) = do
102− rethrow (("Error in type synonym " ++ show name ++ ":\n") ++) $ do
103− typeIsNotDefined moduleName name
104− kind <- kindsOf moduleName name args [ty]
105− addTypeSynonym moduleName name args ty kind
106− typeCheckAll moduleName rest
107−typeCheckAll _ (TypeDeclaration _ _ : _) = error "Type declarations should have been removed"
108−typeCheckAll moduleName (ValueDeclaration name [] Nothing val : rest) = do
109− rethrow (("Error in declaration " ++ show name ++ ":\n") ++) $ do
110− valueIsNotDefined moduleName name
111− [ty] <- typesOf moduleName [(name, val)]
112− addValue moduleName name ty
113− typeCheckAll moduleName rest
114−typeCheckAll _ (ValueDeclaration _ _ _ _ : _) = error "Binders were not desugared"
115−typeCheckAll moduleName (BindingGroupDeclaration vals : rest) = do
116− rethrow (("Error in binding group " ++ show (map fst vals) ++ ":\n") ++) $ do
117− forM_ (map fst vals) $ \name ->
118− valueIsNotDefined moduleName name
119− tys <- typesOf moduleName vals
120− forM (zip (map fst vals) tys) $ \(name, ty) ->
121− addValue moduleName name ty
122− typeCheckAll moduleName rest
123−typeCheckAll moduleName (ExternDataDeclaration name kind : rest) = do
124− env <- getEnv
125− guardWith (show name ++ " is already defined") $ not $ M.member (moduleName, name) (types env)
126− putEnv $ env { types = M.insert (moduleName, name) (kind, TypeSynonym) (types env) }
127− typeCheckAll moduleName rest
128−typeCheckAll moduleName (ExternMemberDeclaration member name ty : rest) = do
129− rethrow (("Error in foreign import member declaration " ++ show name ++ ":\n") ++) $ do
130− env <- getEnv
131− kind <- kindOf moduleName ty
132− guardWith "Expected kind *" $ kind == Star
133− case M.lookup (moduleName, name) (names env) of
134− Just _ -> throwError $ show name ++ " is already defined"
135− Nothing -> case ty of
136− _ | isSingleArgumentFunction ty -> do
137− putEnv (env { names = M.insert (moduleName, name) (ty, Extern) (names env)
138− , members = M.insert (moduleName, name) member (members env) })
139− | otherwise -> throwError "Foreign member declarations must have function types, with an single argument."
140− typeCheckAll moduleName rest
141− where
142− isSingleArgumentFunction (Function [_] _) = True
143− isSingleArgumentFunction (ForAll _ t) = isSingleArgumentFunction t
144− isSingleArgumentFunction _ = False
145−typeCheckAll moduleName (ExternDeclaration name ty : rest) = do
146− rethrow (("Error in foreign import declaration " ++ show name ++ ":\n") ++) $ do
147− env <- getEnv
148− kind <- kindOf moduleName ty
149− guardWith "Expected kind *" $ kind == Star
150− case M.lookup (moduleName, name) (names env) of
151− Just _ -> throwError $ show name ++ " is already defined"
152− Nothing -> putEnv (env { names = M.insert (moduleName, name) (ty, Extern) (names env) })
153− typeCheckAll moduleName rest
154−typeCheckAll moduleName (FixityDeclaration _ name : rest) = do
155− typeCheckAll moduleName rest
156− env <- getEnv
157− guardWith ("Fixity declaration with no binding: " ++ name) $ M.member (moduleName, Op name) $ names env
158−typeCheckAll currentModule (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− typeCheckAll currentModule rest
170− where errorMessage = (("Error in import declaration " ++ show moduleName ++ ":\n") ++)
171− filterModule = filter ((== moduleName) . fst) . M.keys
172− moduleExists env = not (null (filterModule (names env))) || not (null (filterModule (types env)))
173− shadowIdents idents' env =
174− forM_ idents' $ \ident -> do
175− guardWith (show currentModule ++ "." ++ show ident ++ " is already defined") $ (currentModule, ident) `M.notMember` names env
176− case (moduleName, ident) `M.lookup` names env of
177− Just (pt, _) -> modifyEnv (\e -> e { names = M.insert (currentModule, ident) (pt, Alias moduleName ident) (names e) })
178− Nothing -> throwError (show moduleName ++ "." ++ show ident ++ " is undefined")
179− shadowTypes pns env =
180− forM_ pns $ \pn -> do
181− guardWith (show currentModule ++ "." ++ show pn ++ " is already defined") $ (currentModule, pn) `M.notMember` types env
182− case (moduleName, pn) `M.lookup` types env of
183− Nothing -> throwError (show moduleName ++ "." ++ show pn ++ " is undefined")
184− Just (k, _) -> do
185− modifyEnv (\e -> e { types = M.insert (currentModule, pn) (k, DataAlias moduleName pn) (types e) })
186− let keys = map (snd . fst) . filter (\(_, fn) -> fn `constructs` pn) . M.toList . dataConstructors $ env
187− forM_ keys $ \dctor -> do
188− guardWith (show currentModule ++ "." ++ show dctor ++ " is already defined") $ (currentModule, dctor) `M.notMember` dataConstructors env
189− case (moduleName, dctor) `M.lookup` dataConstructors env of
190− Just ctorTy -> modifyEnv (\e -> e { dataConstructors = M.insert (currentModule, dctor) ctorTy (dataConstructors e) })
191− Nothing -> throwError (show moduleName ++ "." ++ show dctor ++ " is undefined")
192− constructs (TypeConstructor (Qualified (Just mn) pn')) pn
193− = mn == moduleName && pn' == pn
194− constructs (ForAll _ ty) pn = ty `constructs` pn
195− constructs (Function _ ty) pn = ty `constructs` pn
196− constructs (TypeApp ty _) pn = ty `constructs` pn
197− constructs fn _ = error $ "Invalid arguments to construct" ++ show fn
198−
src/Language/PureScript/TypeChecker/Kinds.hsdeleted−139
@@ -1,139 +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−{-# LANGUAGE DeriveDataTypeable #-}
16−
17−module Language.PureScript.TypeChecker.Kinds (
18− kindOf,
19− kindsOf,
20− kindsOfAll
21−) where
22−
23−import Language.PureScript.Types
24−import Language.PureScript.Kinds
25−import Language.PureScript.Names
26−import Language.PureScript.TypeChecker.Monad
27−import Language.PureScript.Pretty
28−import Language.PureScript.Unknown
29−
30−import Control.Monad.State
31−import Control.Monad.Error
32−import Control.Monad.Reader
33−
34−import Control.Applicative
35−
36−import qualified Data.Map as M
37−
38−instance Unifiable Kind where
39− unknown = KUnknown
40− isUnknown (KUnknown u) = Just u
41− isUnknown _ = Nothing
42− KUnknown u1 ~~ KUnknown u2 | u1 == u2 = return ()
43− KUnknown u ~~ k = replace u k
44− k ~~ KUnknown u = replace u k
45− Star ~~ Star = return ()
46− Row ~~ Row = return ()
47− FunKind k1 k2 ~~ FunKind k3 k4 = do
48− k1 ~~ k3
49− k2 ~~ k4
50− k1 ~~ k2 = throwError $ "Cannot unify " ++ prettyPrintKind k1 ++ " with " ++ prettyPrintKind k2 ++ "."
51− apply s (KUnknown u) = runSubstitution s u
52− apply s (FunKind k1 k2) = FunKind (apply s k1) (apply s k2)
53− apply _ k = k
54− unknowns (KUnknown (Unknown u)) = [u]
55− unknowns (FunKind k1 k2) = unknowns k1 ++ unknowns k2
56− unknowns _ = []
57−
58−kindOf :: ModuleName -> Type -> Check Kind
59−kindOf moduleName ty = fmap (\(k, _, _) -> k) . runSubst (SubstContext moduleName) $ starIfUnknown <$> infer ty
60−
61−kindsOf :: ModuleName -> ProperName -> [String] -> [PolyType] -> Check Kind
62−kindsOf moduleName name args ts = fmap (starIfUnknown . (\(k, _, _) -> k)) . runSubst (SubstContext moduleName) $ do
63− tyCon <- fresh
64− kargs <- replicateM (length args) fresh
65− let dict = (name, tyCon) : zip (map ProperName args) kargs
66− bindLocalTypeVariables moduleName dict $
67− solveTypes ts kargs tyCon
68−
69−kindsOfAll :: ModuleName -> [(ProperName, [String], [PolyType])] -> Check [Kind]
70−kindsOfAll moduleName tys = fmap (map starIfUnknown . (\(ks, _, _) -> ks)) . runSubst (SubstContext moduleName) $ do
71− tyCons <- replicateM (length tys) fresh
72− let dict = zipWith (\(name, _, _) tyCon -> (name, tyCon)) tys tyCons
73− bindLocalTypeVariables moduleName dict $
74− zipWithM (\tyCon (_, args, ts) -> do
75− kargs <- replicateM (length args) fresh
76− let argDict = zip (map ProperName args) kargs
77− bindLocalTypeVariables moduleName argDict $
78− solveTypes ts kargs tyCon) tyCons tys
79−
80−solveTypes :: [Type] -> [Kind] -> Kind -> Subst Kind
81−solveTypes ts kargs tyCon = do
82− ks <- mapM infer ts
83− tyCon ~~ foldr FunKind Star kargs
84− forM_ ks $ \k -> k ~~ Star
85− return tyCon
86−
87−starIfUnknown :: Kind -> Kind
88−starIfUnknown (KUnknown _) = Star
89−starIfUnknown (FunKind k1 k2) = FunKind (starIfUnknown k1) (starIfUnknown k2)
90−starIfUnknown k = k
91−
92−infer :: Type -> Subst Kind
93−infer (Array t) = do
94− k <- infer t
95− k ~~ Star
96− return Star
97−infer (Object row) = do
98− k <- inferRow row
99− k ~~ Row
100− return Star
101−infer (Function args ret) = do
102− ks <- mapM infer args
103− k <- infer ret
104− k ~~ Star
105− forM ks (~~ Star)
106− return Star
107−infer (TypeVar v) = do
108− moduleName <- substCurrentModule <$> ask
109− lookupTypeVariable moduleName (Qualified Nothing (ProperName v))
110−infer (TypeConstructor v) = do
111− env <- liftCheck getEnv
112− moduleName <- substCurrentModule `fmap` ask
113− case M.lookup (qualify moduleName v) (types env) of
114− Nothing -> throwError $ "Unknown type constructor '" ++ show v ++ "'"
115− Just (kind, _) -> return kind
116−infer (TypeApp t1 t2) = do
117− k0 <- fresh
118− k1 <- infer t1
119− k2 <- infer t2
120− k1 ~~ FunKind k2 k0
121− return k0
122−infer (ForAll ident ty) = do
123− k <- fresh
124− moduleName <- substCurrentModule <$> ask
125− bindLocalTypeVariables moduleName [(ProperName ident, k)] $ infer ty
126−infer _ = return Star
127−
128−inferRow :: Row -> Subst Kind
129−inferRow (RowVar v) = do
130− moduleName <- substCurrentModule <$> ask
131− lookupTypeVariable moduleName (Qualified Nothing (ProperName v))
132−inferRow REmpty = return Row
133−inferRow (RCons _ ty row) = do
134− k1 <- infer ty
135− k2 <- inferRow row
136− k1 ~~ Star
137− k2 ~~ Row
138− return Row
139−inferRow _ = error "Invalid row in inferRow"
src/Language/PureScript/TypeChecker/Monad.hsdeleted−208
@@ -1,208 +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.Names
23−import Language.PureScript.Unknown
24−
25−import Data.Data
26−import Data.Maybe
27−import Data.Monoid
28−import Control.Applicative
29−import Control.Monad.State
30−import Control.Monad.Error
31−import Control.Monad.Reader
32−
33−import qualified Data.Map as M
34−
35−data NameKind
36− = Value
37− | Extern
38− | Alias ModuleName Ident
39− | LocalVariable deriving Show
40−
41−data TypeDeclarationKind
42− = Data
43− | ExternData
44− | TypeSynonym
45− | DataAlias ModuleName ProperName
46− | LocalTypeVariable deriving Show
47−
48−data Environment = Environment
49− { names :: M.Map (ModuleName, Ident) (Type, NameKind)
50− , types :: M.Map (ModuleName, ProperName) (Kind, TypeDeclarationKind)
51− , dataConstructors :: M.Map (ModuleName, ProperName) Type
52− , typeSynonyms :: M.Map (ModuleName, ProperName) ([String], Type)
53− , members :: M.Map (ModuleName, Ident) String
54− } deriving (Show)
55−
56−emptyEnvironment :: Environment
57−emptyEnvironment = Environment M.empty M.empty M.empty M.empty M.empty
58−
59−bindNames :: (MonadState CheckState m) => M.Map (ModuleName, Ident) (Type, NameKind) -> m a -> m a
60−bindNames newNames action = do
61− orig <- get
62− modify $ \st -> st { checkEnv = (checkEnv st) { names = newNames `M.union` (names . checkEnv $ st) } }
63− a <- action
64− modify $ \st -> st { checkEnv = (checkEnv st) { names = names . checkEnv $ orig } }
65− return a
66−
67−bindTypes :: (MonadState CheckState m) => M.Map (ModuleName, ProperName) (Kind, TypeDeclarationKind) -> m a -> m a
68−bindTypes newNames action = do
69− orig <- get
70− modify $ \st -> st { checkEnv = (checkEnv st) { types = newNames `M.union` (types . checkEnv $ st) } }
71− a <- action
72− modify $ \st -> st { checkEnv = (checkEnv st) { types = types . checkEnv $ orig } }
73− return a
74−
75−bindLocalVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(Ident, Type)] -> m a -> m a
76−bindLocalVariables moduleName bindings action =
77− bindNames (M.fromList $ flip map bindings $ \(name, ty) -> ((moduleName, name), (ty, LocalVariable))) action
78−
79−bindLocalTypeVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(ProperName, Kind)] -> m a -> m a
80−bindLocalTypeVariables moduleName bindings action =
81− bindTypes (M.fromList $ flip map bindings $ \(name, k) -> ((moduleName, name), (k, LocalTypeVariable))) action
82−
83−lookupVariable :: (Functor m, MonadState CheckState m, MonadError String m) => ModuleName -> Qualified Ident -> m Type
84−lookupVariable currentModule (Qualified moduleName var) = do
85− env <- getEnv
86− case M.lookup (fromMaybe currentModule moduleName, var) (names env) of
87− Nothing -> throwError $ show var ++ " is undefined"
88− Just (ty, _) -> return ty
89−
90−lookupTypeVariable :: (Functor m, MonadState CheckState m, MonadError String m) => ModuleName -> Qualified ProperName -> m Kind
91−lookupTypeVariable currentModule (Qualified moduleName name) = do
92− env <- getEnv
93− case M.lookup (fromMaybe currentModule moduleName, name) (types env) of
94− Nothing -> throwError $ "Type variable " ++ show name ++ " is undefined"
95− Just (k, _) -> return k
96−
97−data AnyUnifiable where
98− AnyUnifiable :: forall t. (Unifiable t) => t -> AnyUnifiable
99−
100−data CheckState = CheckState { checkEnv :: Environment
101− , checkNextVar :: Int
102− }
103−
104−newtype Check a = Check { unCheck :: StateT CheckState (Either String) a }
105− deriving (Functor, Monad, Applicative, MonadPlus, MonadState CheckState, MonadError String)
106−
107−getEnv :: (Functor m, MonadState CheckState m) => m Environment
108−getEnv = checkEnv <$> get
109−
110−putEnv :: (MonadState CheckState m) => Environment -> m ()
111−putEnv env = modify (\s -> s { checkEnv = env })
112−
113−modifyEnv :: (MonadState CheckState m) => (Environment -> Environment) -> m ()
114−modifyEnv f = modify (\s -> s { checkEnv = f (checkEnv s) })
115−
116−runCheck :: Check a -> Either String (a, Environment)
117−runCheck c = do
118− (a, s) <- flip runStateT (CheckState emptyEnvironment 0) $ unCheck c
119− return (a, checkEnv s)
120−
121−guardWith :: (MonadError e m) => e -> Bool -> m ()
122−guardWith _ True = return ()
123−guardWith e False = throwError e
124−
125−rethrow :: (MonadError e m) => (e -> e) -> m a -> m a
126−rethrow f = flip catchError $ \e -> throwError (f e)
127−
128−newtype Substitution = Substitution { runSubstitution :: forall t. (Unifiable t) => Unknown t -> t }
129−
130−instance Monoid Substitution where
131− mempty = Substitution unknown
132− s1 `mappend` s2 = Substitution $ \u -> apply s1 (apply s2 (unknown u))
133−
134−data SubstState = SubstState { substSubst :: Substitution
135− , substFutureEscapeChecks :: [AnyUnifiable] }
136−
137−newtype SubstContext = SubstContext { substCurrentModule :: ModuleName } deriving (Show)
138−
139−newtype Subst a = Subst { unSubst :: ReaderT SubstContext (StateT SubstState Check) a }
140− deriving (Functor, Monad, Applicative, MonadPlus, MonadReader SubstContext)
141−
142−instance MonadState CheckState Subst where
143− get = Subst . lift . lift $ get
144− put = Subst . lift . lift . put
145−
146−deriving instance MonadError String Subst
147−
148−liftCheck :: Check a -> Subst a
149−liftCheck = Subst . lift . lift
150−
151−runSubst :: (Unifiable a) => SubstContext -> Subst a -> Check (a, Substitution, [AnyUnifiable])
152−runSubst context subst = do
153− (a, s) <- flip runStateT (SubstState mempty []) . flip runReaderT context . unSubst $ subst
154− return (apply (substSubst s) a, substSubst s, substFutureEscapeChecks s)
155−
156−substituteWith :: (Typeable t) => (Unknown t -> t) -> Substitution
157−substituteWith f = Substitution $ \u -> fromMaybe (unknown u) $ do
158− u1 <- cast u
159− cast (f u1)
160−
161−substituteOne :: (Unifiable t) => Unknown t -> t -> Substitution
162−substituteOne u t = substituteWith $ \u1 ->
163− case u1 of
164− u2 | u2 == u -> t
165− | otherwise -> unknown u2
166−
167−replace :: (Unifiable t) => Unknown t -> t -> Subst ()
168−replace u t' = do
169− sub <- substSubst <$> Subst get
170− let t = apply sub t'
171− occursCheck u t
172− let current = apply sub $ unknown u
173− case isUnknown current of
174− Just u1 | u1 == u -> return ()
175− _ -> current ~~ t
176− Subst . modify $ \s -> s { substSubst = substituteOne u t <> substSubst s }
177−
178−class (Typeable t, Data t, Show t) => Unifiable t where
179− unknown :: Unknown t -> t
180− (~~) :: t -> t -> Subst ()
181− isUnknown :: t -> Maybe (Unknown t)
182− apply :: Substitution -> t -> t
183− unknowns :: t -> [Int]
184−
185−instance (Unifiable a) => Unifiable [a] where
186− unknown _ = error "not supported"
187− (~~) = zipWithM_ (~~)
188− isUnknown _ = error "not supported"
189− apply s = map (apply s)
190− unknowns = concatMap unknowns
191−
192−occursCheck :: (Unifiable t) => Unknown s -> t -> Subst ()
193−occursCheck (Unknown u) t =
194− case isUnknown t of
195− Nothing -> guardWith "Occurs check fails" (u `notElem` unknowns t)
196− _ -> return ()
197−
198−fresh' :: Subst Int
199−fresh' = do
200− n <- checkNextVar <$> get
201− modify $ \s -> s { checkNextVar = succ (checkNextVar s) }
202− return n
203−
204−fresh :: (Unifiable t) => Subst t
205−fresh = unknown . Unknown <$> fresh'
206−
207−escapeCheckLater :: (Unifiable t) => t -> Subst ()
208−escapeCheckLater t = Subst . modify $ \s -> s { substFutureEscapeChecks = AnyUnifiable t : substFutureEscapeChecks s }
src/Language/PureScript/TypeChecker/Synonyms.hsdeleted−48
@@ -1,48 +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−
23−import Data.Maybe (fromMaybe)
24−import Data.Data
25−import Data.Generics
26−import Data.Generics.Extras
27−import Control.Monad.Writer
28−import Control.Monad.Error
29−
30−buildTypeSubstitution :: ModuleName -> Qualified ProperName -> Int -> Type -> Either String (Maybe Type)
31−buildTypeSubstitution moduleName name n = go n []
32− where
33− go :: Int -> [Type] -> Type -> Either String (Maybe Type)
34− go 0 args (TypeConstructor ctor) | qualify moduleName name == qualify moduleName ctor = return (Just $ SaturatedTypeSynonym ctor args)
35− go m _ (TypeConstructor ctor) | m > 0 && name == ctor = throwError $ "Partially applied type synonym " ++ show name
36− go m args (TypeApp f arg) = go (m - 1) (arg:args) f
37− go _ _ _ = return Nothing
38−
39−saturateTypeSynonym :: (Data d) => ModuleName -> Qualified ProperName -> Int -> d -> Either String d
40−saturateTypeSynonym moduleName name n = everywhereM' (mkM replace)
41− where
42− replace t = fmap (fromMaybe t) $ buildTypeSubstitution moduleName name n t
43−
44−saturateAllTypeSynonyms :: (Data d) => ModuleName -> [(Qualified ProperName, Int)] -> d -> Either String d
45−saturateAllTypeSynonyms moduleName syns d = foldM (\result (name, n) -> saturateTypeSynonym moduleName name n result) d syns
46−
47−
48−
src/Language/PureScript/TypeChecker/Types.hsdeleted−782
@@ -1,782 +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−{-# LANGUAGE DeriveDataTypeable, FlexibleContexts #-}
16−
17−module Language.PureScript.TypeChecker.Types (
18− typesOf
19−) where
20−
21−import Data.List
22−import Data.Maybe (fromMaybe)
23−import Data.Either (lefts, rights)
24−import qualified Data.Data as D
25−import Data.Generics
26− (mkT, something, everywhere, everywhereBut, mkQ, extQ)
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−
47−instance Unifiable Type where
48− unknown = TUnknown
49− isUnknown (TUnknown u) = Just u
50− isUnknown _ = Nothing
51− (~~) = unifyTypes
52− apply s (TUnknown u) = runSubstitution s u
53− apply s (SaturatedTypeSynonym name tys) = SaturatedTypeSynonym name $ map (apply s) tys
54− apply s (ForAll idents ty) = ForAll idents $ apply s ty
55− apply s (Array t) = Array (apply s t)
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 _ t = t
60− unknowns (TUnknown (Unknown u)) = [u]
61− unknowns (SaturatedTypeSynonym _ tys) = concatMap unknowns tys
62− unknowns (ForAll _ ty) = unknowns ty
63− unknowns (Array t) = unknowns t
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 _ = []
68−
69−instance Unifiable Row where
70− unknown = RUnknown
71− isUnknown (RUnknown u) = Just u
72− isUnknown _ = Nothing
73− r1 ~~ r2 =
74− let
75− (s1, r1') = rowToList r1
76− (s2, r2') = rowToList r2
77− int = [ (t1, t2) | (name, t1) <- s1, (name', t2) <- s2, name == name' ]
78− sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ]
79− sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ]
80− in do
81− forM_ int (uncurry (~~))
82− unifyRows sd1 r1' sd2 r2'
83− where
84− unifyRows :: [(String, Type)] -> Row -> [(String, Type)] -> Row -> Subst ()
85− unifyRows [] (RUnknown u) sd r = replace u (rowFromList (sd, r))
86− unifyRows sd r [] (RUnknown u) = replace u (rowFromList (sd, r))
87− unifyRows ((name, ty):row) r others u@(RUnknown un) = do
88− occursCheck un ty
89− forM row $ \(_, t) -> occursCheck un t
90− u' <- fresh
91− u ~~ RCons name ty u'
92− unifyRows row r others u'
93− unifyRows [] REmpty [] REmpty = return ()
94− unifyRows [] (RowVar v1) [] (RowVar v2) | v1 == v2 = return ()
95− unifyRows [] (RSkolem s1) [] (RSkolem s2) | s1 == s2 = return ()
96− unifyRows sd3 r3 sd4 r4 = throwError $ "Cannot unify " ++ prettyPrintRow (rowFromList (sd3, r3)) ++ " with " ++ prettyPrintRow (rowFromList (sd4, r4)) ++ "."
97− apply s (RUnknown u) = runSubstitution s u
98− apply s (RCons name ty r) = RCons name (apply s ty) (apply s r)
99− apply _ r = r
100− unknowns (RUnknown (Unknown u)) = [u]
101− unknowns (RCons _ ty r) = unknowns ty ++ unknowns r
102− unknowns _ = []
103−
104−unifyTypes :: Type -> Type -> Subst ()
105−unifyTypes t1 t2 = rethrow (\e -> "Error unifying type " ++ prettyPrintType t1 ++ " with type " ++ prettyPrintType t2 ++ ":\n" ++ e) $ do
106− unifyTypes' t1 t2
107− where
108− unifyTypes' (TUnknown u1) (TUnknown u2) | u1 == u2 = return ()
109− unifyTypes' (TUnknown u) t = replace u t
110− unifyTypes' t (TUnknown u) = replace u t
111− unifyTypes' (SaturatedTypeSynonym name1 args1) (SaturatedTypeSynonym name2 args2)
112− | name1 == name2 = zipWithM_ unifyTypes args1 args2
113− unifyTypes' (SaturatedTypeSynonym name args) ty = do
114− ty1 <- expandTypeSynonym name args
115− ty1 `unifyTypes` ty
116− unifyTypes' ty s@(SaturatedTypeSynonym _ _) = s `unifyTypes` ty
117− unifyTypes' (ForAll ident1 ty1) (ForAll ident2 ty2) = do
118− sk <- skolemize ident1 ty1
119− replaced <- replaceVarWithUnknown ident2 ty2
120− sk `unifyTypes` replaced
121− unifyTypes' (ForAll ident ty1) ty2 = do
122− sk <- skolemize ident ty1
123− sk `unifyTypes` ty2
124− unifyTypes' ty f@(ForAll _ _) = f `unifyTypes` ty
125− unifyTypes' Number Number = return ()
126− unifyTypes' String String = return ()
127− unifyTypes' Boolean Boolean = return ()
128− unifyTypes' (Array s) (Array t) = s `unifyTypes` t
129− unifyTypes' (Object row1) (Object row2) = row1 ~~ row2
130− unifyTypes' (Function args1 ret1) (Function args2 ret2) = do
131− guardWith "Function applied to incorrect number of args" $ length args1 == length args2
132− zipWithM_ unifyTypes args1 args2
133− ret1 `unifyTypes` ret2
134− unifyTypes' (TypeVar v1) (TypeVar v2) | v1 == v2 = return ()
135− unifyTypes' (TypeConstructor c1) (TypeConstructor c2) = do
136− env <- getEnv
137− moduleName <- substCurrentModule `fmap` ask
138− guardWith ("Cannot unify " ++ show c1 ++ " with " ++ show c2 ++ ".") (typeConstructorsAreEqual env moduleName c1 c2)
139− unifyTypes' (TypeApp t3 t4) (TypeApp t5 t6) = do
140− t3 `unifyTypes` t5
141− t4 `unifyTypes` t6
142− unifyTypes' (Skolem s1) (Skolem s2) | s1 == s2 = return ()
143− unifyTypes' t3 t4 = throwError $ "Cannot unify " ++ prettyPrintType t3 ++ " with " ++ prettyPrintType t4 ++ "."
144−
145−typeConstructorsAreEqual :: Environment -> ModuleName -> Qualified ProperName -> Qualified ProperName -> Bool
146−typeConstructorsAreEqual env moduleName c1 c2 =
147− let
148− c1' = qualify moduleName c1
149− c2' = qualify moduleName c2
150− in
151− canonicalize env c1' == canonicalize env c2'
152− where
153− canonicalize :: Environment -> (ModuleName, ProperName) -> (ModuleName, ProperName)
154− canonicalize _ key = case key `M.lookup` types env of
155− Just (_, DataAlias mn' pn') -> (mn', pn')
156− _ -> key
157−
158−typesOf :: ModuleName -> [(Ident, Value)] -> Check [Type]
159−typesOf moduleName vals = do
160− (tys, sub, checks) <- runSubst (SubstContext moduleName) $ do
161− let es = map isTyped vals
162− typed = lefts es
163− untyped = rights es
164− typedDict = map (\(ident, ty, _) -> (ident, ty)) typed
165− untypedNames <- replicateM (length untyped) fresh
166− let untypedDict = zip (map fst untyped) untypedNames
167− dict = M.fromList (map (\(ident, ty) -> ((moduleName, ident), (ty, LocalVariable))) $ typedDict ++ untypedDict)
168− tys <- forM es $ \e -> case e of
169− Left (_, ty, val) -> do
170− kind <- liftCheck $ kindOf moduleName ty
171− guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
172− ty' <- replaceAllTypeSynonyms ty
173− bindNames dict $ check val ty'
174− return ty'
175− Right (ident, val) -> do
176− ty <- bindNames dict $ infer val
177− ty ~~ fromMaybe (error "name not found in dictionary") (lookup ident untypedDict)
178− return ty
179− return tys
180− forM tys $ flip (escapeCheck checks) sub
181− forM tys $ skolemEscapeCheck
182− return $ map (varIfUnknown . desaturateAllTypeSynonyms . setifyAll) tys
183−
184−isTyped :: (Ident, Value) -> Either (Ident, Type, Value) (Ident, Value)
185−isTyped (name, TypedValue value ty) = Left (name, ty, value)
186−isTyped (name, value) = Right (name, value)
187−
188−escapeCheck :: [AnyUnifiable] -> Type -> Substitution -> Check ()
189−escapeCheck checks ty sub =
190− let
191− visibleUnknowns = nub $ unknowns ty
192− in
193− forM_ checks $ \c -> case c of
194− AnyUnifiable t -> do
195− let unsolvedUnknowns = nub . unknowns $ apply sub t
196− guardWith "Escape check fails" $ null $ unsolvedUnknowns \\ visibleUnknowns
197−
198−skolemEscapeCheck :: Type -> Check ()
199−skolemEscapeCheck ty =
200− case something (extQ (mkQ Nothing findSkolems) findRSkolems) ty of
201− Nothing -> return ()
202− Just _ -> throwError "Skolem variables cannot escape. Consider adding a type signature."
203− where
204− findSkolems (Skolem _) = return ()
205− findSkolems _ = mzero
206− findRSkolems (RSkolem _) = return ()
207− findRSkolems _ = mzero
208−
209−setify :: Row -> Row
210−setify = rowFromList . first (M.toList . M.fromList) . rowToList
211−
212−setifyAll :: (D.Data d) => d -> d
213−setifyAll = everywhere (mkT setify)
214−
215−varIfUnknown :: Type -> Type
216−varIfUnknown ty =
217− let unks = nub $ unknowns ty
218− toName = (:) 't' . show
219− ty' = everywhere (mkT rowToVar) . everywhere (mkT typeToVar) $ ty
220− typeToVar :: Type -> Type
221− typeToVar (TUnknown (Unknown u)) = TypeVar (toName u)
222− typeToVar t = t
223− rowToVar :: Row -> Row
224− rowToVar (RUnknown (Unknown u)) = RowVar (toName u)
225− rowToVar t = t
226− in mkForAll (sort . map toName $ unks) ty'
227−
228−replaceAllTypeVars :: (D.Data d) => [(String, Type)] -> d -> d
229−replaceAllTypeVars = foldl' (\f (name, ty) -> replaceTypeVars name ty . f) id
230−
231−replaceTypeVars :: (D.Data d) => String -> Type -> d -> d
232−replaceTypeVars name t = everywhereBut (mkQ False isShadowed) (mkT replaceTypeVar)
233− where
234− replaceTypeVar (TypeVar v) | v == name = t
235− replaceTypeVar other = other
236− isShadowed (ForAll v _) | v == name = True
237− isShadowed _ = False
238−
239−replaceRowVars :: (D.Data d) => String -> Row -> d -> d
240−replaceRowVars name r = everywhere (mkT replaceRowVar)
241− where
242− replaceRowVar (RowVar v) | v == name = r
243− replaceRowVar other = other
244−
245−replaceAllVarsWithUnknowns :: Type -> Subst Type
246−replaceAllVarsWithUnknowns (ForAll ident ty) = replaceVarWithUnknown ident ty >>= replaceAllVarsWithUnknowns
247−replaceAllVarsWithUnknowns ty = return ty
248−
249−replaceVarWithUnknown :: String -> Type -> Subst Type
250−replaceVarWithUnknown ident ty = do
251− tu <- fresh
252− ru <- fresh
253− return $ replaceRowVars ident ru . replaceTypeVars ident tu $ ty
254−
255−replaceAllTypeSynonyms :: (Functor m, MonadState CheckState m, MonadReader SubstContext m, MonadError String m) => (D.Data d) => d -> m d
256−replaceAllTypeSynonyms d = do
257− env <- getEnv
258− moduleName <- substCurrentModule <$> ask
259− let syns = map (\((path, name), (args, _)) -> (Qualified (Just path) name, length args)) . M.toList $ typeSynonyms env
260− either throwError return $ saturateAllTypeSynonyms moduleName syns d
261−
262−desaturateAllTypeSynonyms :: (D.Data d) => d -> d
263−desaturateAllTypeSynonyms = everywhere (mkT replaceSaturatedTypeSynonym)
264− where
265− replaceSaturatedTypeSynonym (SaturatedTypeSynonym name args) = foldl TypeApp (TypeConstructor name) args
266− replaceSaturatedTypeSynonym t = t
267−
268−expandTypeSynonym :: Qualified ProperName -> [Type] -> Subst Type
269−expandTypeSynonym name args = do
270− env <- getEnv
271− moduleName <- substCurrentModule `fmap` ask
272− case M.lookup (qualify moduleName name) (typeSynonyms env) of
273− Just (synArgs, body) -> return $ replaceAllTypeVars (zip synArgs args) body
274− Nothing -> error "Type synonym was not defined"
275−
276−ensureNoDuplicateProperties :: (MonadError String m) => [(String, Value)] -> m ()
277−ensureNoDuplicateProperties ps = guardWith "Duplicate property names" $ length (nub . map fst $ ps) == length ps
278−
279−infer :: Value -> Subst Type
280−infer val = rethrow (\e -> "Error inferring type of term " ++ prettyPrintValue val ++ ":\n" ++ e) $ do
281− ty <- infer' val
282− escapeCheckLater ty
283− return ty
284−
285−infer' :: Value -> Subst Type
286−infer' (NumericLiteral _) = return Number
287−infer' (StringLiteral _) = return String
288−infer' (BooleanLiteral _) = return Boolean
289−infer' (ArrayLiteral vals) = do
290− ts <- mapM (infer) vals
291− els <- fresh
292− forM_ ts $ \t -> els ~~ Array t
293− return els
294−infer' (Unary op val) = do
295− t <- infer val
296− inferUnary op t
297−infer' (Binary op left right) = do
298− t1 <- infer left
299− t2 <- infer right
300− inferBinary op t1 t2
301−infer' (ObjectLiteral ps) = do
302− ensureNoDuplicateProperties ps
303− ts <- mapM (infer . snd) ps
304− let fields = zipWith (\(name, _) t -> (name, t)) ps ts
305− return $ Object $ rowFromList (fields, REmpty)
306−infer' (ObjectUpdate o ps) = do
307− ensureNoDuplicateProperties ps
308− row <- fresh
309− newTys <- zipWith (\(name, _) t -> (name, t)) ps <$> mapM (infer . snd) ps
310− oldTys <- zip (map fst ps) <$> replicateM (length ps) fresh
311− check o $ Object $ rowFromList (oldTys, row)
312− return $ Object $ rowFromList (newTys, row)
313−infer' (Indexer index val) = do
314− el <- fresh
315− check index Number
316− check val (Array el)
317− return el
318−infer' (Accessor prop val) = do
319− obj <- infer val
320− propTy <- inferProperty obj prop
321− case propTy of
322− Nothing -> do
323− field <- fresh
324− rest <- fresh
325− obj `subsumes` Object (RCons prop field rest)
326− return field
327− Just ty -> return ty
328−infer' (Abs args ret) = do
329− ts <- replicateM (length args) fresh
330− moduleName <- substCurrentModule <$> ask
331− bindLocalVariables moduleName (zip args ts) $ do
332− body <- infer' ret
333− return $ Function ts body
334−infer' app@(App _ _) = do
335− let (f, argss) = unfoldApplication app
336− ft <- infer f
337− ret <- fresh
338− checkFunctionApplications ft argss ret
339− return ret
340−infer' (Var var) = do
341− moduleName <- substCurrentModule <$> ask
342− ty <- lookupVariable moduleName var
343− replaceAllTypeSynonyms ty
344−infer' (Block ss) = do
345− ret <- fresh
346− (allCodePathsReturn, _) <- checkBlock M.empty ret ss
347− guardWith "Block is missing a return statement" allCodePathsReturn
348− return ret
349−infer' (Constructor c) = do
350− env <- getEnv
351− moduleName <- substCurrentModule `fmap` ask
352− case M.lookup (qualify moduleName c) (dataConstructors env) of
353− Nothing -> throwError $ "Constructor " ++ show c ++ " is undefined"
354− Just ty -> replaceAllTypeSynonyms ty
355−infer' (Case vals binders) = do
356− ts <- mapM infer vals
357− ret <- fresh
358− checkBinders ts ret binders
359− return ret
360−infer' (IfThenElse cond th el) = do
361− check cond Boolean
362− t2 <- infer th
363− t3 <- infer el
364− t2 ~~ t3
365− return t2
366−infer' (TypedValue val ty) = do
367− moduleName <- substCurrentModule <$> ask
368− kind <- liftCheck $ kindOf moduleName ty
369− guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
370− ty' <- replaceAllTypeSynonyms ty
371− check val ty'
372− return ty'
373−infer' _ = error "Invalid argument to infer"
374−
375−inferProperty :: Type -> String -> Subst (Maybe Type)
376−inferProperty (Object row) prop = do
377− let (props, _) = rowToList row
378− return $ lookup prop props
379−inferProperty (SaturatedTypeSynonym name args) prop = do
380− replaced <- expandTypeSynonym name args
381− inferProperty replaced prop
382−inferProperty (ForAll ident ty) prop = do
383− replaced <- replaceVarWithUnknown ident ty
384− inferProperty replaced prop
385−inferProperty _ _ = return Nothing
386−
387−inferUnary :: UnaryOperator -> Type -> Subst Type
388−inferUnary op val =
389− case fromMaybe (error "Invalid operator") $ lookup op unaryOps of
390− (valTy, resTy) -> do
391− val ~~ valTy
392− return resTy
393−
394−checkUnary :: UnaryOperator -> Value -> Type -> Subst ()
395−checkUnary op val res =
396− case fromMaybe (error "Invalid operator") $ lookup op unaryOps of
397− (valTy, resTy) -> do
398− res ~~ resTy
399− check val valTy
400−
401−unaryOps :: [(UnaryOperator, (Type, Type))]
402−unaryOps = [ (Negate, (Number, Number))
403− , (Not, (Boolean, Boolean))
404− , (BitwiseNot, (Number, Number))
405− ]
406−
407−inferBinary :: BinaryOperator -> Type -> Type -> Subst Type
408−inferBinary op left right | isEqualityTest op = do
409− left ~~ right
410− return Boolean
411−inferBinary op left right =
412− case fromMaybe (error "Invalid operator") $ lookup op binaryOps of
413− (valTy, resTy) -> do
414− left ~~ valTy
415− right ~~ valTy
416− return resTy
417−
418−checkBinary :: BinaryOperator -> Value -> Value -> Type -> Subst ()
419−checkBinary op left right res | isEqualityTest op = do
420− res ~~ Boolean
421− t1 <- infer left
422− t2 <- infer right
423− t1 ~~ t2
424−checkBinary op left right res =
425− case fromMaybe (error "Invalid operator") $ lookup op binaryOps of
426− (valTy, resTy) -> do
427− res ~~ resTy
428− check left valTy
429− check right valTy
430−
431−isEqualityTest :: BinaryOperator -> Bool
432−isEqualityTest EqualTo = True
433−isEqualityTest NotEqualTo = True
434−isEqualityTest _ = False
435−
436−binaryOps :: [(BinaryOperator, (Type, Type))]
437−binaryOps = [ (Add, (Number, Number))
438− , (Subtract, (Number, Number))
439− , (Multiply, (Number, Number))
440− , (Divide, (Number, Number))
441− , (Modulus, (Number, Number))
442− , (BitwiseAnd, (Number, Number))
443− , (BitwiseOr, (Number, Number))
444− , (BitwiseXor, (Number, Number))
445− , (ShiftRight, (Number, Number))
446− , (ZeroFillShiftRight, (Number, Number))
447− , (And, (Boolean, Boolean))
448− , (Or, (Boolean, Boolean))
449− , (Concat, (String, String))
450− , (Modulus, (Number, Number))
451− , (LessThan, (Number, Boolean))
452− , (LessThanOrEqualTo, (Number, Boolean))
453− , (GreaterThan, (Number, Boolean))
454− , (GreaterThanOrEqualTo, (Number, Boolean))
455− ]
456−
457−inferBinder :: Type -> Binder -> Subst (M.Map Ident Type)
458−inferBinder _ NullBinder = return M.empty
459−inferBinder val (StringBinder _) = val ~~ String >> return M.empty
460−inferBinder val (NumberBinder _) = val ~~ Number >> return M.empty
461−inferBinder val (BooleanBinder _) = val ~~ Boolean >> return M.empty
462−inferBinder val (VarBinder name) = return $ M.singleton name val
463−inferBinder val (NullaryBinder ctor) = do
464− env <- getEnv
465− moduleName <- substCurrentModule <$> ask
466− case M.lookup (qualify moduleName ctor) (dataConstructors env) of
467− Just ty -> do
468− ty `subsumes` val
469− return M.empty
470− _ -> throwError $ "Constructor " ++ show ctor ++ " is not defined"
471−inferBinder val (UnaryBinder ctor binder) = do
472− env <- getEnv
473− moduleName <- substCurrentModule <$> ask
474− case M.lookup (qualify moduleName ctor) (dataConstructors env) of
475− Just ty -> do
476− fn <- replaceAllVarsWithUnknowns ty
477− case fn of
478− Function [obj] ret -> do
479− val `subsumes` ret
480− inferBinder obj binder
481− _ -> throwError $ "Constructor " ++ show ctor ++ " is not a unary constructor"
482− _ -> throwError $ "Constructor " ++ show ctor ++ " is not defined"
483−inferBinder val (ObjectBinder props) = do
484− row <- fresh
485− rest <- fresh
486− m1 <- inferRowProperties row rest props
487− val ~~ Object row
488− return m1
489− where
490− inferRowProperties :: Row -> Row -> [(String, Binder)] -> Subst (M.Map Ident Type)
491− inferRowProperties nrow row [] = nrow ~~ row >> return M.empty
492− inferRowProperties nrow row ((name, binder):binders) = do
493− propTy <- fresh
494− m1 <- inferBinder propTy binder
495− m2 <- inferRowProperties nrow (RCons name propTy row) binders
496− return $ m1 `M.union` m2
497−inferBinder val (ArrayBinder binders) = do
498− el <- fresh
499− m1 <- M.unions <$> mapM (inferBinder el) binders
500− val ~~ Array el
501− return m1
502−inferBinder val (ConsBinder headBinder tailBinder) = do
503− el <- fresh
504− m1 <- inferBinder el headBinder
505− m2 <- inferBinder val tailBinder
506− val ~~ Array el
507− return $ m1 `M.union` m2
508−inferBinder val (NamedBinder name binder) = do
509− m <- inferBinder val binder
510− return $ M.insert name val m
511−
512−checkBinders :: [Type] -> Type -> [([Binder], Maybe Guard, Value)] -> Subst ()
513−checkBinders _ _ [] = return ()
514−checkBinders nvals ret ((binders, grd, val):bs) = do
515− moduleName <- substCurrentModule <$> ask
516− m1 <- M.unions <$> zipWithM inferBinder nvals binders
517− bindLocalVariables moduleName (M.toList m1) $ do
518− check val ret
519− case grd of
520− Nothing -> return ()
521− Just g -> check g Boolean
522− checkBinders nvals ret bs
523−
524−assignVariable :: Ident -> Subst ()
525−assignVariable name = do
526− env <- checkEnv <$> get
527− moduleName <- substCurrentModule <$> ask
528− case M.lookup (moduleName, name) (names env) of
529− Just (_, LocalVariable) -> throwError $ "Variable with name " ++ show name ++ " already exists."
530− _ -> return ()
531−
532−checkStatement :: M.Map Ident Type -> Type -> Statement -> Subst (Bool, M.Map Ident Type)
533−checkStatement mass _ (VariableIntroduction name val) = do
534− assignVariable name
535− t <- infer val
536− return (False, M.insert name t mass)
537−checkStatement mass _ (Assignment ident val) = do
538− t <- infer val
539− case M.lookup ident mass of
540− Nothing -> throwError $ "No local variable with name " ++ show ident
541− Just ty -> do t ~~ ty
542− return (False, mass)
543−checkStatement mass ret (While val inner) = do
544− check val Boolean
545− (allCodePathsReturn, _) <- checkBlock mass ret inner
546− return (allCodePathsReturn, mass)
547−checkStatement mass ret (If ifst) = do
548− allCodePathsReturn <- checkIfStatement mass ret ifst
549− return (allCodePathsReturn, mass)
550−checkStatement mass ret (For ident start end inner) = do
551− moduleName <- substCurrentModule <$> ask
552− assignVariable ident
553− check start Number
554− check end Number
555− (allCodePathsReturn, _) <- bindLocalVariables moduleName [(ident, Number)] $ checkBlock mass ret inner
556− return (allCodePathsReturn, mass)
557−checkStatement mass ret (ForEach ident vals inner) = do
558− moduleName <- substCurrentModule <$> ask
559− assignVariable ident
560− val <- fresh
561− check vals (Array val)
562− (allCodePathsReturn, _) <- bindLocalVariables moduleName [(ident, val)] $ checkBlock mass ret inner
563− guardWith "Cannot return from within a foreach block" $ not allCodePathsReturn
564− return (False, mass)
565−checkStatement mass _ (ValueStatement val) = do
566− check val unit
567− return (False, mass)
568−checkStatement mass ret (Return val) = do
569− check val ret
570− return (True, mass)
571−
572−checkIfStatement :: M.Map Ident Type -> Type -> IfStatement -> Subst Bool
573−checkIfStatement mass ret (IfStatement val thens Nothing) = do
574− check val Boolean
575− _ <- checkBlock mass ret thens
576− return False
577−checkIfStatement mass ret (IfStatement val thens (Just elses)) = do
578− check val Boolean
579− (allCodePathsReturn1, _) <- checkBlock mass ret thens
580− allCodePathsReturn2 <- checkElseStatement mass ret elses
581− return $ allCodePathsReturn1 && allCodePathsReturn2
582−
583−checkElseStatement :: M.Map Ident Type -> Type -> ElseStatement -> Subst Bool
584−checkElseStatement mass ret (Else elses) = fst <$> checkBlock mass ret elses
585−checkElseStatement mass ret (ElseIf ifst) = checkIfStatement mass ret ifst
586−
587−checkBlock :: M.Map Ident Type -> Type -> [Statement] -> Subst (Bool, M.Map Ident Type)
588−checkBlock mass _ [] = return (False, mass)
589−checkBlock mass ret (s:ss) = do
590− moduleName <- substCurrentModule <$> ask
591− (b1, mass1) <- checkStatement mass ret s
592− bindLocalVariables moduleName (M.toList mass1) $ case (b1, ss) of
593− (True, []) -> return (True, mass1)
594− (True, _) -> throwError "Unreachable code"
595− (False, ss') -> checkBlock mass1 ret ss'
596−
597−skolemize :: String -> Type -> Subst Type
598−skolemize ident ty = do
599− tsk <- Skolem <$> fresh'
600− rsk <- RSkolem <$> fresh'
601− return $ replaceRowVars ident rsk $ replaceTypeVars ident tsk ty
602−
603−check :: Value -> Type -> Subst ()
604−check val ty = rethrow errorMessage $ check' val ty
605− where
606− errorMessage msg =
607− "Error checking type of term " ++
608− prettyPrintValue val ++
609− " against type " ++
610− prettyPrintType ty ++
611− ":\n" ++
612− msg
613−
614−check' :: Value -> Type -> Subst ()
615−check' val (ForAll idents ty) = do
616− sk <- skolemize idents ty
617− check val sk
618−check' val u@(TUnknown _) = do
619− ty <- infer val
620− -- Don't unify an unknown with an inferred polytype
621− ty' <- replaceAllVarsWithUnknowns ty
622− ty' ~~ u
623−check' (NumericLiteral _) Number = return ()
624−check' (StringLiteral _) String = return ()
625−check' (BooleanLiteral _) Boolean = return ()
626−check' (Unary op val) ty = checkUnary op val ty
627−check' (Binary op left right) ty = checkBinary op left right ty
628−check' (ArrayLiteral vals) (Array ty) = forM_ vals (\val -> check val ty)
629−check' (Indexer index vals) ty = check index Number >> check vals (Array ty)
630−check' (Abs args ret) (Function argTys retTy) = do
631− moduleName <- substCurrentModule <$> ask
632− guardWith "Incorrect number of function arguments" (length args == length argTys)
633− bindLocalVariables moduleName (zip args argTys) $ check ret retTy
634−check' app@(App _ _) ret = do
635− let (f, argss) = unfoldApplication app
636− ft <- infer f
637− checkFunctionApplications ft argss ret
638−check' (Var var) ty = do
639− moduleName <- substCurrentModule <$> ask
640− ty1 <- lookupVariable moduleName var
641− repl <- replaceAllTypeSynonyms ty1
642− repl `subsumes` ty
643−check' (TypedValue val ty1) ty2 = do
644− moduleName <- substCurrentModule <$> ask
645− kind <- liftCheck $ kindOf moduleName ty1
646− guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
647− ty1 `subsumes` ty2
648− check val ty1
649−check' (Case vals binders) ret = do
650− ts <- mapM infer vals
651− checkBinders ts ret binders
652−check' (IfThenElse cond th el) ty = do
653− check cond Boolean
654− check th ty
655− check el ty
656−check' (ObjectLiteral ps) (Object row) = do
657− ensureNoDuplicateProperties ps
658− checkProperties ps row False
659−check' (ObjectUpdate obj ps) (Object row) = do
660− ensureNoDuplicateProperties ps
661− us <- zip (map fst ps) <$> replicateM (length ps) fresh
662− let (propsToCheck, rest) = rowToList row
663− propsToRemove = map fst ps
664− remainingProps = filter (\(p, _) -> p `notElem` propsToRemove) propsToCheck
665− check obj (Object (rowFromList (us ++ remainingProps, rest)))
666− checkProperties ps row True
667−check' (Accessor prop val) ty = do
668− rest <- fresh
669− check val (Object (RCons prop ty rest))
670−check' (Block ss) ret = do
671− (allCodePathsReturn, _) <- checkBlock M.empty ret ss
672− guardWith "Block is missing a return statement" allCodePathsReturn
673−check' (Constructor c) ty = do
674− env <- getEnv
675− moduleName <- substCurrentModule <$> ask
676− case M.lookup (qualify moduleName c) (dataConstructors env) of
677− Nothing -> throwError $ "Constructor " ++ show c ++ " is undefined"
678− Just ty1 -> do
679− repl <- replaceAllTypeSynonyms ty1
680− repl `subsumes` ty
681−check' val (SaturatedTypeSynonym name args) = do
682− ty <- expandTypeSynonym name args
683− check val ty
684−check' val ty = throwError $ prettyPrintValue val ++ " does not have type " ++ prettyPrintType ty
685−
686−checkProperties :: [(String, Value)] -> Row -> Bool -> Subst ()
687−checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where
688− go [] [] REmpty = return ()
689− go [] [] u@(RUnknown _) = u ~~ REmpty
690− go [] [] (RSkolem _) | lax = return ()
691− go [] ((p, _): _) _ | lax = return ()
692− | otherwise = throwError $ prettyPrintValue (ObjectLiteral ps) ++ " does not have property " ++ p
693− go ((p,_):_) [] REmpty = throwError $ "Property " ++ p ++ " is not present in closed object type " ++ prettyPrintRow row
694− go ((p,v):ps') [] u@(RUnknown _) = do
695− ty <- infer v
696− rest <- fresh
697− u ~~ RCons p ty rest
698− go ps' [] rest
699− go ((p,v):ps') ts r =
700− case lookup p ts of
701− Nothing -> do
702− ty <- infer v
703− rest <- fresh
704− r ~~ RCons p ty rest
705− go ps' ts rest
706− Just ty -> do
707− check v ty
708− go ps' (delete (p, ty) ts) r
709− go _ _ _ = throwError $ prettyPrintValue (ObjectLiteral ps) ++ " does not have type " ++ prettyPrintType (Object row)
710−
711−unfoldApplication :: Value -> (Value, [[Value]])
712−unfoldApplication = go []
713− where
714− go argss (App f args) = go (args:argss) f
715− go argss f = (f, argss)
716−
717−checkFunctionApplications :: Type -> [[Value]] -> Type -> Subst ()
718−checkFunctionApplications _ [] _ = error "Nullary function application"
719−checkFunctionApplications fnTy [args] ret = checkFunctionApplication fnTy args ret
720−checkFunctionApplications fnTy (args:argss) ret = do
721− argTys <- mapM (infer) args
722− f <- inferFunctionApplication fnTy argTys
723− checkFunctionApplications f argss ret
724−
725−checkFunctionApplication :: Type -> [Value] -> Type -> Subst ()
726−checkFunctionApplication fnTy args ret = rethrow errorMessage $ checkFunctionApplication' fnTy args ret
727− where
728− errorMessage msg = "Error applying function of type "
729− ++ prettyPrintType fnTy
730− ++ " to arguments " ++ intercalate ", " (map prettyPrintValue args)
731− ++ ", expecting value of type "
732− ++ prettyPrintType ret ++ ":\n" ++ msg
733−
734−inferFunctionApplication :: Type -> [Type] -> Subst Type
735−inferFunctionApplication (Function argTys retTy) args = do
736− guardWith "Incorrect number of function arguments" (length args == length argTys)
737− zipWithM subsumes args argTys
738− return retTy
739−inferFunctionApplication (ForAll ident ty) args = do
740− replaced <- replaceVarWithUnknown ident ty
741− inferFunctionApplication replaced args
742−inferFunctionApplication u@(TUnknown _) args = do
743−
744− ret <- fresh
745− args' <- mapM replaceAllVarsWithUnknowns args
746− u ~~ Function args' ret
747− return ret
748−inferFunctionApplication (SaturatedTypeSynonym name tyArgs) args = do
749− ty <- expandTypeSynonym name tyArgs
750− inferFunctionApplication ty args
751−inferFunctionApplication fnTy args = throwError $ "Cannot apply function of type "
752− ++ prettyPrintType fnTy
753− ++ " to argument(s) of type(s) " ++ intercalate ", " (map prettyPrintType args)
754−
755−checkFunctionApplication' :: Type -> [Value] -> Type -> Subst ()
756−checkFunctionApplication' (Function argTys retTy) args ret = do
757− guardWith "Incorrect number of function arguments" (length args == length argTys)
758− zipWithM (check) args argTys
759− retTy `subsumes` ret
760−checkFunctionApplication' (ForAll ident ty) args ret = do
761− replaced <- replaceVarWithUnknown ident ty
762− checkFunctionApplication replaced args ret
763−checkFunctionApplication' u@(TUnknown _) args ret = do
764− tyArgs <- mapM (\arg -> infer arg >>= replaceAllVarsWithUnknowns) args
765− u ~~ Function tyArgs ret
766−checkFunctionApplication' (SaturatedTypeSynonym name tyArgs) args ret = do
767− ty <- expandTypeSynonym name tyArgs
768− checkFunctionApplication' ty args ret
769−checkFunctionApplication' fnTy args ret = throwError $ "Applying a function of type "
770− ++ prettyPrintType fnTy
771− ++ " to argument(s) " ++ intercalate ", " (map prettyPrintValue args)
772− ++ " does not yield a value of type " ++ prettyPrintType ret ++ "."
773−
774−subsumes :: Type -> Type -> Subst ()
775−subsumes (ForAll ident ty1) ty2 = do
776− replaced <- replaceVarWithUnknown ident ty1
777− replaced `subsumes` ty2
778−subsumes (Function args1 ret1) (Function args2 ret2) = do
779− zipWithM subsumes args2 args1
780− ret1 `subsumes` ret2
781−subsumes ty1 ty2 = ty1 ~~ ty2
782−
src/Language/PureScript/TypeDeclarations.hsdeleted−35
@@ -1,35 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.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.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 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/Types.hsdeleted−73
@@ -1,73 +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 Language.PureScript.Names
21−import Language.PureScript.Unknown (Unknown(..))
22−
23−data Type
24− = TUnknown (Unknown Type)
25− | Number
26− | String
27− | Boolean
28− | Array Type
29− | Object Row
30− | Function [PolyType] Type
31− | TypeVar String
32− | TypeConstructor (Qualified ProperName)
33− | TypeApp Type Type
34− | SaturatedTypeSynonym (Qualified ProperName) [Type]
35− | ForAll String Type
36− | Skolem Int deriving (Show, Eq, Data, Typeable)
37−
38−type PolyType = Type
39−
40−data Row
41− = RUnknown (Unknown Row)
42− | RowVar String
43− | REmpty
44− | RCons String Type Row
45− | RSkolem Int deriving (Show, Eq, Data, Typeable)
46−
47−rowToList :: Row -> ([(String, Type)], Row)
48−rowToList (RCons name ty row) = let (tys, rest) = rowToList row
49− in ((name, ty):tys, rest)
50−rowToList r = ([], r)
51−
52−rowFromList :: ([(String, Type)], Row) -> Row
53−rowFromList ([], r) = r
54−rowFromList ((name, t):ts, r) = RCons name t (rowFromList (ts, r))
55−
56−isMonoType :: Type -> Bool
57−isMonoType (ForAll _ _) = False
58−isMonoType ty = isPolyType ty
59−
60−isPolyType :: Type -> Bool
61−isPolyType (Array ty) = isMonoType ty
62−isPolyType (Object ps) = all isPolyType (map snd . fst $ rowToList ps)
63−isPolyType (Function args ret) = all isPolyType args && isPolyType ret
64−isPolyType (TypeApp t1 t2) = isMonoType t1 && isMonoType t2
65−isPolyType (SaturatedTypeSynonym _ args) = all isPolyType args
66−isPolyType (ForAll _ ty) = isPolyType ty
67−isPolyType _ = True
68−
69−mkForAll :: [String] -> Type -> Type
70−mkForAll = flip . foldl . flip $ ForAll
71−
72−unit :: Type
73−unit = Object REmpty
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−102
@@ -1,102 +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 deriving (Show, Eq, Data, Typeable)
30−
31−data BinaryOperator
32− = Add
33− | Subtract
34− | Multiply
35− | Divide
36− | Modulus
37− | EqualTo
38− | NotEqualTo
39− | LessThan
40− | LessThanOrEqualTo
41− | GreaterThan
42− | GreaterThanOrEqualTo
43− | And
44− | Or
45− | BitwiseAnd
46− | BitwiseOr
47− | BitwiseXor
48− | ShiftLeft
49− | ShiftRight
50− | ZeroFillShiftRight
51− | Concat deriving (Show, Eq, Data, Typeable)
52−
53−data Value
54− = NumericLiteral (Either Integer Double)
55− | StringLiteral String
56− | BooleanLiteral Bool
57− | Unary UnaryOperator Value
58− | Binary BinaryOperator Value Value
59− | BinaryNoParens (Qualified Ident) Value Value
60− | Parens Value
61− | ArrayLiteral [Value]
62− | Indexer Value Value
63− | ObjectLiteral [(String, Value)]
64− | Accessor String Value
65− | ObjectUpdate Value [(String, Value)]
66− | Abs [Ident] Value
67− | App Value [Value]
68− | Var (Qualified Ident)
69− | IfThenElse Value Value Value
70− | Block [Statement]
71− | Constructor (Qualified ProperName)
72− | Case [Value] [([Binder], Maybe Guard, Value)]
73− | TypedValue Value PolyType deriving (Show, Data, Typeable)
74−
75−data Statement
76− = VariableIntroduction Ident Value
77− | Assignment Ident Value
78− | While Value [Statement]
79− | For Ident Value Value [Statement]
80− | ForEach Ident Value [Statement]
81− | If IfStatement
82− | ValueStatement Value
83− | Return Value deriving (Show, Data, Typeable)
84−
85−data IfStatement = IfStatement Value [Statement] (Maybe ElseStatement) deriving (Show, Data, Typeable)
86−
87−data ElseStatement
88− = Else [Statement]
89− | ElseIf IfStatement deriving (Show, Data, Typeable)
90−
91−data Binder
92− = NullBinder
93− | BooleanBinder Bool
94− | StringBinder String
95− | NumberBinder (Either Integer Double)
96− | VarBinder Ident
97− | NullaryBinder (Qualified ProperName)
98− | UnaryBinder (Qualified ProperName) Binder
99− | ObjectBinder [(String, Binder)]
100− | ArrayBinder [Binder]
101− | ConsBinder Binder Binder
102− | NamedBinder Ident Binder deriving (Show, Data, Typeable)
src/Main.hsdeleted−85
@@ -1,85 +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−
25−readInput :: Maybe [FilePath] -> IO (Either ParseError [P.Module])
26−readInput Nothing = getContents >>= return . P.runIndentParser P.parseModules
27−readInput (Just input) = fmap (fmap concat . sequence) $ forM input $ \inputFile -> do
28− text <- U.readFile inputFile
29− return $ P.runIndentParser P.parseModules text
30−
31−compile :: Maybe [FilePath] -> Maybe FilePath -> Maybe FilePath -> IO ()
32−compile input output externs = do
33− modules <- readInput input
34− case modules of
35− Left err -> do
36− U.print err
37− exitFailure
38− Right ms ->
39− case P.compile ms of
40− Left err -> do
41− U.putStrLn err
42− exitFailure
43− Right (js, exts, _) -> do
44− case output of
45− Just path -> U.writeFile path js
46− Nothing -> U.putStrLn js
47− case externs of
48− Nothing -> return ()
49− Just filePath -> U.writeFile filePath exts
50− exitSuccess
51−
52−useStdIn :: Term Bool
53−useStdIn = value . flag $ (optInfo [ "s", "stdin" ])
54− { optDoc = "Read from standard input" }
55−
56−inputFiles :: Term [FilePath]
57−inputFiles = value $ posAny [] $ posInfo
58− { posDoc = "The input .ps files" }
59−
60−outputFile :: Term (Maybe FilePath)
61−outputFile = value $ opt Nothing $ (optInfo [ "o", "output" ])
62− { optDoc = "The output .js file" }
63−
64−externsFile :: Term (Maybe FilePath)
65−externsFile = value $ opt Nothing $ (optInfo [ "e", "externs" ])
66− { optDoc = "The output .e.ps file" }
67−
68−stdInOrInputFiles :: Term (Maybe [FilePath])
69−stdInOrInputFiles = combine <$> useStdIn <*> inputFiles
70− where
71− combine False input = Just input
72− combine True _ = Nothing
73−
74−term :: Term (IO ())
75−term = compile <$> stdInOrInputFiles <*> outputFile <*> externsFile
76−
77−termInfo :: TermInfo
78−termInfo = defTI
79− { termName = "psc"
80− , version = "1.0"
81− , termDoc = "Compiles PureScript to Javascript"
82− }
83−
84−main :: IO ()
85−main = run (term, termInfo)
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 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