git.iko.soy/rowtype-yoga/purescript-native
on cbf70e7 help sign in
355eb9b
swap
0 ahead, 3963 behind
.gitignore−15
since splitsnapshots
unifiedsplit
@@ -1,23 +1,8 @@
1dist
1dist
2cabal-dev
2cabal-dev
3−.cabal-sandbox
4−cabal.sandbox.config
5*.o
3*.o
6*.hi
4*.hi
7*.chi
5*.chi
8*.chs.h
6*.chs.h
9*.lksh*
7*.lksh*
10.virthualenv
8.virthualenv
11−.psci_modules/
12−.test_modules/
13−bower_components/
14−node_modules
15−tmp/
16−.stack-work/
17−stack.yaml.lock
18−output
19−examples/docs/docs/
20−core-tests/full-core-docs.md
21−.psc-ide-port
22−.vscode/
23−result
.travis.ymlnew file+3
@@ -0,0 +1,3 @@
1+language: haskell
2+notifications:
3+ email: false
CONTRIBUTING.mdnew file+14
@@ -0,0 +1,14 @@
1+Pull requests are encouraged.
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.mddeleted−3
@@ -1,3 +0,0 @@
1−# Changelog for pscpp
2−
3−## Unreleased changes
LICENSE+16−26
@@ -1,30 +1,20 @@
1−Copyright Andy Arvanitis (c) 2018
1+The MIT License (MIT)
2
2
3−All rights reserved.
3+Copyright (c) 2013 Phil Freeman
4
4
5−Redistribution and use in source and binary forms, with or without
5+Permission is hereby granted, free of charge, to any person obtaining a copy of
6+this software and associated documentation files (the "Software"), to deal in
7+the Software without restriction, including without limitation the rights to
8+use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
9+the Software, and to permit persons to whom the Software is furnished to do so,
6−modification, are permitted provided that the following conditions are met:
10+subject to the following conditions:
7
11
8− * Redistributions of source code must retain the above copyright
12+The above copyright notice and this permission notice shall be included in all
9− notice, this list of conditions and the following disclaimer.
13+copies or substantial portions of the Software.
10
14
11− * Redistributions in binary form must reproduce the above
15+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
12− copyright notice, this list of conditions and the following
13− disclaimer in the documentation and/or other materials provided
14− with the distribution.
15−
16− * Neither the name of Author name here nor the names of other
17− contributors may be used to endorse or promote products derived
18− from this software without specific prior written permission.
19−
20−THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21−"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22−LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
16+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
23−A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
17+FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
24−OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
18+COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
25−SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26−LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27−DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28−THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29−(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
19+IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
30−OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
20+CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
README-go.mddeleted−48
@@ -1,48 +0,0 @@
1−
2−### psgo
3−
4−#### Performance
5−
6−* No runtime system beyond some support types and functions
7−* Uses PureScript's normal tail call optimization techniques for generated Go code
8−
9−#### Differences from PureScript:
10−
11−* Foreign imports/exports are Go instead of JavaScript – see [standard library foreign implementations](https://github.com/andyarvanitis/purescript-native-go-ffi)
12−* No Go-specific REPL
13−
14−#### Other notes:
15−
16−* The provided `Any` type is just an alias for `interface{}`
17−* PureScript types are represented in Go with:
18−
19− | PureScript | Go |
20− |------------|----|
21− |`Array` | `[]Any`|
22− |`String` | `string`|
23− |`Number` | `float64`|
24− |`Int` | `int`|
25− |`Char` | `string` (single UTF-8 entity)|
26− |`Boolean` | `bool`|
27− |Records | `map[string]Any`|
28−
29−#### Future ideas:
30−
31−* Nice facilities (modules) for concurrency/parallelism, using goroutines
32−
33−
34−#### Getting Started
35−This assumes you are running macOS (OS X) or a Unix-like system (Linux, *BSD, etc.).
36−
37−1. Choose a working directory wherever you like. Then create a `src` subdirectory under it, which will be where you will place your own PureScript source files.
38−
39−1. Initialize your project with `spago init`, and install any dependencies with `spago install` (please see their instructions if you haven't used it before).
40−
41−1. Add the `backend = "psgo"` option to your `spago.dhall` file. That way `spago` will use the psgo backend when compiling.
42−
43−1. You should now be ready to build a PureScript program:
44− * As stated above, place your source file(s) in the working directory's `src` subdirectory and execute `spago build`.
45−
46− * This will generate the Go source tree for your program and then build an executable binary. The resulting executable will be in your working directory and will be named `Main`. The generated source files will be under `output/`.
47−
48−---
README.md+695−28
@@ -1,41 +1,708 @@
1−[![PureScript](https://raw.githubusercontent.com/purescript/purescript/master/logo.png)](http://purescript.org)
1+purescript
2+==========
2
3
3−This is a platform-native compiler backend for [PureScript](https://github.com/purescript/purescript). It attempts to generate "sane", debuggable, and portable [C++11](https://isocpp.org/wiki/faq/cpp11) (or later) or [Go](https://golang.org/) code as an intermediate language, which is then compiled to a native executable binary. This also enables easy interoperability with existing C/C++ or Go frameworks and libraries on a number of platforms.
4+[![Build Status](https://secure.travis-ci.org/paf31/purescript.png?branch=master)](http://travis-ci.org/paf31/purescript)
4
5
5−There are two utilities in the purescript-native "suite": `pscpp` and `psgo`. The source code in this branch is for `psgo`, the purescript-to-Go transpiler. For the source code of the `pscpp` purescript-to-C++ transpiler, please see the [cpp branch](https://github.com/andyarvanitis/purescript-native/tree/cpp).
6+A small strongly, statically typed compile-to-JS language with basic extensible records and type-safe blocks
6
7
7−#### Platforms
8+## Current Features
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`
20
9
10+- Full Type Inference
11+- Higher Kinded Polymorphism
12+- Support for basic Javascript types
13+- Extensible records
14+- Type-safe blocks with for/while/assignment etc.
15+- Functions with multiple arguments
16+- Pattern matching
17+- Simple FFI
21
18
22−#### Requirements for building `pscpp` and `psgo`
19+## Try It!
23
20
24−* [Haskell Stack](https://docs.haskellstack.org/en/stable/README/) (if you're running macOS 10.14.5+, you can use pre-built binaries from [here](https://github.com/andyarvanitis/purescript-native/releases/))
21+Try PureScript in the browser [here](http://tryps.functorial.com/).
25
22
26−#### Requirements for using PureScript + purescript-native
23+## License
27
24
28−* A recent version (0.13+) of [purescript](https://github.com/purescript/purescript/releases).
25+See the `LICENSE` file
29
26
30−* For `pscpp`, a C++11-capable toolchain, e.g. recent versions of clang, gcc, Microsoft Visual Studio
27+## Contributing
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.
34
28
29+Contributions are always encouraged! Please see `CONTRIBUTING.md` for guidelines.
35
30
36−#### For more information and a Getting Started guide, please see
31+## Installation
37−* [`pscpp`](https://github.com/andyarvanitis/purescript-native/blob/cpp/README-cpp.md)
32+
38−* [`psgo`](https://github.com/andyarvanitis/purescript-native/blob/golang/README-go.md)
33+Install the Haskell Plaform, then `cabal install`
34+
35+## Usage
36+
37+The `psc` executable takes a list of PureScript source files as arguments and by default writes out its errors or output to the console.
38+
39+The following options are supported:
40+
41+ -o --output
42+ Write the generated Javascript to the specified file
43+
44+ -e --foreign imports
45+ Write a list of foreign imports declarations to the specified file in addition to generating Javascript output
46+
47+## Motivation
48+
49+I was looking for a simple functional language which would compile to JavaScript and have the following characteristics:
50+
51+- Generate simple readable Javascript
52+- Provide the ability to compile to tight loops if necessary
53+- Reasonable type system
54+- Ideally, written in a programming language I would enjoy working in
55+- Provides a simple interface to existing Javascript code
56+
57+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.
58+
59+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.
60+
61+PureScript can also be seen as a trade-off between a theoretically ideal language and one which generates reasonably high performance code.
62+
63+## Hello, PureScript!
64+
65+As an introductory example, here is the usual "Hello World" written in PureScript:
66+
67+```haskell
68+foreign import console :: { log :: String -> {} }
69+
70+main = \() -> console.log "Hello, World!"
71+```
72+
73+which compiles to the following Javascript:
74+
75+```javascript
76+function main() {
77+ console.log("Hello, World!");
78+}
79+```
80+
81+## Another Example
82+
83+The following code defines a `Person` data type and a function to generate a string representation for a `Person`:
84+
85+```haskell
86+data Person = Person { name :: String, age :: Number }
87+
88+foreign import numberToString :: Number -> String
89+
90+showPerson :: Person -> String
91+showPerson = \p -> case p of
92+ Person o -> o.name ++ ", aged " ++ numberToString(o.age)
93+```
94+
95+Line by line, this reads as follows:
96+
97+- `Person` is a data type with one constructor, also called `Person`
98+ - The `Person` constructor takes an object with two properties, `name` which is a `String`, and `age` which is a `Number`
99+- The `numberToString` function is written in Javascript, and converts a `Number` to its `String` representation
100+- The `showPerson` function takes a `Person` and returns a `String`
101+- `showPerson` works by case analysis on its argument `p`, first matching the constructor `Person` and then using string concatenation and object accessors to return its result.
102+
103+The generated Javascript looks like this:
104+
105+```javascript
106+var Person = function (value) {
107+ return { ctor: 'Person', value: value };
108+};
109+
110+function showPerson(p) {
111+ if (p.ctor === "Person") {
112+ return p.value.name + ", aged " + itoa(p.value.age)
113+ };
114+ throw "Failed pattern match"
115+}
116+
117+```
118+
119+## Type System
120+
121+The type system defines the following types:
122+
123+- Primitive Types
124+ - Number
125+ - String
126+ - Boolean
127+- Arrays
128+ - E.g. `[String]`, `[[Number]]`
129+- Records
130+ - E.g. `{ foo :: String, bar :: Number }`
131+- Tagged Unions
132+ - E.g. `data Foo a = Foo | Bar String`
133+- Functions
134+ - E.g. `Number -> String`
135+ - E.g. `(Number, Number) -> Number`
136+ - Functions can have zero or more arguments
137+- Polymorphic types (for top level declarations only)
138+ - E.g. `forall a. a -> a`
139+
140+## Primitive Types
141+
142+The three primitive types `String`, `Number` and `Boolean` correspond to their Javascript equivalents at runtime.
143+
144+PureScript supports the same binary and unary operations on primitive types as Javascript, with the following exceptions:
145+
146+- String concatenation is denoted `++` to differentiate it from numeric addition, `+`
147+- PureScript's `==` and `!=` correspond to Javascript's strong equality tests `===` and `!==`
148+
149+Examples:
150+
151+```haskell
152+num = 1 + 2 * 3
153+str = "Hello, " ++ "World!"
154+bool = 1 > 2 || true
155+```
156+
157+## Arrays
158+
159+PureScript arrays correspond to Javascript arrays at runtime, but all elements must have the same type.
160+
161+Array literals look like Javascript array literals: `[1, 2, 3]`
162+
163+Array elements can be read using array index notation `arr !! index`
164+
165+## Records
166+
167+PureScript records correspond to Javascript objects.
168+
169+Record literals look like Javascript object literals: `{ foo: "Foo" }`
170+
171+Properties can be read by using dot notation: `o.foo`
172+
173+## Tagged Unions
174+
175+Tagged unions consist of one or more constructors, each of which takes zero or one arguments.
176+
177+Tagged unions can only be created using their constructors, and deconstructed through pattern matching (see later).
178+
179+For example:
180+
181+```haskell
182+data Foo a = Foo | Bar String
183+
184+runFoo = \foo -> case foo of
185+Foo -> "It's a Foo"
186+Bar s -> "It's a Bar. The string is " ++ s
187+
188+runFoo Foo ++ runFoo (Bar "Test")
189+```
190+
191+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.
192+
193+`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.
194+
195+## Functions
196+
197+Functions in PureScript can have zero or more arguments in general, just like in Javascript.
198+
199+Functions are introduced by using a backslash followed by a list of argument names:
200+
201+```haskell
202+test1 = \a b -> a + b
203+```
204+
205+which would correspond to the Javascript
206+
207+```javascript
208+function test1(a) {
209+ return function (b) {
210+ return a + b;
211+ }
212+}
213+```
214+
215+Multiple argument functions can be introduced by wrapping the arguments in parentheses, and separating them with commas:
216+
217+```haskell
218+test1 = \(a, b) -> a + b
219+```
220+
221+which generates
222+
223+```javascript
224+function test1(a, b) {
225+ return a + b;
226+}
227+```
228+
229+In the case of a function with no arguments, the parentheses may be omitted, as follows:
230+
231+```haskell
232+test2 = \ -> 100
233+```
234+
235+which would correspond to the Javascript `function test2() { return 100; }`
236+
237+Multiple-argument and single-argument syntax can be mixed, as follows:
238+
239+```haskell
240+test3 = \a (b, c) d -> a + b + c + d
241+```
242+
243+which generates
244+
245+```javascript
246+function test3(a) {
247+ return function (b, c) {
248+ return function (d) {
249+ return a + b + c + d;
250+ }
251+ }
252+}
253+```
254+
255+Functions are applied by providing their arguments inside parentheses:
256+
257+```haskell
258+test1(1, 2, 3)
259+test2()
260+```
261+
262+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:
263+
264+```haskell
265+-- has type Number -> Number -> Number -> Number
266+addThree = \a b c -> a + b + c
267+
268+-- has type Number -> Number -> Number
269+addThree 1
270+
271+-- has type Number -> Number
272+addThree 1 2
273+
274+-- has type Number
275+addThree 1 2 3
276+```
277+
278+## Polymorphic Types
279+
280+Expressions defined at the top level may have polymorphic types.
281+
282+Here is an example:
283+
284+```haskell
285+identity = \x -> x
286+```
287+
288+`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.
289+
290+A type annotation can also be provided:
291+
292+```haskell
293+identity :: forall a. a -> a
294+identity = \x -> x
295+```
296+
297+Functions may also be polymorphic in row types or type variables with other kinds (see "Kind System"):
298+
299+```haskell
300+addProps = \o -> o.foo + o.bar
301+```
302+
303+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*.
304+
305+So, the following compiles:
306+
307+```haskell
308+addProps { foo: 1, bar: 2, baz: 3 }
309+```
310+
311+but the following does not:
312+
313+```haskell
314+addProps { foo: 1 }
315+```
316+
317+since the `bar` property is missing.
318+
319+Again, a type annotation can be provided if necessary.
320+
321+## Type Inference
322+
323+All types can be inferred, but annotations can optionally be provided.
324+
325+## Kind System
326+
327+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.
328+
329+## Whitespace
330+
331+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.
332+
333+That is, the following is valid:
334+
335+```haskell
336+foo = bar(x) +
337+ baz(x)
338+```
339+
340+But this is not:
341+
342+```haskell
343+foo = bar(x) +
344+baz(x)
345+```
346+
347+## Do Notation
348+
349+There is a keyword `do`, which does not have the same purpose as the `do` keyword in Haskell.
350+
351+`do` introduces a block. Blocks consist of statements, and must return a value of the same type on every branch of execution.
352+
353+The following types of statement are supported:
354+
355+- Variable introduction
356+- Variable assignment
357+- For loops
358+- For-each loops
359+- While loops
360+- If-Then-Else statements
361+
362+Here is an example of a power function defined using a block:
363+
364+```haskell
365+pow = \n p -> do
366+ var m = n
367+ for i <- 0 until p:
368+ m = m * n
369+ return m
370+```
371+
372+Blocks enable local mutation of their variables, but mutation is not allowed in general. The type system prevents mutable variables from escaping their scope.
373+
374+That is, while the example above is valid, the following does not compile:
375+
376+```haskell
377+incr = \n -> do
378+ n = n + 1
379+ return n
380+```
381+
382+The variable `n` is not mutable, and so the assignment in the first line of the `do` block is not allowed.
383+
384+This function can be rewritten as follows:
385+
386+```haskell
387+incr = \n -> do
388+ var m = n
389+ m = m + 1
390+ return m
391+```
392+
393+## For Loops
394+
395+For loops look like this:
396+
397+```haskell
398+total = do
399+ var n = 0
400+ for i <- 0 until 10:
401+ n = n + i
402+ return n
403+```
404+
405+The bounds `0` and `10` are inclusive and exclusive respectively.
406+
407+## For-Each Loops
408+
409+For each loops loop over the elements in an array using the `Object.forEach` method. A polyfill may be required for some browsers:
410+
411+```haskell
412+total = \arr -> do
413+ var n = 0
414+ foreach i in arr:
415+ n = n + i
416+ return n
417+```
418+
419+## While Loops
420+
421+The syntax of a while loop is similar to a foreach loop:
422+
423+```haskell
424+log2 = \n -> do
425+ var count = 0
426+ var m = n
427+ while m > 1:
428+ m = m / 2
429+ count = count + 1
430+ return count
431+```
432+
433+## If-Then-Else Statements
434+
435+Else branches are optional, and may contain further `if` statements, just as in Javascript:
436+
437+```haskell
438+collatz = \n -> do
439+ var count = 0
440+ var m = n
441+ while m > 1:
442+ if m % 2 == 0:
443+ m = m / 2
444+ else:
445+ m = m * 3 + 1
446+ count = count + 1
447+ return count
448+```
449+
450+## If-Then-Else Expressions
451+
452+The `if`, `then` and `else` keywords can also be used to create conditional expressions. In this case, the `else` block is always required.
453+
454+For example,
455+
456+```haskell
457+conditional = if 2 > 1 then "ok" else "oops"
458+```
459+
460+## Pattern Matching
461+
462+Pattern matching deconstructs a value to bring zero or more expressions into scope. Pattern matches are introduced with the `case` keyword.
463+
464+Pattern matches have the following general form
465+
466+```haskell
467+case value of
468+ pattern -> result
469+ -- ...
470+ pattern -> result
471+```
472+
473+The following pattern types are supported:
474+
475+- Wildcard pattern
476+- Literal patterns
477+- Variable pattern
478+- Array patterns
479+- Record patterns
480+- Named patterns
481+- Guards
482+
483+Patterns need not be exhaustive. A pattern match failed exception will be thrown at runtime if no pattern matches the input.
484+
485+## Wildcard Patterns
486+
487+The wilcard `_` matches any input and brings nothing into scope:
488+
489+```haskell
490+case x of
491+ _ -> 0
492+```
493+
494+## Literal Patterns
495+
496+Literal patterns are provided to match on primitives:
497+
498+```haskell
499+case booleanValue of
500+ true -> 0
501+ false -> 1
502+
503+case stringValue of
504+ "Foo" -> 0
505+ _ -> 1
506+
507+case numericValue of
508+ 0 -> 0
509+ _ -> 1
510+```
511+
512+## Variable Pattern
513+
514+A variable pattern matches any input and binds that input to its name:
515+
516+```haskell
517+case foo(x) of
518+ result -> bar(result)
519+```
520+
521+## Array Patterns
522+
523+Array patterns match an input which is an array, and bring its elements into scope.
524+
525+For example:
526+
527+```haskell
528+f = \arr -> case arr of
529+ [x] -> x
530+ [x, y : xs] -> x * y + f(xs)
531+ _ -> 0
532+```
533+
534+Here, the first pattern only matches arrays of length one, and brings the first element of the array into scope.
535+
536+The second pattern matches arrays with two or more elements, and brings the first and second elements into scope, along with the remainder of the array as the variable `xs`.
537+
538+## Record Patterns
539+
540+Record patterns match an input which is a record, and bring its properties into scope.
541+
542+```haskell
543+f = \o -> case o of
544+ { foo = "Foo" } -> o.bar
545+ _ -> 0
546+```
547+
548+## Nested Patterns
549+
550+The patterns above can be combined to create larger patterns.
551+
552+For example:
553+
554+```haskell
555+f = \o -> case o of
556+ { arr = [x:_], take = "car" } -> x
557+ { arr = [_,x:_], take = "cadr" } -> x
558+ _ -> 0
559+```
560+
561+## Named Patterns
562+
563+Named patterns bring additional names into scope when using nested patterns. Any pattern can be named by using the `@` symbol:
564+
565+```haskell
566+f = \arr -> case arr of
567+ a@[_,_:_] -> a
568+ a -> a
569+```
570+
571+Here, in the first pattern, any array with two or more elements will be matched and bound to the variable `a`.
572+
573+## Guards
574+
575+Guards are used to impose additional constraints inside a pattern using boolean-valued expressions, and are introduced with a pipe after the pattern:
576+
577+```haskell
578+evens = \arr -> case arr of
579+ [] -> 0
580+ [x:xs] | x % 2 == 0 -> 1 + evens xs
581+ [_:xs] -> evens xs
582+```
583+
584+## Type Synonyms
585+
586+For convenience, it is possible to declare a synonym for a type using the `type` keyword. Type synonyms can include type arguments.
587+
588+For example:
589+
590+```haskell
591+type Foo = { foo :: Number, bar Number }
592+
593+addFoo :: Foo -> Number
594+addFoo = \o -> o.foo + o.bar
595+```
596+## Record Updates
597+
598+Properties on records can be updated using the following syntax: `o { key = value, ..., key = value }`
599+
600+For example, the following function increments the `foo` property on its argument:
601+
602+```haskell
603+incr = \o -> o { foo = o.foo + 1 }
604+```
605+
606+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
607+
608+```haskell
609+Object.prototype.extend = function(o, p) {
610+ return $.extend({}, o, p);
611+};
612+```
613+
614+## Operators
615+
616+In addition to the standard operators, user-defined infix operators can be created by enclosing names in parentheses:
617+
618+E.g. to create a synonym for string concatenation:
619+
620+```haskell
621+(<>) = \s1 s2 -> s1 ++ s2
622+
623+greeting = "Hello" <> "World!"
624+```
625+
626+Regular functions can be used as operators by enclosing their names in backticks:
627+
628+```haskell
629+foo = \x y -> x * y + y
630+
631+test = 10 `foo` 20
632+```
633+
634+Fixity declarations can associate a precedence level, which is a natural number, to a user-defined operator, and specify which way it associates:
635+
636+```haskell
637+infixl 5 <>
638+infixr 7 %%
639+```
640+
641+## Modules
642+
643+Simple modules are supported by the `module` keyword.
644+
645+Introduce a module as follows, with a list of indented declarations:
646+
647+```haskell
648+module A where
649+
650+ foo = \x -> x
651+```
652+
653+Modules may be nested:
654+
655+```haskell
656+module A where
657+
658+ foo = \x -> x
659+
660+ module B where
661+
662+ bar = \y -> y
663+```
664+
665+Names may be qualified by using a colon:
666+
667+```
668+foo = A:foo
669+bar = A:B:bar
670+```
671+
672+All the names in a module can be aliased using the `import` declaration:
673+
674+```haskell
675+import A
676+```
677+
678+You can also limit which names are going to be aliased:
679+
680+```haskell
681+import A.B (bar)
682+```
683+
684+## Foreign Function Interface
685+
686+The `foreign import` keyword declares a value which is defined in Javascript, and its type:
687+
688+```haskell
689+foreign import pow :: (Number, Number) -> Number
690+```
691+
692+To declare a new type with no constructors, use `foreign import data` and provide the kind:
693+
694+```haskell
695+foreign import data IO :: * -> *
696+
697+foreign import console :: {
698+ log :: String -> IO {}
699+}
700+```
701+
702+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:
703+
704+```haskell
705+foreign import member "length" length :: forall a. [a] -> Number
706+```
39
707
40
708
41−---
Setup.hsdeleted−2
@@ -1,2 +0,0 @@
1−import Distribution.Simple
2−main = defaultMain
Setup.lhsnew file+6
@@ -0,0 +1,6 @@
1+#!/usr/bin/runhaskell
2+> module Main where
3+> import Distribution.Simple
4+> main :: IO ()
5+> main = defaultMain
6+
app/Main.hsdeleted−250
@@ -1,250 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−{-# LANGUAGE RankNTypes #-}
3−{-# LANGUAGE TemplateHaskell #-}
4−
5−module Main where
6−
7−import Control.Monad (when)
8−import qualified Control.Monad.Parallel as Par
9−import Data.Aeson
10−import Data.Aeson.Types
11−import Data.Char
12−import Data.FileEmbed (embedFile)
13−import Data.List (delete, intercalate, isPrefixOf, nub, partition, (\\))
14−import Data.Maybe
15−import Data.Monoid ((<>))
16−import Data.Version
17−import Control.Monad.Supply
18−import Control.Monad.Supply.Class
19−import Text.Printf
20−
21−import System.Environment
22−import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist, getCurrentDirectory, getModificationTime)
23−import System.FilePath ((</>), joinPath, splitDirectories, takeDirectory)
24−import System.FilePath.Find
25−import System.Process
26−
27−import Data.Text (Text)
28−import qualified Data.Text as T
29−import qualified Data.Text.Encoding as T
30−import qualified Data.Text.Lazy as L
31−import qualified Data.Text.Lazy.Encoding as L
32−import qualified Data.ByteString as B
33−
34−import Development.GitRev
35−
36−import Language.PureScript.AST.Literals
37−import Language.PureScript.CoreFn
38−import Language.PureScript.CoreFn.FromJSON
39−
40−import CodeGen.IL
41−import CodeGen.IL.Common
42−import CodeGen.IL.Printer
43−
44−import Tests
45−
46−data Command = Build | Run (Maybe String)
47−
48−parseJson :: Text -> Value
49−parseJson text
50− | Just fileJson <- decode . L.encodeUtf8 $ L.fromStrict text = fileJson
51− | otherwise = error "Bad json"
52−
53−jsonToModule :: Value -> Module Ann
54−jsonToModule value =
55− case parse moduleFromJSON value of
56− Success (_, r) -> r
57− _ -> error "Failed parsing corefn. Psgo currently supports purescript <= 0.13.8"
58−
59−splitArgs :: [String] -> ([String], Maybe String, [String])
60−splitArgs args =
61− let (opts, files) = partition (isPrefixOf "--") args
62− opts' = (map . map) toLower opts
63− (moduleName, files') =
64− if null files
65− then (Nothing, files)
66− else
67− if "--run" `elem` opts' && length (files) >= 1
68− then do
69− let file0 = head files
70− files' = tail files
71− case file0 of
72− "Main.main" -> (Just "Main", files')
73− "Test.Main.main" -> (Just "Test.Main", files')
74− _ -> (Nothing, files)
75− else (Nothing, files)
76− in (opts, moduleName, files')
77−
78−main :: IO ()
79−main = do
80− args <- getArgs
81− -- let (opts, files) = partition (isPrefixOf "--") args
82− let (opts, moduleName, files) = splitArgs args
83− opts' = (map . map) toLower opts
84− if "--tests" `elem` opts'
85− then runTests
86− else do
87− if "--help" `elem` opts' || "--version" `elem` opts'
88− then do
89− when ("--help" `elem` opts') $ do
90− putStrLn help
91− when ("--version" `elem` opts') $ do
92− let branch = $(gitBranch)
93− details | branch == "golang" = "master, commit " ++ $(gitHash)
94− | otherwise = branch
95− putStrLn $ details ++ if $(gitDirty) then " (DIRTY)" else ""
96− else do
97− if null files
98− then do
99− currentDir <- getCurrentDirectory
100− processFiles opts' [currentDir]
101− else
102− processFiles opts' files
103− if "--run" `elem` opts
104− then runBuildTool $ Run moduleName
105− else when ("--no-build" `notElem` opts) $
106− runBuildTool Build
107− return ()
108− where
109− processFiles :: [String] -> [FilePath] -> IO ()
110− processFiles opts [file] = do
111− isDir <- doesDirectoryExist file
112− if isDir then do
113− files <- find always (fileName ==? corefn) file
114− if null files
115− then errorNoCorefnFiles
116− else generateFiles opts files
117− else generateFiles opts [file]
118− processFiles opts files = do
119− generateFiles opts files
120− basePath :: [FilePath] -> FilePath
121− basePath files =
122− let filepath = takeDirectory (head files) in
123− joinPath $ (init $ splitDirectories filepath)
124− generateFiles :: [String] -> [FilePath] -> IO ()
125− generateFiles opts files = do
126− let baseOutpath = basePath files
127− writeSupportFiles baseOutpath
128− Par.mapM (generateCode opts baseOutpath) files
129− return ()
130− runBuildTool :: Command -> IO ()
131− runBuildTool cmd = do
132− project <- projectEnv
133− case cmd of
134− Build -> do
135− callProcess "go" ["build", T.unpack project </> modPrefix' </> "Main"]
136− Run moduleName -> do
137− callProcess "go" ["run", T.unpack project </> modPrefix' </> fromMaybe "Main" moduleName]
138− return ()
139−
140−generateCode :: [String] -> FilePath -> FilePath -> IO ()
141−generateCode opts baseOutpath jsonFile = do
142− jsonModTime <- getModificationTime jsonFile
143− let filepath = takeDirectory jsonFile
144− dirparts = splitDirectories $ filepath
145− mname = last dirparts
146− basedir = joinPath $ init dirparts
147− mname' = T.pack mname
148− possibleFileName = basedir </> (T.unpack mname') </> implFileName mname'
149− exists <- doesFileExist possibleFileName
150− if exists
151− then do
152− modTime <- getModificationTime possibleFileName
153− when (modTime < jsonModTime) $
154− transpile opts baseOutpath jsonFile
155− else transpile opts baseOutpath jsonFile
156−
157−transpile :: [String] -> FilePath -> FilePath -> IO ()
158−transpile opts baseOutpath jsonFile = do
159− jsonText <- T.decodeUtf8 <$> B.readFile jsonFile
160− project <- projectEnv
161− let module' = jsonToModule $ parseJson jsonText
162− ((_, foreigns, asts, implHeader, implFooter), _) <- runSupplyT 5 (moduleToIL module' project)
163− let mn = moduleNameToIL' $ moduleName module'
164− implementation = prettyPrintIL asts
165− outpath = joinPath [baseOutpath, T.unpack mn]
166− implPath = outpath </> implFileName mn
167− createDirectoryIfMissing True outpath
168− putStrLn implPath
169− B.writeFile implPath $ T.encodeUtf8 (implHeader <> implementation <> implFooter)
170−
171−writeSupportFiles :: FilePath -> IO ()
172−writeSupportFiles baseOutpath = do
173− currentDir <- getCurrentDirectory
174− let outputdir = T.pack $ baseOutpath \\ currentDir
175− ffiOutpath = currentDir </> subdir
176− createDirectoryIfMissing True baseOutpath
177− createDirectoryIfMissing True ffiOutpath
178− writeModuleFile outputdir currentDir $(embedFile "support/go.mod.working")
179− writeModuleFile outputdir baseOutpath $(embedFile "support/go.mod.output")
180− writeModuleFile outputdir ffiOutpath $(embedFile "support/go.mod.ffi-loader")
181− writeLoaderFile ffiOutpath $(embedFile "support/ffi-loader.go")
182− where
183− writeModuleFile :: Text -> FilePath -> B.ByteString -> IO ()
184− writeModuleFile outputdir path modText = do
185− let goModSource = path </> "go.mod"
186− goModSourceExists <- doesFileExist goModSource
187− when (not goModSourceExists) $ do
188− project <- projectEnv
189− let project' = T.unpack project
190− outputdir' = tail $ T.unpack outputdir
191− modText' = T.replace "$PROJECT" project $ T.decodeUtf8 modText
192− replaceLoader = project' </> ffiLoader' <> "=." </> subdir
193− replaceOutput = project' </> modPrefix' <> "=." </> outputdir'
194− B.writeFile goModSource $ T.encodeUtf8 modText'
195− callProcess "go" ["mod", "edit", "-replace", replaceLoader]
196− callProcess "go" ["mod", "edit", "-replace", replaceOutput]
197− callProcess "go" ["clean", "-modcache"]
198− writeLoaderFile :: FilePath -> B.ByteString -> IO ()
199− writeLoaderFile ffiOutpath loaderText = do
200− let loaderSource = ffiOutpath </> "ffi_loader.go"
201− loaderSourceExists <- doesFileExist loaderSource
202− when (not loaderSourceExists) $ do
203− B.writeFile loaderSource loaderText
204−
205−implFileName :: Text -> FilePath
206−implFileName mn = ((\c -> if c == '.' then '_' else c) <$> T.unpack mn) <> ".go"
207−
208−projectEnv :: IO Text
209−projectEnv = do
210− T.pack . fromMaybe defaultProject <$> lookupEnv goproject
211−
212−help :: String
213−help = "Usage: psgo OPTIONS COREFN-FILES\n\
214− \ PureScript to native (via go) compiler\n\n\
215− \Available options:\n\
216− \ --help Show this help text\n\n\
217− \ --version Show the version number\n\n\
218− \ --run Run the generated go code directly, without building an\n\
219− \ executable\n\
220− \ --no-build Generate go source files, but do not build an executable\n\
221− \ --tests Run test cases (under construction)\n\n\
222− \See also:\n\
223− \ purs compile --help\n"
224−
225−corefn :: String
226−corefn = "corefn.json"
227−
228−goSrc :: String
229−goSrc = ".go"
230−
231−goproject :: String
232−goproject = "GOPROJECT"
233−
234−defaultProject :: String
235−defaultProject = "project.localhost"
236−
237−modPrefix' :: String
238−modPrefix' = T.unpack modPrefix
239−
240−ffiLoader' :: String
241−ffiLoader' = T.unpack ffiLoader
242−
243−subdir :: String
244−subdir = T.unpack modLabel
245−
246−errorNoCorefnFiles :: IO ()
247−errorNoCorefnFiles = do
248− ioError . userError $ "no compiled purescript '" <> corefn <> "' files found –\n" <>
249− " make sure to use the '--codegen corefn' option with your purs\n" <>
250− " project build tool"
default.nixdeleted−23
@@ -1,23 +0,0 @@
1−let
2− haskellNix = import (builtins.fetchTarball https://github.com/input-output-hk/haskell.nix/archive/master.tar.gz) {};
3− nixpkgsSrc = haskellNix.sources.nixpkgs-1903; # has hsc2hs-0.68.4
4−
5− hsc2hsOverlay = self: super: {
6− buildPackages = super.buildPackages // {
7− hsc2hs = super.haskellPackages.hsc2hs;
8− };
9− };
10−
11− nixpkgsArgs = haskellNix.nixpkgsArgs // {
12− overlays = haskellNix.nixpkgsArgs.overlays ++ [ hsc2hsOverlay ];
13− };
14−in
15−{ pkgs ? import nixpkgsSrc nixpkgsArgs
16−}:
17−
18−pkgs.haskell-nix.stackProject {
19− src = pkgs.haskell-nix.haskellLib.cleanGit {
20− name = "purescript-native";
21− src = ./.;
22− };
23−}
examples/.gitignorenew file+1
@@ -0,0 +1 @@
1+shelltest/tests
examples/failing/Arrays.psnew file+1
@@ -0,0 +1 @@
1+test = \arr -> arr !! (0 !! 0)
examples/failing/Import.psnew file+1
@@ -0,0 +1 @@
1+import UndefinedModule
examples/failing/KindError.psnew file+1
@@ -0,0 +1 @@
1+data KindError f a = One f | Two f a
examples/failing/PatternScope.psnew file+7
@@ -0,0 +1,7 @@
1+-- Pattern scope doesn't leak
2+foobar = \x -> do
3+ var y = case x of
4+ z | z % 2 == 0 -> 1
5+ _ -> 2
6+ return z
7+
examples/failing/Rank2Types.psnew file+3
@@ -0,0 +1,3 @@
1+foreign import test :: (forall a. a -> a) -> Number
2+
3+test1 = test (\n -> n + 1)
examples/failing/ReadShow.psnew file+5
@@ -0,0 +1,5 @@
1+foreign import read :: forall a. String -> a
2+
3+foreign import show :: forall a. a -> String
4+
5+test = \x -> show (read x)
examples/failing/TypeError.psnew file+3
@@ -0,0 +1,3 @@
1+test = do
2+ var x = 0
3+ return x ++ "A"
examples/passing/Arrays.psnew file+14
@@ -0,0 +1,14 @@
1+test1 = \arr -> arr !! 0 + arr !! 1
2+
3+test2 = \arr -> case arr of
4+ [x, y] -> x + y
5+ [x] -> x
6+ [] -> 0
7+ [x, y : _] -> x + y
8+
9+data Tree = One Number | Some [Tree]
10+
11+test3 = \(tree, sum) -> case tree of
12+ One n -> n
13+ Some [n1, n2 : rest] -> test3(n1, sum) * 10 + test3(n2, sum) * 5 + sum(rest)
14+
examples/passing/Assign.psnew file+5
@@ -0,0 +1,5 @@
1+sum = \n -> do
2+ var x = 0
3+ for i <- 0 until n:
4+ x = x + i
5+ return x
examples/passing/Conditional.psnew file+5
@@ -0,0 +1,5 @@
1+fns = \f -> if f true then f else \x -> x
2+
3+bin = \x -> if x && !x then x else x
4+
5+not = \x -> if x then false else true
examples/passing/Console.psnew file+19
@@ -0,0 +1,19 @@
1+foreign import data IO :: * -> *
2+
3+foreign import ret :: forall a. a -> IO a
4+
5+foreign import (>>=) :: forall a b. IO a -> (a -> IO b) -> IO b
6+
7+(*>) = \a -> \b -> a >>= \x -> b
8+
9+foreign import putStrLn :: String -> IO {}
10+
11+replicateM_ :: forall a. Number -> IO a -> IO {}
12+replicateM_ = \n -> \x -> do
13+ var io = ret {}
14+ for i <- 0 until n:
15+ io = x *> io
16+ return io
17+
18+main = replicateM_ 10 (putStrLn "Hello World!")
19+
examples/passing/ExternData.psnew file+13
@@ -0,0 +1,13 @@
1+foreign import data IO :: * -> *
2+
3+foreign import fmap :: forall a b. IO a -> (a -> b) -> IO b
4+
5+foreign import ret :: forall a. a -> IO a
6+
7+foreign import bind :: forall a b. IO a -> (a -> IO b) -> IO b
8+
9+foreign import showMessage :: String -> IO { }
10+
11+foreign import prompt :: IO String
12+
13+main = prompt `bind` \s -> showMessage s
examples/passing/FFI.psnew file+5
@@ -0,0 +1,5 @@
1+foreign import foo :: String -> String
2+
3+bar :: String -> String
4+
5+bar = \x -> foo (x ++ "bar")
examples/passing/Foreach.psnew file+5
@@ -0,0 +1,5 @@
1+sum = \ns -> do
2+ var total = 0
3+ foreach n in ns:
4+ total = total + n
5+ return total
examples/passing/Functions.psnew file+11
@@ -0,0 +1,11 @@
1+test1 = \ -> 0
2+
3+test2 = \() -> 0
4+
5+test3 = \a (b, c) d -> a + b + c + d
6+
7+test4 = \(a) -> a
8+
9+test5 = \(%%) -> 1 %% 2
10+
11+test6 = \((+++), (***)) -> 1 +++ 2 *** 3
examples/passing/Guards.psnew file+8
@@ -0,0 +1,8 @@
1+collatz = \x -> case x of
2+ y | y % 2 == 0 -> y / 2
3+ y -> y * 3 + 1
4+
5+-- Guards have access to current scope
6+collatz2 = \x y -> case x of
7+ z | y > 0 -> z / 2
8+ z -> z * 3 + 1
examples/passing/IfThenElse.psnew file+24
@@ -0,0 +1,24 @@
1+testIf = do
2+ var x = 0
3+ if x == 0:
4+ x = x + 1
5+ return x
6+
7+testIfElse = do
8+ var x = 0
9+ if x == 0:
10+ x = x + 1
11+ else:
12+ x = x - 1
13+ return x
14+
15+testIfElseIf = \x -> do
16+ var y = x
17+ while y > 1:
18+ if y % 3 == 0:
19+ y = y / 3
20+ else if y % 3 == 1:
21+ y = (y - 1) % 3
22+ else:
23+ y = y * 4 + 1
24+ return y
examples/passing/Import.psnew file+12
@@ -0,0 +1,12 @@
1+module Hello where
2+ id :: forall a. a -> a
3+ id = \x -> x
4+
5+ module Nested where
6+ import Hello (id)
7+
8+ foo = id
9+
10+import Hello.Nested
11+
12+main = \() -> foo 42
examples/passing/List.psnew file+22
@@ -0,0 +1,22 @@
1+data List a
2+ = Nil
3+ | Cons
4+ { head :: a
5+ , tail :: List a
6+ }
7+
8+isNull = \l -> case l of
9+ Nil -> true
10+ _ -> false
11+
12+concat = \l1 -> \l2 -> case l1 of
13+ Nil -> l2
14+ Cons x -> Cons
15+ { head: x.head
16+ , tail: concat x.tail l2
17+ }
18+
19+flatten = \xss -> case xss of
20+ Nil -> Nil
21+ Cons cons -> concat cons.head (flatten cons.tail)
22+
examples/passing/Match.psnew file+3
@@ -0,0 +1,3 @@
1+data Foo a = Foo
2+
3+foo = \f -> case f of Foo -> "foo"
examples/passing/Maybe.psnew file+10
@@ -0,0 +1,10 @@
1+data Maybe a = Nothing | Just a
2+
3+maybe :: forall a b. b -> (a -> b) -> Maybe a -> b
4+maybe = \b -> \f -> \m -> case m of
5+ Nothing -> b
6+ Just a -> f a
7+
8+fmap = \m -> \f -> maybe Nothing (\a -> Just (f a)) m
9+
10+bind = \m -> \f -> maybe Nothing f m
examples/passing/Module.psnew file+22
@@ -0,0 +1,22 @@
1+module Test where
2+
3+ data Foo = Foo String
4+
5+ foo :: Test:Foo -> String
6+ foo = \f -> case f of Foo s -> s ++ "foo"
7+
8+ bar :: Foo -> String
9+ bar = foo
10+
11+ module Inner where
12+
13+ inner = "Inner"
14+
15+baz :: Test:Foo -> String
16+baz = Test:foo
17+
18+innerCopy :: String
19+innerCopy = Test:Inner:inner
20+
21+match :: Test:Foo -> String
22+match = \f -> case f of Test:Foo s -> s ++ "foo"
examples/passing/NamedPatterns.psnew file+3
@@ -0,0 +1,3 @@
1+foo = \x -> case x of
2+ y@{ foo = "Foo" } -> y
3+ y -> y
examples/passing/Nested.psnew file+3
@@ -0,0 +1,3 @@
1+data Extend r a = Extend { prev :: r a, next :: a }
2+
3+data Matrix r a = Square (r (r a)) | Bigger (Matrix (Extend r) a)
examples/passing/ObjectUpdate.psnew file+9
@@ -0,0 +1,9 @@
1+update1 = \o -> o { foo = "Foo" }
2+
3+update2 :: forall r. { foo :: String | r } -> { foo :: String | r }
4+update2 = \o -> o { foo = "Foo" }
5+
6+replace = \o -> case o of
7+ { foo = "Foo" } -> o { foo = "Bar" }
8+ { foo = "Bar" } -> o { bar = "Baz" }
9+ o -> o
examples/passing/Objects.psnew file+12
@@ -0,0 +1,12 @@
1+test = \x -> x.foo + x.bar
2+
3+append = \o -> { foo: o.foo, bar: 1 }
4+
5+apTest = append({foo : "Foo", baz: "Baz"})
6+
7+f = (\a -> a.b.c) { b: { c: 1, d: "Hello" }, e: "World" }
8+
9+g = (\a -> a.f { x: 1, y: "y" }) { f: \o -> o.x + 1 }
10+
11+typed :: { foo :: Number }
12+typed = { foo: 0 }
examples/passing/Operators.psnew file+37
@@ -0,0 +1,37 @@
1+test1 = \(x, y, z) -> x * y + z(x)(y)
2+
3+test2 = (\x -> x.foo false) { foo : \_ -> 1 }
4+
5+test3 = (\(x, y) -> x)(1 + 2 * (1 + 2), true && (false || false))
6+
7+k = \x -> \y -> x
8+
9+test4 = 1 `k` 2
10+
11+infixl 5 %%
12+
13+(%%) = \x -> \y -> x * y + y
14+
15+test5 = 1 %% 2 %% 3
16+
17+test6 = ((\x -> x) `k` 2) 3
18+
19+(<>) = \s1 -> \s2 -> s1 ++ s2
20+
21+test7 = "Hello" <> "World!"
22+
23+module Ops where
24+
25+ (@@) :: forall a b. (a -> b) -> a -> b
26+ (@@) = \f x -> f x
27+
28+ foo :: String -> String
29+ foo = \s -> s
30+
31+ test8 = foo @@ "Hello World"
32+
33+ bar = \s1 s2 -> s1 ++ s2
34+
35+test9 = Ops:foo Ops:@@ "Hello World"
36+
37+test10 = "Hello" `Ops:bar` "World"
examples/passing/Patterns.psnew file+23
@@ -0,0 +1,23 @@
1+test = \x -> case x of
2+ { str = "Foo", bool = true } -> true
3+ { str = "Bar", bool = b } -> b
4+ _ -> false
5+
6+f = \o -> case o of
7+ { foo = "Foo" } -> o.bar
8+ _ -> 0
9+
10+g = \o -> case o of
11+ { arr = [x : xs], take = "car" } -> x
12+ { arr = [_, x : xs], take = "cadr" } -> x
13+ _ -> 0
14+
15+
16+h = \o -> case o of
17+ a@[_,_,_] -> a
18+ _ -> []
19+
20+isDesc = \o -> case o of
21+ [x, y] | x > y -> true
22+ _ -> false
23+
examples/passing/Person.psnew file+7
@@ -0,0 +1,7 @@
1+data Person = Person { name :: String, age :: Number }
2+
3+foreign import itoa :: Number -> String
4+
5+showPerson :: Person -> String
6+showPerson = \p -> case p of
7+ Person o -> o.name ++ ", aged " ++ itoa(o.age)
examples/passing/Rank2Types.psnew file+10
@@ -0,0 +1,10 @@
1+test1 :: (forall a. (a -> a)) -> Number
2+test1 = \f -> f 0
3+
4+foreign import data ST :: * -> * -> *
5+
6+foreign import runST :: forall a. (forall s. ST s a) -> a
7+
8+foreign import exampleST :: forall s. ST s Number
9+
10+testST = runST exampleST
examples/passing/Recursion.psnew file+4
@@ -0,0 +1,4 @@
1+fib = \n -> case n of
2+ 0 -> 1
3+ 1 -> 1
4+ n -> fib (n - 1) + fib (n - 2)
examples/passing/TypeDecl.psnew file+12
@@ -0,0 +1,12 @@
1+id :: forall a. (a) -> a
2+id = \x -> x
3+
4+k :: String -> Number -> String
5+k = \x -> \y -> x
6+
7+iterate :: forall a. Number -> (a -> a) -> a -> a
8+iterate = \n -> \f -> \a -> do
9+ var result = a
10+ for i <- 0 until n:
11+ result = f result
12+ return result
examples/passing/TypeSynonyms.psnew file+29
@@ -0,0 +1,29 @@
1+type Lens a b =
2+ { get :: a -> b
3+ , set :: a -> b -> a
4+ }
5+
6+composeLenses :: forall a b c. Lens a b -> Lens b c -> Lens a c
7+composeLenses = \l1 -> \l2 ->
8+ { get: \a -> l2.get (l1.get a)
9+ , set: \a -> \c -> do
10+ var b = l1.get a
11+ var b1 = l2.set b c
12+ return l1.set a b1
13+ }
14+
15+type Pair a b = { fst :: a, snd :: b }
16+
17+fst :: forall a b. Lens (Pair a b) a
18+fst =
19+ { get: \p -> p.fst
20+ , set: \p -> \a -> { fst: a, snd: p.snd }
21+ }
22+
23+test1 :: forall a b c. Lens (Pair (Pair a b) c) a
24+test1 = composeLenses fst fst
25+
26+foreign import head :: forall a. Lens [a] a
27+
28+test2 :: forall a b c. Lens (Pair [Pair a b] c) a
29+test2 = composeLenses fst (composeLenses head fst)
examples/passing/iota.psnew file+5
@@ -0,0 +1,5 @@
1+s = \x -> \y -> \z -> x z (y z)
2+
3+k = \x -> \y -> x
4+
5+iota = \x -> x s k
examples/passing/s.psnew file+1
@@ -0,0 +1 @@
1+s = \x y z -> x z (y z)
examples/shelltest/Console.jsnew file+19
@@ -0,0 +1,19 @@
1+// data IO a = \ -> a
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.jsnew file+1
@@ -0,0 +1 @@
1+console.log(sum([1,2,3,4,5]));
examples/shelltest/List.jsnew file+7
@@ -0,0 +1,7 @@
1+var l1 = Cons({ head: 1, tail: Nil });
2+var l2 = Cons({ head: 2, tail: Nil });
3+var l3 = Cons({ head: l1, tail: Cons({ head: l2, tail: Nil }) });
4+var flat = flatten(l3);
5+var f1 = flat.value.head;
6+var f2 = flat.value.tail.value.head
7+console.log([f1, f2]);
examples/shelltest/Maybe.jsnew file+5
@@ -0,0 +1,5 @@
1+console.log(bind(Just("a"))(function(a) {
2+ return bind(Just("b"))(function(b) {
3+ return Just(a + b);
4+ });
5+}));
examples/shelltest/runAll.testnew file+23
@@ -0,0 +1,23 @@
1+# Maybe
2+mkdir -p tests && ../../dist/build/psc/psc ../passing/Maybe.ps -o tests/Maybe.js && cat tests/Maybe.js Maybe.js | node
3+<<<
4+>>>
5+{ ctor: 'Just', value: 'ab' }
6+>>>2
7+>>>= 0
8+
9+# List
10+mkdir -p tests && ../../dist/build/psc/psc ../passing/List.ps -o tests/List.js && cat tests/List.js List.js | node
11+<<<
12+>>>
13+[ 1, 2 ]
14+>>>2
15+>>>= 0
16+
17+# Foreach
18+mkdir -p tests && ../../dist/build/psc/psc ../passing/Foreach.ps -o tests/Foreach.js && cat tests/Foreach.js Foreach.js | node
19+<<<
20+>>>
21+15
22+>>>2
23+>>>= 0
examples/shelltest/runMain.jsnew file+1
@@ -0,0 +1 @@
1+main();
libraries/.gitignorenew file+1
@@ -0,0 +1 @@
1+*/all.js
libraries/jquery/Makefilenew file+4
@@ -0,0 +1,4 @@
1+all:
2+ ../../dist/build/psc/psc jquery.ps example.ps -o all.js
3+ cat jquery.js >> all.js
4+ echo "main()" >> all.js
libraries/jquery/example.psnew file+5
@@ -0,0 +1,5 @@
1+main = do
2+ var div = create "<div>"
3+ div = div `appendText` "Hello World!" `css` { color: "#FF0000" }
4+ div = div `appendTo` select "body"
5+ return { }
libraries/jquery/jquery.jsnew file+7
@@ -0,0 +1,7 @@
1+function select(s) { return $(s); }
2+function create(s) { return $(s); }
3+function attr(j, a) { return j.attr(o); }
4+function css(j, a) { return j.css(o); }
5+function append(j1, j2) { return j1.append(j2); }
6+function appendTo(j1, j2) { return j1.appendTo(j2); }
7+function appendText(j1, s) { return j1.append(s); }
libraries/jquery/jquery.psnew file+23
@@ -0,0 +1,23 @@
1+-- The jQuery wrapper type
2+foreign import data JQuery :: *
3+
4+-- Wrapper function for jQuery selection $('..')
5+foreign import select :: String -> JQuery
6+
7+-- Wrapper function for jQuery creation e.g. $('<div>')
8+foreign import create :: String -> JQuery
9+
10+-- .attr({ ... })
11+foreign import attr :: forall attr. JQuery -> { | attr } -> JQuery
12+
13+-- .css({ ... })
14+foreign import css :: forall css. JQuery -> { | css } -> JQuery
15+
16+-- .append(...)
17+foreign import append :: JQuery -> JQuery -> JQuery
18+
19+-- .appendTo(...)
20+foreign import appendTo :: JQuery -> JQuery -> JQuery
21+
22+-- .append(...)
23+foreign import appendText :: JQuery -> String -> JQuery
libraries/prelude/Makefilenew file+3
@@ -0,0 +1,3 @@
1+all:
2+ ../../dist/build/psc/psc prelude.ps -o all.js
3+ cat prelude.js >> all.js
libraries/prelude/prelude.jsnew file+65
@@ -0,0 +1,65 @@
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.psnew file+261
@@ -0,0 +1,261 @@
1+id :: forall a. a -> a
2+id = \x -> x
3+
4+flip :: forall a b c. (a -> b -> c) -> b -> a -> c
5+flip = \f -> \b -> \a -> f a b
6+
7+konst :: forall a b. a -> b -> a
8+konst = \a -> \b -> a
9+
10+(|>) :: forall a b c. (a -> b) -> (b -> c) -> a -> c
11+(|>) = \f -> \g -> \a -> g (f a)
12+
13+(<|) :: forall a b c. (b -> c) -> (a -> b) -> a -> c
14+(<|) = flip (|>)
15+
16+-- Maybe
17+
18+data Maybe a = Nothing | Just a
19+
20+maybe :: forall a b. b -> (a -> b) -> Maybe a -> b
21+maybe = \b -> \f -> \m -> case m of
22+ Nothing -> b
23+ Just a -> f a
24+
25+fromMaybe :: forall a. a -> Maybe a -> a
26+fromMaybe = \a -> maybe a id
27+
28+bindMaybe :: forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
29+bindMaybe = \m -> \f -> maybe Nothing f m
30+
31+-- Either
32+
33+data Either a b = Left a | Right b
34+
35+either :: forall a b c. (a -> c) -> (b -> c) -> Either a b -> c
36+either = \f -> \g -> \e -> case e of
37+ Left a -> f a
38+ Right b -> g b
39+
40+bindEither :: forall e a b. Either e a -> (a -> Either e b) -> Either e b
41+bindEither = either (\e -> \_ -> Left e) (\a -> \f -> f a)
42+
43+-- Arrays
44+
45+head :: forall a. [a] -> a
46+head = \xs -> case xs of
47+ [x:_] -> x
48+
49+headSafe :: forall a. [a] -> Maybe a
50+headSafe = \xs -> case xs of
51+ [x:_] -> Just x
52+ _ -> Nothing
53+
54+tail :: forall a. [a] -> [a]
55+tail = \xs -> case xs of
56+ [_:xs] -> xs
57+
58+tailSafe :: forall a. [a] -> Maybe [a]
59+tailSafe = \xs -> case xs of
60+ [_:xs] -> Just xs
61+ _ -> Nothing
62+
63+foreign import map :: forall a b. (a -> b) -> [a] -> [b]
64+
65+foldr :: forall a b. (a -> b -> a) -> a -> [b] -> a
66+foldr = \f -> \a -> \bs -> case bs of
67+ [b:bs] -> f (foldr f a bs) b
68+ [] -> a
69+
70+foldl :: forall a b. (a -> b -> b) -> b -> [a] -> b
71+foldl = \f -> \b -> \as -> do
72+ var result = b
73+ foreach a in as:
74+ result = f a result
75+ return result
76+
77+foreign import member "length" length :: forall a. [a] -> Number
78+
79+foreign import indexOf :: forall a. [a] -> a -> Number
80+
81+foreign import lastIndexOf :: forall a. [a] -> a -> Number
82+
83+foreign import concat :: forall a. [a] -> [a] -> [a]
84+
85+foreign import join :: [String] -> String
86+
87+foreign import joinWith :: [String] -> String -> String
88+
89+foreign import push :: forall a. [a] -> a -> [a]
90+
91+foreign import reverse :: forall a. [a] -> [a]
92+
93+foreign import shift :: forall a. [a] -> [a]
94+
95+foreign import slice :: forall a. Number -> Number -> [a] -> [a]
96+
97+foreign import sort :: forall a. [a] -> [a]
98+
99+foreign import splice :: forall a. Number -> Number -> [a] -> [a] -> [a]
100+
101+cons :: forall a. a -> [a] -> [a]
102+cons = \a -> concat([a])
103+
104+concatMap :: forall a b. [a] -> (a -> [b]) -> [b]
105+concatMap = \as -> \f -> do
106+ var result = []
107+ foreach a in as:
108+ result = result `concat` f a
109+ return result
110+
111+foreign import filter :: forall a. [a] -> (a -> Boolean) -> [a]
112+
113+empty :: forall a. [a] -> Boolean
114+empty = \as -> case as of
115+ [] -> true
116+ _ -> false
117+
118+range :: Number -> Number -> [Number]
119+range = \lo -> \hi -> do
120+ var ns = []
121+ for n <- lo until hi:
122+ ns = push ns n
123+ return ns
124+
125+zipWith :: forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
126+zipWith = \f -> \as -> \bs -> case { as: as, bs: bs } of
127+ { as = [a:as1], bs = [b:bs1] } -> cons (f a b) (zipWith f as1 bs1)
128+ _ -> []
129+
130+any :: forall a. (a -> Boolean) -> [a] -> Boolean
131+any = \p -> \as -> do
132+ for i <- 0 until length as:
133+ if p (as !! i):
134+ return true
135+ return false
136+
137+all :: forall a. (a -> Boolean) -> [a] -> Boolean
138+all = \p -> \as -> do
139+ for i <- 0 until length as:
140+ if !(p (as !! i)):
141+ return false
142+ return true
143+
144+-- Pairs
145+
146+type Tuple a b = { fst :: a, snd :: b }
147+
148+curry :: forall a b c. (Tuple a b -> c) -> a -> b -> c
149+curry = \f -> \a -> \b -> f { fst: a, snd: b }
150+
151+uncurry :: forall a b c. (a -> b -> c) -> Tuple a b -> c
152+uncurry = \f -> \t -> f t.fst t.snd
153+
154+tuple :: forall a b. a -> b -> Tuple a b
155+tuple = curry id
156+
157+zip :: forall a b. [a] -> [b] -> [Tuple a b]
158+zip = zipWith tuple
159+
160+unzip :: forall a b. [Tuple a b] -> Tuple [a] [b]
161+unzip = \ts -> case ts of
162+ [t:ts1] -> case unzip ts1 of
163+ { fst = as, snd = bs } -> tuple (cons t.fst as) (cons t.snd bs)
164+ [] -> tuple [] []
165+
166+-- Strings
167+
168+foreign import member "length" lengthS :: String -> Number
169+
170+foreign import charAt :: Number -> String -> String
171+
172+foreign import indexOfS :: String -> String -> Number
173+
174+foreign import lastIndexOfS :: String -> String -> Number
175+
176+foreign import localeCompare :: String -> String -> Number
177+
178+foreign import replace :: String -> String -> String -> String
179+
180+foreign import sliceS :: Number -> Number -> String -> String
181+
182+foreign import split :: String -> String -> [String]
183+
184+foreign import substr :: Number -> Number -> String -> String
185+
186+foreign import substring :: Number -> Number -> String -> String
187+
188+foreign import toLower :: String -> String
189+
190+foreign import toUpper :: String -> String
191+
192+foreign import trim :: String -> String
193+
194+-- Regex
195+
196+foreign import data Regex :: *
197+
198+foreign import regex :: String -> String -> Regex
199+
200+foreign import test :: Regex -> String -> Boolean
201+
202+foreign import match :: Regex -> String -> [String]
203+
204+foreign import replaceR :: Regex -> String -> String -> String
205+
206+foreign import search :: Regex -> String -> Number
207+
208+-- Globals
209+
210+foreign import nan :: Number
211+
212+foreign import infinity :: Number
213+
214+foreign import toExponential :: Number -> String
215+
216+foreign import toFixed :: Number -> Number -> String
217+
218+foreign import toPrecision :: Number -> Number -> String
219+
220+foreign import numberToString :: Number -> String
221+
222+foreign import isNaN :: Number -> Boolean
223+
224+foreign import isFinite :: Number -> Boolean
225+
226+foreign import parseFloat :: String -> Number
227+
228+foreign import parseInt :: String -> Number
229+
230+foreign import encodeURIComponent :: String -> String
231+
232+foreign import decodeURIComponent :: String -> String
233+
234+foreign import encodeURI :: String -> String
235+
236+foreign import decodeURI :: String -> String
237+
238+-- Math
239+
240+type Math =
241+ { abs :: Number -> Number
242+ , acos :: Number -> Number
243+ , asin :: Number -> Number
244+ , atan :: Number -> Number
245+ , atan2 :: (Number, Number) -> Number
246+ , aceil :: Number -> Number
247+ , cos :: Number -> Number
248+ , exp :: Number -> Number
249+ , floor :: Number -> Number
250+ , log :: Number -> Number
251+ , max :: (Number, Number) -> Number
252+ , pow :: (Number, Number) -> Number
253+ , random :: () -> Number
254+ , round :: Number -> Number
255+ , sin :: Number -> Number
256+ , sqrt :: Number -> Number
257+ , tan :: Number -> Number
258+ }
259+
260+foreign import math :: Math
261+
package.yamldeleted−86
@@ -1,86 +0,0 @@
1−name: psgo
2−version: 0.1.0.0
3−github: "andyarvanitis/purescript-native"
4−license: BSD3
5−author: "Andy Arvanitis"
6−maintainer: "example@example.com"
7−copyright: "2018 Andy Arvanitis"
8−
9−extra-source-files:
10−- README.md
11−- ChangeLog.md
12−- stack.yaml
13−- support/*
14−
15−# Metadata used when publishing your package
16−# synopsis: Short description of your package
17−# category: Web
18−
19−# To avoid duplicated efforts in documentation and dealing with the
20−# complications of embedding Haddock markup inside cabal files, it is
21−# common to point users to the README.md file.
22−description: Please see the README on Github at <https://github.com/andyarvanitis/purescript-native#readme>
23−
24−dependencies:
25−- base >= 4.7 && < 5
26−- bytestring >= 0.10.8.2 && < 0.11
27−- purescript
28−- base-compat >=0.6.0
29−- protolude >=0.1.6
30−- text
31−- containers
32−- filepath
33−- monad-parallel >= 0.7.2.2 && <0.8
34−- pattern-arrows >=0.0.2 && <0.1
35−- safe >=0.3.9 && <0.4
36−- transformers >=0.3.0 && <0.6
37−- mtl >=2.1.0 && <2.3.0
38−- aeson >=1.0 && <1.5
39−- directory
40−- process
41−- file-embed
42−- filemanip
43−- gitrev
44−
45−library:
46− source-dirs: src
47− default-extensions:
48− - ConstraintKinds
49− - DataKinds
50− - DeriveFunctor
51− - EmptyDataDecls
52− - FlexibleContexts
53− - KindSignatures
54− - LambdaCase
55− - MultiParamTypeClasses
56− - NoImplicitPrelude
57− - PatternGuards
58− - PatternSynonyms
59− - RankNTypes
60− - RecordWildCards
61− - OverloadedStrings
62− - ScopedTypeVariables
63− - TupleSections
64− - ViewPatterns
65−
66−executables:
67− psgo:
68− main: Main.hs
69− source-dirs: app
70− ghc-options:
71− - -threaded
72− - -rtsopts
73− - -with-rtsopts=-N
74− dependencies:
75− - psgo
76−
77−tests:
78− psgo-test:
79− main: Spec.hs
80− source-dirs: test
81− ghc-options:
82− - -threaded
83− - -rtsopts
84− - -with-rtsopts=-N
85− dependencies:
86− - psgo
psgo.cabaldeleted−145
@@ -1,145 +0,0 @@
1−cabal-version: 1.12
2−
3−-- This file has been generated from package.yaml by hpack version 0.35.0.
4−--
5−-- see: https://github.com/sol/hpack
6−
7−name: psgo
8−version: 0.1.0.0
9−description: Please see the README on Github at <https://github.com/andyarvanitis/purescript-native#readme>
10−homepage: https://github.com/andyarvanitis/purescript-native#readme
11−bug-reports: https://github.com/andyarvanitis/purescript-native/issues
12−author: Andy Arvanitis
13−maintainer: example@example.com
14−copyright: 2018 Andy Arvanitis
15−license: BSD3
16−license-file: LICENSE
17−build-type: Simple
18−extra-source-files:
19− README.md
20− ChangeLog.md
21− stack.yaml
22− support/ffi-loader.go
23− support/go.mod.ffi-loader
24− support/go.mod.output
25− support/go.mod.working
26−
27−source-repository head
28− type: git
29− location: https://github.com/andyarvanitis/purescript-native
30−
31−library
32− exposed-modules:
33− CodeGen.IL
34− CodeGen.IL.Common
35− CodeGen.IL.Optimizer
36− CodeGen.IL.Optimizer.Common
37− CodeGen.IL.Optimizer.Inliner
38− CodeGen.IL.Optimizer.MagicDo
39− CodeGen.IL.Optimizer.TCO
40− CodeGen.IL.Printer
41− Tests
42− other-modules:
43− Paths_psgo
44− hs-source-dirs:
45− src
46− default-extensions:
47− ConstraintKinds
48− DataKinds
49− DeriveFunctor
50− EmptyDataDecls
51− FlexibleContexts
52− KindSignatures
53− LambdaCase
54− MultiParamTypeClasses
55− NoImplicitPrelude
56− PatternGuards
57− PatternSynonyms
58− RankNTypes
59− RecordWildCards
60− OverloadedStrings
61− ScopedTypeVariables
62− TupleSections
63− ViewPatterns
64− build-depends:
65− aeson >=1.0 && <1.5
66− , base >=4.7 && <5
67− , base-compat >=0.6.0
68− , bytestring >=0.10.8.2 && <0.11
69− , containers
70− , directory
71− , file-embed
72− , filemanip
73− , filepath
74− , gitrev
75− , monad-parallel >=0.7.2.2 && <0.8
76− , mtl >=2.1.0 && <2.3.0
77− , pattern-arrows >=0.0.2 && <0.1
78− , process
79− , protolude >=0.1.6
80− , purescript
81− , safe >=0.3.9 && <0.4
82− , text
83− , transformers >=0.3.0 && <0.6
84− default-language: Haskell2010
85−
86−executable psgo
87− main-is: Main.hs
88− other-modules:
89− Paths_psgo
90− hs-source-dirs:
91− app
92− ghc-options: -threaded -rtsopts -with-rtsopts=-N
93− build-depends:
94− aeson >=1.0 && <1.5
95− , base >=4.7 && <5
96− , base-compat >=0.6.0
97− , bytestring >=0.10.8.2 && <0.11
98− , containers
99− , directory
100− , file-embed
101− , filemanip
102− , filepath
103− , gitrev
104− , monad-parallel >=0.7.2.2 && <0.8
105− , mtl >=2.1.0 && <2.3.0
106− , pattern-arrows >=0.0.2 && <0.1
107− , process
108− , protolude >=0.1.6
109− , psgo
110− , purescript
111− , safe >=0.3.9 && <0.4
112− , text
113− , transformers >=0.3.0 && <0.6
114− default-language: Haskell2010
115−
116−test-suite psgo-test
117− type: exitcode-stdio-1.0
118− main-is: Spec.hs
119− other-modules:
120− Paths_psgo
121− hs-source-dirs:
122− test
123− ghc-options: -threaded -rtsopts -with-rtsopts=-N
124− build-depends:
125− aeson >=1.0 && <1.5
126− , base >=4.7 && <5
127− , base-compat >=0.6.0
128− , bytestring >=0.10.8.2 && <0.11
129− , containers
130− , directory
131− , file-embed
132− , filemanip
133− , filepath
134− , gitrev
135− , monad-parallel >=0.7.2.2 && <0.8
136− , mtl >=2.1.0 && <2.3.0
137− , pattern-arrows >=0.0.2 && <0.1
138− , process
139− , protolude >=0.1.6
140− , psgo
141− , purescript
142− , safe >=0.3.9 && <0.4
143− , text
144− , transformers >=0.3.0 && <0.6
145− default-language: Haskell2010
purescript.cabalnew file+60
@@ -0,0 +1,60 @@
1+name: purescript
2+version: 0.1.10
3+cabal-version: >=1.8
4+build-type: Simple
5+license: MIT
6+license-file: LICENSE
7+copyright: (c) Phil Freeman 2013
8+maintainer: Phil Freeman <paf31@cantab.net>
9+stability: experimental
10+synopsis: PureScript Programming Language Compiler
11+description: A small compile-to-JS language with extensible records and type-safe blocks
12+category: Language
13+author: Phil Freeman <paf31@cantab.net>
14+data-dir: ""
15+
16+library
17+ build-depends: base >=4 && <5, syb -any, cmdtheline -any,
18+ containers -any, mtl -any, transformers -any, parsec -any,
19+ utf8-string -any
20+ exposed-modules: Data.Generics.Extras Language.PureScript.Operators
21+ Language.PureScript.Optimize Language.PureScript.Pretty.JS
22+ Language.PureScript.CodeGen.JS.AST Main Language.PureScript
23+ Language.PureScript.Declarations Language.PureScript.Names
24+ Language.PureScript.Types Language.PureScript.Values
25+ Language.PureScript.Kinds Language.PureScript.Pretty
26+ Language.PureScript.Pretty.Common Language.PureScript.Pretty.Values
27+ Language.PureScript.Pretty.Types Language.PureScript.Pretty.Kinds
28+ Language.PureScript.CodeGen Language.PureScript.CodeGen.Externs
29+ Language.PureScript.CodeGen.JS Language.PureScript.CodeGen.Monad
30+ Language.PureScript.Parser Language.PureScript.Parser.Common
31+ Language.PureScript.Parser.Declarations
32+ Language.PureScript.Parser.Types Language.PureScript.Parser.Values
33+ Language.PureScript.Parser.State Language.PureScript.Parser.Kinds
34+ Language.PureScript.TypeChecker
35+ Language.PureScript.TypeChecker.Kinds
36+ Language.PureScript.TypeChecker.Monad
37+ Language.PureScript.TypeChecker.Types
38+ Language.PureScript.TypeChecker.Synonyms
39+ Language.PureScript.Unknown
40+ exposed: True
41+ buildable: True
42+ hs-source-dirs: src
43+
44+executable psc
45+ build-depends: base >=4 && <5, cmdtheline -any, containers -any,
46+ mtl -any, transformers -any, parsec -any, utf8-string -any,
47+ syb -any
48+ main-is: Main.hs
49+ buildable: True
50+ hs-source-dirs: src
51+ other-modules:
52+
53+test-suite tests
54+ build-depends: base >=4 && <5, syb -any, directory -any,
55+ filepath -any, containers -any, mtl -any, transformers -any,
56+ parsec -any, utf8-string -any, purescript -any
57+ type: exitcode-stdio-1.0
58+ main-is: Main.hs
59+ buildable: True
60+ hs-source-dirs: tests
src/CodeGen/IL.hsdeleted−321
@@ -1,321 +0,0 @@
1−-- | This module generates code in the core imperative representation from
2−-- elaborated PureScript code.
3−module CodeGen.IL
4− ( module AST
5− , module Common
6− , moduleToIL
7− ) where
8−
9−import Prelude.Compat
10−import Protolude (ordNub)
11−
12−import Control.Arrow ((&&&))
13−import Control.Monad (forM, liftM, replicateM, void)
14−import Control.Monad.Supply.Class
15−
16−import Data.List ((\\), delete, intersect, nub)
17−import qualified Data.Foldable as F
18−import qualified Data.Map as M
19−import Data.Maybe (fromMaybe, isNothing, mapMaybe)
20−import Data.Monoid ((<>))
21−import Data.String (fromString)
22−import Data.Text (Text)
23−import qualified Data.Text as T
24−
25−import Language.PureScript.AST.SourcePos
26−import Language.PureScript.CoreImp.AST (AST)
27−import qualified Language.PureScript.CoreImp.AST as AST
28−import Language.PureScript.CoreFn
29−import Language.PureScript.Crash
30−import Language.PureScript.Names
31−import Language.PureScript.Options
32−import Language.PureScript.PSString (PSString, mkString)
33−import Language.PureScript.Traversals (sndM)
34−import qualified Language.PureScript.Constants as C
35−
36−import System.FilePath.Posix ((</>))
37−
38−import CodeGen.IL.Common as Common
39−import CodeGen.IL.Optimizer
40−import CodeGen.IL.Printer
41−
42−data DeclType = ModuleDecl | LetDecl | RecLetDecl deriving (Eq)
43−
44−-- | Generate code in the simplified intermediate representation for all declarations in a
45−-- module.
46−moduleToIL
47− :: forall m
48− -- . (Monad m, MonadReader Options m, MonadSupply m, MonadError MultipleErrors m)
49− . (Monad m, MonadSupply m)
50− => Module Ann
51− -> Text
52− -> m (Text, [Text], [AST], Text, Text)
53−moduleToIL (Module _ coms mn _ imps _ foreigns decls) project =
54− do
55− ilDecls <- mapM (bindToIL ModuleDecl) decls
56− optimized <- traverse (traverse (optimize modName')) ilDecls
57− let optimized' = concat optimized
58− values = annotValue <$> optimized'
59− foreigns' = moduleIdentToIL <$> foreigns
60− interface = interfaceSource modName values foreigns
61− imports = nub . concat $ importToIL <$> optimized'
62− implHeader = implHeaderSource modName imports project
63− implFooter = implFooterSource (runModuleName mn) foreigns
64− return $ (interface, foreigns', optimized', implHeader, implFooter)
65− where
66− modName = moduleNameToIL mn
67− modName' = AST.Var Nothing modName
68−
69− annotValue :: AST -> (Text, Bool)
70− annotValue (AST.Function _ (Just name) [] (AST.Block _ [AST.Return _ ret]))
71− | isLiteral ret = (name, True)
72− annotValue (AST.Function _ (Just name) [] _) = (name, False)
73− annotValue _ = error "Unexpected top-level value form"
74−
75− -- | Extracts all declaration names from a binding group.
76− getNames :: Bind Ann -> [Ident]
77− getNames (NonRec _ ident _) = [ident]
78− getNames (Rec vals) = map (snd . fst) vals
79−
80− -- | Generates IL code for a module import
81− --
82− importToIL :: AST -> [Text]
83− importToIL = AST.everything (++) modRef
84− where
85− modRef (AST.Indexer _ (AST.Var _ _) (AST.Var _ mname))
86− | not $ T.null mname = [extract mname]
87− modRef _ = []
88− extract :: Text -> Text
89− extract = T.replace "_" "." . T.dropWhileEnd (=='_')
90−
91− -- |
92− -- Generate code in the simplified intermediate representation for a declaration
93− --
94− bindToIL :: DeclType -> Bind Ann -> m [AST]
95− bindToIL dt (NonRec ann ident val) = return <$> nonRecToIL dt ann ident val
96− bindToIL dt (Rec vals) = forM vals (uncurry . uncurry $ nonRecToIL dt')
97− where
98− dt' = if dt == LetDecl then RecLetDecl else dt
99−
100− -- | Generate code in the simplified intermediate representation for a single non-recursive
101− -- declaration.
102− --
103− -- The main purpose of this function is to handle code generation for comments.
104− nonRecToIL :: DeclType -> Ann -> Ident -> Expr Ann -> m AST
105− nonRecToIL dt a i e@(extractAnn -> (_, com, _, _)) | not (null com) = do
106− -- withoutComment <- asks optionsNoComments
107− let withoutComment = False
108− if withoutComment
109− then nonRecToIL dt a i (modifyAnn removeComments e)
110− else AST.Comment Nothing com <$> nonRecToIL dt a i (modifyAnn removeComments e)
111− nonRecToIL ModuleDecl (ss, _, _, _) ident val = do
112− il <- valueToIL val
113− pure $ AST.Function Nothing (Just $ moduleIdentToIL ident) [] (AST.Block Nothing [AST.Return Nothing il])
114− nonRecToIL RecLetDecl (ss, _, _, _) ident val = do
115− ilExpr <- valueToIL val
116− pure $ AST.Assignment Nothing (AST.Var Nothing $ identToIL ident) ilExpr
117− nonRecToIL _ (ss, _, _, _) ident val = do
118− il <- valueToIL val
119− pure $ AST.VariableIntroduction Nothing (identToIL ident) (Just il)
120−
121− -- | Generate code in the simplified intermediate representation for a variable based on a
122− -- PureScript identifier.
123− var :: Ident -> AST
124− var = AST.Var Nothing . identToIL
125−
126− accessorString :: PSString -> AST -> AST
127− accessorString prop = AST.Indexer Nothing (AST.StringLiteral Nothing prop)
128−
129− -- | Generate code in the simplified intermediate representation for a value or expression.
130−
131− valueToIL :: Expr Ann -> m AST
132− valueToIL (Literal (pos, _, _, _) l) = literalToValueIL pos l
133− valueToIL (Accessor _ prop val) =
134− accessorString prop <$> valueToIL val
135− valueToIL (ObjectUpdate _ o ps) = do
136− obj <- valueToIL o
137− updates <- mapM (sndM valueToIL) ps
138− obj' <- freshName'
139− let objVar = AST.Var Nothing obj'
140− copy = AST.VariableIntroduction Nothing obj' (Just $ copyDict obj)
141− assign (k, v) = AST.Assignment Nothing (accessorString k objVar) v
142− sts = copy : (assign <$> updates) ++ [AST.Return Nothing objVar]
143− return $ AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing sts)) []
144− valueToIL (Abs _ arg val) = do
145− ret <- valueToIL val
146− let ilArg = case arg of
147− UnusedIdent -> []
148− _ -> [identToIL arg]
149− return $ AST.Function Nothing Nothing ilArg (AST.Block Nothing [AST.Return Nothing ret])
150− valueToIL e@App{} = do
151− let (f, args) = unApp e []
152− args' <- mapM valueToIL args
153− fn <- valueToIL f
154− case f of
155− Var (_, _, _, Just IsNewtype) _ -> return (head args')
156− _ -> flip (foldl (\fn a -> AST.App Nothing fn [a])) args' <$> valueToIL f
157− where
158− unApp :: Expr Ann -> [Expr Ann] -> (Expr Ann, [Expr Ann])
159− unApp (App _ val arg) args = unApp val (arg : args)
160− unApp other args = (other, args)
161− valueToIL (Var _ ident) = return $ varToIL ident
162− valueToIL (Case (ss, _, _, _) values binders) = do
163− vals <- mapM valueToIL values
164− bindersToIL ss binders vals
165− valueToIL (Let _ ds val) = do
166− let recurs = concatMap getNames $ filter isRec ds
167− recurDs = (\v -> AST.VariableIntroduction Nothing (identToIL v) Nothing) <$> recurs
168− ds' <- concat <$> mapM (bindToIL LetDecl) ds
169− ret <- valueToIL val
170− return $ AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing (recurDs ++ ds' ++ [AST.Return Nothing ret]))) []
171− where
172− isRec :: Bind Ann -> Bool
173− isRec (Rec _) = True
174− isRec _ = False
175− valueToIL (Constructor (_, _, _, Just IsNewtype) _ (ProperName ctor) _) = error "IsNewtype"
176− valueToIL (Constructor _ _ (ProperName ctor) fields) =
177− let body = AST.ObjectLiteral Nothing $ (mkString ctor, AST.BooleanLiteral Nothing True) :
178− ((\field -> (mkString (identToIL field), var field)) `map` fields)
179− fn = foldr (\f inner -> AST.Function Nothing Nothing [identToIL f] (AST.Block Nothing [AST.Return Nothing inner])) body fields
180− in return fn
181−
182−
183− iife :: Text -> [AST] -> AST
184− iife v exprs = AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing $ exprs ++ [AST.Return Nothing $ AST.Var Nothing v])) []
185−
186− literalToValueIL :: SourceSpan -> Literal (Expr Ann) -> m AST
187− literalToValueIL ss (NumericLiteral (Left i)) = return $ AST.NumericLiteral (Just ss) (Left i)
188− literalToValueIL ss (NumericLiteral (Right n)) = return $ AST.NumericLiteral (Just ss) (Right n)
189− literalToValueIL ss (StringLiteral s) = return $ AST.StringLiteral (Just ss) s
190− literalToValueIL ss (CharLiteral c) = return $ AST.StringLiteral (Just ss) (fromString [c])
191− literalToValueIL ss (BooleanLiteral b) = return $ AST.BooleanLiteral (Just ss) b
192− literalToValueIL ss (ArrayLiteral xs) = AST.ArrayLiteral (Just ss) <$> mapM valueToIL xs
193− literalToValueIL ss (ObjectLiteral ps) = AST.ObjectLiteral (Just ss) <$> mapM (sndM valueToIL) ps
194−
195− -- | Generate code in the simplified intermediate representation for a reference to a
196− -- variable.
197− varToIL :: Qualified Ident -> AST
198− varToIL (Qualified Nothing ident) = var ident
199− varToIL qual = qualifiedToIL id qual
200−
201− -- | Generate code in the simplified intermediate representation for a reference to a
202− -- variable that may have a qualified name.
203− qualifiedToIL :: (a -> Ident) -> Qualified a -> AST
204− qualifiedToIL f (Qualified (Just (ModuleName mn')) a) | mn' == C.prim = AST.Var Nothing . moduleIdentToIL $ f a
205− qualifiedToIL f (Qualified (Just mn') a) | mn /= mn' = AST.Indexer Nothing (AST.Var Nothing . moduleIdentToIL $ f a) (AST.Var Nothing (moduleNameToIL mn'))
206− qualifiedToIL f (Qualified _ a) = AST.Indexer Nothing (AST.Var Nothing . moduleIdentToIL $ f a) (AST.Var Nothing "")
207−
208− -- foreignIdent :: Ident -> AST
209− -- foreignIdent ident = accessorString (mkString $ runIdent ident) (AST.Var Nothing "$foreign")
210−
211− -- | Generate code in the simplified intermediate representation for pattern match binders
212− -- and guards.
213− bindersToIL :: SourceSpan -> [CaseAlternative Ann] -> [AST] -> m AST
214− bindersToIL ss binders vals = do
215− valNames <- replicateM (length vals) freshName'
216− let assignments = zipWith (AST.VariableIntroduction Nothing) valNames (map Just vals)
217− ils <- forM binders $ \(CaseAlternative bs result) -> do
218− ret <- guardsToIL result
219− go valNames ret bs
220− return $ AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing (assignments ++ concat ils ++ [AST.Throw Nothing (AST.StringLiteral Nothing $ mkString failedPatternMessage)])))
221− []
222− where
223− go :: [Text] -> [AST] -> [Binder Ann] -> m [AST]
224− go _ done [] = return done
225− go (v:vs) done' (b:bs) = do
226− done'' <- go vs done' bs
227− binderToIL v done'' b
228− go _ _ _ = internalError "Invalid arguments to bindersToIL"
229−
230− failedPatternMessage :: Text
231− failedPatternMessage = "Failed pattern match at " <> runModuleName mn <> " " <> displayStartEndPos ss
232−
233− guardsToIL :: Either [(Guard Ann, Expr Ann)] (Expr Ann) -> m [AST]
234− guardsToIL (Left gs) = traverse genGuard gs where
235− genGuard (cond, val) = do
236− cond' <- valueToIL cond
237− val' <- valueToIL val
238− return
239− (AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo cond' (AST.BooleanLiteral Nothing True))
240− (AST.Block Nothing [AST.Return Nothing val']) Nothing)
241−
242− guardsToIL (Right v) = return . AST.Return Nothing <$> valueToIL v
243−
244− -- | Generate code in the simplified intermediate representation for a pattern match
245− -- binder.
246− binderToIL :: Text -> [AST] -> Binder Ann -> m [AST]
247− binderToIL _ done NullBinder{} = return done
248− binderToIL varName done (LiteralBinder _ l) =
249− literalToBinderIL varName done l
250− binderToIL varName done (VarBinder _ ident) =
251− return (AST.VariableIntroduction Nothing (identToIL ident) (Just (AST.Var Nothing varName)) : done)
252− binderToIL varName done (ConstructorBinder (_, _, _, Just IsNewtype) _ _ [b]) =
253− binderToIL varName done b
254− binderToIL varName done (ConstructorBinder (_, _, _, Just (IsConstructor ctorType fields)) _ (Qualified _ (ProperName ctor)) bs) = do
255− il <- go (zip fields bs) done
256− return $ case ctorType of
257− ProductType -> il
258− SumType ->
259− [AST.IfElse Nothing (AST.InstanceOf Nothing (AST.Var Nothing varName) (AST.StringLiteral Nothing (mkString ctor)))
260− (AST.Block Nothing il)
261− Nothing]
262− where
263− go :: [(Ident, Binder Ann)] -> [AST] -> m [AST]
264− go [] done' = return done'
265− go ((field, binder) : remain) done' = do
266− argVar <- freshName'
267− done'' <- go remain done'
268− il <- binderToIL argVar done'' binder
269− return (AST.VariableIntroduction Nothing argVar (Just $ accessorString (mkString $ identToIL field) $ AST.Var Nothing varName) : il)
270−
271− binderToIL _ _ ConstructorBinder{} =
272− internalError "binderToIL: Invalid ConstructorBinder in binderToIL"
273− binderToIL varName done (NamedBinder _ ident binder) = do
274− il <- binderToIL varName done binder
275− return (AST.VariableIntroduction Nothing (identToIL ident) (Just (AST.Var Nothing varName)) : il)
276−
277− literalToBinderIL :: Text -> [AST] -> Literal (Binder Ann) -> m [AST]
278− literalToBinderIL varName done (NumericLiteral num) =
279− return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.NumericLiteral Nothing num)) (AST.Block Nothing done) Nothing]
280− literalToBinderIL varName done (CharLiteral c) =
281− return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.StringLiteral Nothing (fromString [c]))) (AST.Block Nothing done) Nothing]
282− literalToBinderIL varName done (StringLiteral str) =
283− return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.StringLiteral Nothing str)) (AST.Block Nothing done) Nothing]
284− literalToBinderIL varName done (BooleanLiteral True) =
285− return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.BooleanLiteral Nothing True)) (AST.Block Nothing done) Nothing]
286− literalToBinderIL varName done (BooleanLiteral False) =
287− return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.BooleanLiteral Nothing False)) (AST.Block Nothing done) Nothing]
288− -- return [AST.IfElse Nothing (AST.Unary Nothing AST.Not (AST.Var Nothing varName)) (AST.Block Nothing done) Nothing]
289− literalToBinderIL varName done (ObjectLiteral bs) = go done bs
290− where
291− go :: [AST] -> [(PSString, Binder Ann)] -> m [AST]
292− go done' [] = return done'
293− go done' ((prop, binder):bs') = do
294− propVar <- freshName'
295− done'' <- go done' bs'
296− il <- binderToIL propVar done'' binder
297− return (AST.VariableIntroduction Nothing propVar (Just (accessorString prop (AST.Var Nothing varName))) : il)
298− literalToBinderIL varName done (ArrayLiteral bs) = do
299− il <- go done 0 bs
300− return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo
301− (arrayLength $ AST.Var Nothing varName)
302− (AST.NumericLiteral Nothing (Left (fromIntegral $ length bs))))
303− (AST.Block Nothing il) Nothing]
304− where
305− go :: [AST] -> Integer -> [Binder Ann] -> m [AST]
306− go done' _ [] = return done'
307− go done' index (binder:bs') = do
308− elVar <- freshName'
309− done'' <- go done' (index + 1) bs'
310− il <- binderToIL elVar done'' binder
311− return (AST.VariableIntroduction Nothing elVar (Just (AST.Indexer Nothing (AST.NumericLiteral Nothing (Left index)) (AST.Var Nothing varName))) : il)
312−
313−emptyAnn :: Ann
314−emptyAnn = (SourceSpan "" (SourcePos 0 0) (SourcePos 0 0), [], Nothing, Nothing)
315−
316−arrayLength :: AST -> AST
317−arrayLength a = AST.App Nothing (AST.Var Nothing arrayLengthFn) [a]
318−-- arrayLength a = AST.Var Nothing (arrayLengthFn <> "(" <> prettyPrintIL1 a <> ")")
319−
320−copyDict :: AST -> AST
321−copyDict a = AST.App Nothing (AST.Var Nothing copyDictFn) [a]
src/CodeGen/IL/Common.hsdeleted−196
@@ -1,196 +0,0 @@
1−-- | Common code generation utility functions
2−module CodeGen.IL.Common where
3−
4−import Prelude.Compat
5−
6−import Control.Monad.Supply.Class (MonadSupply, freshName)
7−import Data.Char
8−import Data.Maybe (maybe)
9−import Data.Monoid ((<>))
10−import Data.Text (Text)
11−import qualified Data.Text as T
12−
13−import Language.PureScript.Crash
14−import Language.PureScript.Names
15−
16−import qualified Language.PureScript.Constants as C
17−
18−moduleNameToIL :: ModuleName -> Text
19−moduleNameToIL (ModuleName mn) =
20− let name = T.replace "." "_" mn
21− in if nameIsILBuiltIn name then (name <> moduleRenamerMarker) else name
22−
23−moduleNameToIL' :: ModuleName -> Text
24−moduleNameToIL' (ModuleName mn) = T.replace "_" "." mn
25−
26−-- | Convert an 'Ident' into a valid IL identifier:
27−--
28−-- * Alphanumeric characters are kept unmodified.
29−--
30−-- * Reserved IL identifiers are wrapped with '_'.
31−--
32−identToIL :: Ident -> Text
33−identToIL UnusedIdent = unusedName
34−identToIL (Ident "$__unused") = unusedName
35−identToIL (Ident name) | name == C.undefined = undefinedName -- Note: done in Printer.hs too
36−identToIL (Ident name) = properToIL name
37−identToIL (GenIdent _ _) = internalError "GenIdent in identToIL"
38−
39−moduleIdentToIL :: Ident -> Text
40−moduleIdentToIL UnusedIdent = unusedName
41−moduleIdentToIL (Ident name) | name == C.undefined = undefinedName
42−moduleIdentToIL (Ident name) = moduleProperToIL name
43−moduleIdentToIL (GenIdent _ _) = internalError "GenIdent in identToIL"
44−
45−undefinedName :: Text
46−undefinedName = "Undefined"
47−
48−unusedName :: Text
49−unusedName = "_"
50−
51−properToIL :: Text -> Text
52−properToIL name
53− | nameIsILReserved name = "ˉ" <> name
54− | otherwise = T.concatMap identCharToText name
55−
56−-- | Attempts to find a human-readable name for a symbol, if none has been specified returns the
57−-- ordinal value.
58−identCharToText :: Char -> Text
59−identCharToText 'ṩ' = "_ṩ"
60−identCharToText c | isAlphaNum c = T.singleton c
61−identCharToText '_' = "_"
62−identCharToText '\'' = "ꞌ" -- lowercase saltillo
63−identCharToText c = error (show (ord c)) -- TODO: should never occur now(?)
64−
65−moduleProperToIL :: Text -> Text
66−moduleProperToIL = T.concatMap identCharToText
67−
68−-- | Checks whether an identifier name is reserved in IL.
69−nameIsILReserved :: Text -> Bool
70−nameIsILReserved name =
71− name `elem` ilAnyReserved
72−
73−-- | Checks whether a name matches a built-in value in IL.
74−nameIsILBuiltIn :: Text -> Bool
75−nameIsILBuiltIn name =
76− name `elem`
77− [ "Any"
78− , "Apply"
79− , "Contains"
80− , "CopyDict"
81− , "Dict"
82− , "EffFn"
83− , "Fn"
84− , "Foreign"
85− , "Get"
86− , "Index"
87− , "Is"
88− , "Length"
89− , "Once"
90− , "Run"
91− , "Undefined"
92− ]
93−
94−ilAnyReserved :: [Text]
95−ilAnyReserved =
96− concat
97− [ ilKeywords
98− , ilLiterals
99− ]
100−
101−ilKeywords :: [Text]
102−ilKeywords =
103− [ "break"
104− , "case"
105− , "chan"
106− , "const"
107− , "continue"
108− , "default"
109− , "defer"
110− , "else"
111− , "fallthrough"
112− , "for"
113− , "func"
114− , "go"
115− , "goto"
116− , "if"
117− , "import"
118− , "interface"
119− , "map"
120− , "package"
121− , "range"
122− , "return"
123− , "select"
124− , "struct"
125− , "switch"
126− , "type"
127− , "var"
128− ]
129−
130−ilLiterals :: [Text]
131−ilLiterals =
132− [ "init"
133− , "nil"
134− , "int"
135− , "int8"
136− , "int16"
137− , "int32"
138− , "int64"
139− , "uint"
140− , "uint8"
141− , "uint16"
142− , "uint32"
143− , "uint64"
144− , "uintptr"
145− , "float32"
146− , "float64"
147− , "complex64"
148− , "complex128"
149− , "byte"
150− , "rune"
151− , "string"
152− ]
153−
154−withPrefix :: Text -> Text
155−withPrefix s = "Ꞌ" <> s -- uppercase saltillo
156−
157−anyType :: Text
158−anyType = "Any"
159−
160−dictType :: Text
161−dictType = "Dict"
162−
163−arrayType :: Text
164−arrayType = "[]" <> anyType
165−
166−uncurriedFnType :: Int -> Text
167−uncurriedFnType i = "Fn" <> (T.pack . show $ i)
168−
169−int :: Text
170−int = "int"
171−
172−float :: Text
173−float = "float64"
174−
175−bool :: Text
176−bool = "bool"
177−
178−string :: Text
179−string = "string"
180−
181−arrayLengthFn :: Text
182−arrayLengthFn = "Length"
183−
184−indexFn :: Text
185−indexFn = "Index"
186−
187−copyDictFn :: Text
188−copyDictFn = "CopyDict"
189−
190−freshName' :: MonadSupply m => m Text
191−freshName' = do
192− name <- freshName
193− return $ T.replace "$" "ṩ" name
194−
195−moduleRenamerMarker :: Text
196−moduleRenamerMarker = "__"
src/CodeGen/IL/Optimizer.hsdeleted−81
@@ -1,81 +0,0 @@
1−-- | This module optimizes code in the intermediate representation.
2−module CodeGen.IL.Optimizer (optimize) where
3−
4−import Prelude.Compat
5−
6−import Control.Monad.Supply.Class (MonadSupply)
7−import Data.Text (Text)
8−import Language.PureScript.CoreImp.AST
9−import Language.PureScript.CoreImp.Optimizer.Blocks
10−import Language.PureScript.CoreImp.Optimizer.Common hiding (isDict)
11−import Language.PureScript.CoreImp.Optimizer.Inliner (etaConvert, evaluateIifes, inlineVariables, unThunk)
12−import Language.PureScript.CoreImp.Optimizer.Unused
13−
14−import CodeGen.IL.Common (unusedName)
15−import CodeGen.IL.Optimizer.Inliner
16−import CodeGen.IL.Optimizer.MagicDo
17−import CodeGen.IL.Optimizer.TCO
18−
19−import qualified Language.PureScript.Constants as C
20−
21−-- | Apply a series of optimizer passes to simplified IL code
22−optimize :: MonadSupply m => AST -> AST -> m AST
23−optimize mn il = do
24− il' <- untilFixedPoint (inlineFnComposition . inlineUnsafeCoerce . inlineUnsafePartial . tidyUp) il
25− il'' <- untilFixedPoint (return . ignoreUnusedResults . inlineCommonValues . inlineCommonOperators . tidyUp) . tco mn . inlineST
26− =<< untilFixedPoint (return . magicDoST)
27− =<< untilFixedPoint (return . magicDoEff)
28− =<< untilFixedPoint (return . magicDoEffect) il'
29− untilFixedPoint (return . collapseVarDeclarations) il''
30− where
31− tidyUp :: AST -> AST
32− tidyUp = applyAll
33− [ collapseNestedBlocks
34− , collapseNestedIfs
35− , collapseIfChecks
36− , removeCodeAfterReturnStatements
37− , unThunk
38− , etaConvert
39− , evaluateIifes
40− , inlineVariables
41− ]
42−
43−untilFixedPoint :: (Monad m, Eq a) => (a -> m a) -> a -> m a
44−untilFixedPoint f = go
45− where
46− go a = do
47− a' <- f a
48− if a' == a then return a' else go a'
49−
50−collapseIfChecks :: AST -> AST
51−collapseIfChecks = everywhere collapse where
52− collapse :: AST -> AST
53− collapse (IfElse _ (Binary _ EqualTo (BooleanLiteral _ True) (BooleanLiteral _ True)) (Block _ [exprs]) _) = exprs
54− collapse (IfElse _ (Binary _ EqualTo (Indexer _ (Var _ prop) (Var _ val)) (BooleanLiteral _ True)) (Block _ [exprs]) _)
55− | prop == "otherwise" && val == "Data_Boolean" = exprs
56− collapse exprs = exprs
57−
58−collapseVarDeclarations :: AST -> AST
59−collapseVarDeclarations = everywhere collapse where
60− collapse :: AST -> AST
61− collapse (Block ss sts) = Block ss (go Nothing sts)
62− collapse s = s
63−
64− go :: Maybe Text -> [AST] -> [AST]
65− go _ [] = []
66− go Nothing (decl@(VariableIntroduction _ var (Just _)) : sts) = decl : go (Just var) (go Nothing sts)
67− go (Just var') ((VariableIntroduction ss var (Just val)) : sts)
68− | var == var' = (Assignment ss (Var Nothing var) val) : go (Just var') sts
69− go var' (s:sts) = s : go var' sts
70−
71−ignoreUnusedResults :: AST -> AST
72−ignoreUnusedResults = everywhere $ removeFromBlock go
73− where
74− go :: [AST] -> [AST]
75− go [] = []
76− go (VariableIntroduction ss var (Just s) : sts)
77− | not $ any (everything (||) (isUsed var)) sts = sts'
78− where
79− sts' | App{} <- s = s : (go sts)
80− | otherwise = go sts
81− go (s:sts) = s : go sts
src/CodeGen/IL/Optimizer/Common.hsdeleted−18
@@ -1,18 +0,0 @@
1−-- | Common functions used by the various optimizer phases
2−module CodeGen.IL.Optimizer.Common where
3−
4−import Prelude.Compat
5−
6−import Data.Text (Text)
7−
8−import Language.PureScript.CoreImp.AST
9−import Language.PureScript.PSString (PSString, decodeString)
10−
11−isDict :: (Text, PSString) -> AST -> Bool
12−isDict (moduleName, dictName) (Indexer _ (Var _ x) (Var _ y)) =
13− Just x == decodeString dictName && y == moduleName
14−isDict _ _ = False
15−
16−isDict' :: [(Text, PSString)] -> AST -> Bool
17−isDict' xs il = any (`isDict` il) xs
18−
src/CodeGen/IL/Optimizer/Inliner.hsdeleted−435
@@ -1,435 +0,0 @@
1−-- | This module performs basic inlining of known functions
2−module CodeGen.IL.Optimizer.Inliner
3− ( inlineCommonValues
4− , inlineCommonOperators
5− , inlineFnComposition
6− , inlineUnsafeCoerce
7− , inlineUnsafePartial
8− ) where
9−
10−import Prelude.Compat
11−
12−import Control.Monad.Supply.Class (MonadSupply)
13−
14−import Data.Either (rights)
15−import Data.Maybe (fromMaybe)
16−import Data.String (IsString, fromString)
17−import Data.Text (Text)
18−import qualified Data.Text as T
19−
20−import Language.PureScript.PSString (PSString, decodeString, mkString)
21−import Language.PureScript.CoreImp.AST
22−import Language.PureScript.CoreImp.Optimizer.Common hiding (isDict, isDict')
23−import Language.PureScript.AST (SourceSpan(..))
24−import qualified Language.PureScript.Constants as C
25−
26−import CodeGen.IL.Common
27−import CodeGen.IL.Optimizer.Common
28−
29−-- TODO: Potential bug:
30−-- Shouldn't just inline this case: { var x = 0; x.toFixed(10); }
31−-- Needs to be: { 0..toFixed(10); }
32−-- Probably needs to be fixed in pretty-printer instead.
33−shouldInline :: AST -> Bool
34−shouldInline (Var _ _) = True
35−shouldInline (NumericLiteral _ _) = True
36−shouldInline (StringLiteral _ _) = True
37−shouldInline (BooleanLiteral _ _) = True
38−shouldInline (Indexer _ index val) = shouldInline index && shouldInline val
39−shouldInline _ = False
40−
41−inlineCommonValues :: AST -> AST
42−inlineCommonValues = everywhere convert
43− where
44− convert :: AST -> AST
45− convert (App ss fn [dict])
46− | isDict' [semiringNumber, semiringInt] dict && isDict fnZero fn = NumericLiteral ss (Left 0)
47− | isDict' [semiringNumber, semiringInt] dict && isDict fnOne fn = NumericLiteral ss (Left 1)
48− | isDict boundedBoolean dict && isDict fnBottom fn = BooleanLiteral ss False
49− | isDict boundedBoolean dict && isDict fnTop fn = BooleanLiteral ss True
50− convert (App ss (App _ fn [dict]) [x])
51− | isDict ringInt dict && isDict fnNegate fn = Unary ss Negate (unbox x $ snd ringInt)
52− convert (App ss (App _ (App _ fn [dict]) [x]) [y])
53− | isDict semiringInt dict && isDict fnAdd fn = intOp ss Add semiringInt x y
54− | isDict semiringInt dict && isDict fnMultiply fn = intOp ss Multiply semiringInt x y
55− | isDict ringInt dict && isDict fnSubtract fn = intOp ss Subtract ringInt x y
56− convert other = other
57− fnZero = (C.dataSemiring, C.zero)
58− fnOne = (C.dataSemiring, C.one)
59− fnBottom = (C.dataBounded, C.bottom)
60− fnTop = (C.dataBounded, C.top)
61− fnAdd = (C.dataSemiring, C.add)
62− fnMultiply = (C.dataSemiring, C.mul)
63− fnSubtract = (C.dataRing, C.sub)
64− fnNegate = (C.dataRing, C.negate)
65− intOp ss op (_, d) x y = Binary ss op (unbox x d) (unbox y d)
66−
67−inlineCommonOperators :: AST -> AST
68−inlineCommonOperators = everywhereTopDown $ applyAll $
69− [ binary semiringNumber opAdd Add
70− , binary semiringNumber opMul Multiply
71−
72− , binary ringNumber opSub Subtract
73− , unary ringNumber opNegate Negate
74−
75− , binary euclideanRingNumber opDiv Divide
76−
77− -- , binary eqNumber opEq EqualTo
78− -- , binary eqNumber opNotEq NotEqualTo
79− , binary eqInt opEq EqualTo
80− , binary eqInt opNotEq NotEqualTo
81− , binary eqString opEq EqualTo
82− , binary eqString opNotEq NotEqualTo
83− , binary eqChar opEq EqualTo
84− , binary eqChar opNotEq NotEqualTo
85− , binary eqBoolean opEq EqualTo
86− , binary eqBoolean opNotEq NotEqualTo
87−
88− , binary ordBoolean opLessThan LessThan
89− , binary ordBoolean opLessThanOrEq LessThanOrEqualTo
90− , binary ordBoolean opGreaterThan GreaterThan
91− , binary ordBoolean opGreaterThanOrEq GreaterThanOrEqualTo
92− , binary ordChar opLessThan LessThan
93− , binary ordChar opLessThanOrEq LessThanOrEqualTo
94− , binary ordChar opGreaterThan GreaterThan
95− , binary ordChar opGreaterThanOrEq GreaterThanOrEqualTo
96− , binary ordInt opLessThan LessThan
97− , binary ordInt opLessThanOrEq LessThanOrEqualTo
98− , binary ordInt opGreaterThan GreaterThan
99− , binary ordInt opGreaterThanOrEq GreaterThanOrEqualTo
100− , binary ordNumber opLessThan LessThan
101− , binary ordNumber opLessThanOrEq LessThanOrEqualTo
102− , binary ordNumber opGreaterThan GreaterThan
103− , binary ordNumber opGreaterThanOrEq GreaterThanOrEqualTo
104− , binary ordString opLessThan LessThan
105− , binary ordString opLessThanOrEq LessThanOrEqualTo
106− , binary ordString opGreaterThan GreaterThan
107− , binary ordString opGreaterThanOrEq GreaterThanOrEqualTo
108−
109− , binary semigroupString opAppend Add
110−
111− , binary heytingAlgebraBoolean opConj And
112− , binary heytingAlgebraBoolean opDisj Or
113− , unary heytingAlgebraBoolean opNot Not
114−
115− , binary' C.dataIntBits C.or BitwiseOr
116− , binary' C.dataIntBits C.and BitwiseAnd
117− , binary' C.dataIntBits C.xor BitwiseXor
118− , binary' C.dataIntBits C.shl ShiftLeft
119− , binary' C.dataIntBits C.shr ShiftRight
120− , unary' C.dataIntBits C.complement BitwiseNot
121−
122− , inlineNonClassFunction (isModFn (C.dataFunction, C.apply)) $ \f x -> App Nothing f [x]
123− , inlineNonClassFunction (isModFn (C.dataFunction, C.applyFlipped)) $ \x f -> App Nothing f [x]
124− , inlineUnsafeIndex (isModFnWithDict (C.dataArray, C.unsafeIndex)) $ flip (Indexer Nothing)
125− ] ++
126− [ fn | i <- [0..10], fn <- [ mkFn i, runFn i ] ] ++
127− [ fn | i <- [0..10], fn <- [ mkEffFn C.controlMonadEffUncurried C.mkEffFn i, runEffFn C.controlMonadEffUncurried C.runEffFn i ] ] ++
128− [ fn | i <- [0..10], fn <- [ mkEffFn C.effectUncurried C.mkEffectFn i, runEffFn C.effectUncurried C.runEffectFn i ] ]
129− where
130− binary :: (Text, PSString) -> (Text, PSString) -> BinaryOperator -> AST -> AST
131− binary dict@(_, d) fns op = convert where
132− convert :: AST -> AST
133− convert (App ss (App _ (App _ fn [dict']) [x]) [y])
134− | isDict dict dict' && isDict fns fn = Binary ss op (unbox x d) (unbox y d)
135− convert other = other
136− binary' :: Text -> PSString -> BinaryOperator -> AST -> AST
137− binary' moduleName opString op = convert where
138− convert :: AST -> AST
139− convert (App ss (App _ fn [x]) [y]) | isDict (moduleName, opString) fn = Binary ss op (unbox x mn) (unbox y mn)
140− convert other = other
141− mn :: PSString
142− mn = mkString moduleName
143− unary :: (Text, PSString) -> (Text, PSString) -> UnaryOperator -> AST -> AST
144− unary dicts@(_, d) fns op = convert where
145− convert :: AST -> AST
146− convert (App ss (App _ fn [dict']) [x]) | isDict dicts dict' && isDict fns fn = Unary ss op (unbox x d)
147− convert other = other
148− unary' :: Text -> PSString -> UnaryOperator -> AST -> AST
149− unary' moduleName fnName op = convert where
150− convert :: AST -> AST
151− convert (App ss fn [x]) | isDict (moduleName, fnName) fn = Unary ss op (unbox x fnName)
152− convert other = other
153−
154− mkFn :: Int -> AST -> AST
155− mkFn = mkFn' C.dataFunctionUncurried C.mkFn $ \ss1 ss2 ss3 args il ->
156− Function ss1 Nothing args (Block ss2 [Return ss3 il])
157−
158− mkEffFn :: Text -> Text -> Int -> AST -> AST
159− mkEffFn modName fnName = mkFn' modName fnName $ \ss1 ss2 ss3 args il ->
160− Function ss1 Nothing args (Block ss2 [Return ss3 (App ss3 il [])])
161−
162− mkFn' :: Text -> Text -> (Maybe SourceSpan -> Maybe SourceSpan -> Maybe SourceSpan -> [Text] -> AST -> AST) -> Int -> AST -> AST
163− mkFn' modName fnName res 0 = convert where
164− convert :: AST -> AST
165− convert (App _ mkFnN [Function s1 Nothing [_] (Block s2 [Return s3 il])]) | isNFn modName fnName 0 mkFnN =
166− res s1 s2 s3 [] il
167− convert other = other
168− mkFn' modName fnName res n = convert where
169− convert :: AST -> AST
170− convert orig@(App ss mkFnN [fn]) | isNFn modName fnName n mkFnN =
171− case collectArgs n [] fn of
172− Just (args, [Return ss' ret]) -> res ss ss ss' args ret
173− _ -> orig
174− convert other = other
175− collectArgs :: Int -> [Text] -> AST -> Maybe ([Text], [AST])
176− collectArgs 1 acc (Function _ Nothing [oneArg] (Block _ il)) | length acc == n - 1 = Just (reverse (oneArg : acc), il)
177− collectArgs m acc (Function _ Nothing [oneArg] (Block _ [Return _ ret])) = collectArgs (m - 1) (oneArg : acc) ret
178− collectArgs _ _ _ = Nothing
179−
180− isNFn :: Text -> Text -> Int -> AST -> Bool
181− isNFn expectMod prefix n (Indexer _ (Var _ name) (Var _ modName)) | modName == expectMod =
182− name == fromString (T.unpack prefix <> show n)
183− isNFn _ _ _ _ = False
184−
185− runFn :: Int -> AST -> AST
186− runFn = runFn' C.dataFunctionUncurried C.runFn (\ss f args ->
187− let len = length args
188− typ = mkString $ uncurriedFnType len in
189− if len > 0
190− then App ss (App Nothing (StringLiteral Nothing typ) [f]) args
191− else App ss f args)
192− runEffFn :: Text -> Text -> Int -> AST -> AST
193− runEffFn modName fnName = runFn' modName fnName $ \ss fn acc ->
194− let typ = mkString . uncurriedFnType $ length acc in
195− Function ss Nothing [] (Block ss [Return ss (App ss (App Nothing (StringLiteral Nothing typ) [fn]) acc)])
196−
197− runFn' :: Text -> Text -> (Maybe SourceSpan -> AST -> [AST] -> AST) -> Int -> AST -> AST
198− runFn' modName runFnName res n = convert where
199− convert :: AST -> AST
200− convert il = fromMaybe il $ go n [] il
201−
202− go :: Int -> [AST] -> AST -> Maybe AST
203− go 0 acc (App ss runFnN [fn]) | isNFn modName runFnName n runFnN && length acc == n =
204− Just $ res ss fn acc
205− go m acc (App _ lhs [arg]) = go (m - 1) (arg : acc) lhs
206− go _ _ _ = Nothing
207−
208− inlineNonClassFunction :: (AST -> Bool) -> (AST -> AST -> AST) -> AST -> AST
209− inlineNonClassFunction p f = convert where
210− convert :: AST -> AST
211− convert (App _ (App _ op' [x]) [y]) | p op' = f x y
212− convert other = other
213−
214− inlineUnsafeIndex :: (AST -> Bool) -> (AST -> AST -> AST) -> AST -> AST
215− inlineUnsafeIndex p _ = convert where
216− convert :: AST -> AST
217− convert (App _ (App ss op' [x]) [y@NumericLiteral{}])
218− | p op' = Indexer ss y x
219− convert (App _ (App ss op' [x]) [y])
220− | p op' = App ss (Var Nothing indexFn) [x, y]
221− convert other = other
222−
223− isModFn :: (Text, PSString) -> AST -> Bool
224− isModFn (m, op) (Indexer _ (Var _ op') (Var _ m')) =
225− m == m' && decodeString op == Just op'
226− isModFn _ _ = False
227−
228− isModFnWithDict :: (Text, PSString) -> AST -> Bool
229− isModFnWithDict (m, op) (App _ (Indexer _ (Var _ op') (Var _ m')) [Var _ _]) =
230− m == m' && decodeString op == Just op'
231− isModFnWithDict _ _ = False
232−
233−-- (f <<< g $ x) = f (g x)
234−-- (f <<< g) = \x -> f (g x)
235−inlineFnComposition :: forall m. MonadSupply m => AST -> m AST
236−inlineFnComposition = everywhereTopDownM convert where
237− convert :: AST -> m AST
238− convert (App s1 (App s2 (App _ (App _ fn [dict']) [x]) [y]) [z])
239− | isFnCompose dict' fn = return $ App s1 x [App s2 y [z]]
240− | isFnComposeFlipped dict' fn = return $ App s2 y [App s1 x [z]]
241− convert app@(App ss (App _ (App _ fn [dict']) _) _)
242− | isFnCompose dict' fn || isFnComposeFlipped dict' fn = mkApps ss <$> goApps app <*> freshName'
243− convert other = return other
244−
245− mkApps :: Maybe SourceSpan -> [Either AST (Text, AST)] -> Text -> AST
246− mkApps ss fns a = App ss (Function ss Nothing [] (Block ss $ vars <> [Return Nothing comp])) []
247− where
248− vars = uncurry (VariableIntroduction ss) . fmap Just <$> rights fns
249− comp = Function ss Nothing [a] (Block ss [Return Nothing apps])
250− apps = foldr (\fn acc -> App ss (mkApp fn) [acc]) (Var ss a) fns
251−
252− mkApp :: Either AST (Text, AST) -> AST
253− mkApp = either id $ \(name, arg) -> Var (getSourceSpan arg) name
254−
255− goApps :: AST -> m [Either AST (Text, AST)]
256− goApps (App _ (App _ (App _ fn [dict']) [x]) [y])
257− | isFnCompose dict' fn = mappend <$> goApps x <*> goApps y
258− | isFnComposeFlipped dict' fn = mappend <$> goApps y <*> goApps x
259− goApps app@(App {}) = pure . Right . (,app) <$> freshName'
260− goApps other = pure [Left other]
261−
262− isFnCompose :: AST -> AST -> Bool
263− isFnCompose dict' fn = isDict semigroupoidFn dict' && isDict fnCompose fn
264−
265− isFnComposeFlipped :: AST -> AST -> Bool
266− isFnComposeFlipped dict' fn = isDict semigroupoidFn dict' && isDict fnComposeFlipped fn
267−
268− fnCompose :: forall a b. (IsString a, IsString b) => (a, b)
269− fnCompose = (C.controlSemigroupoid, C.compose)
270−
271− fnComposeFlipped :: forall a b. (IsString a, IsString b) => (a, b)
272− fnComposeFlipped = (C.controlSemigroupoid, C.composeFlipped)
273−
274−inlineUnsafeCoerce :: AST -> AST
275−inlineUnsafeCoerce = everywhereTopDown convert where
276− convert (App _ (Indexer _ (Var _ unsafeCoerceFn) (Var _ unsafeCoerce)) [ comp ])
277− | unsafeCoerceFn == C.unsafeCoerceFn && unsafeCoerce == C.unsafeCoerce
278− = comp
279− convert other = other
280−
281−inlineUnsafePartial :: AST -> AST
282−inlineUnsafePartial = everywhereTopDown convert where
283− convert (App ss fn [ comp ])
284− | isDict fnUnsafePartial fn
285− = App ss comp []
286− where
287− fnUnsafePartial :: forall a b. (IsString a, IsString b) => (a, b)
288− fnUnsafePartial = (C.partialUnsafe, C.unsafePartial)
289− convert other = other
290−
291−semiringNumber :: forall a b. (IsString a, IsString b) => (a, b)
292−semiringNumber = (C.dataSemiring, C.semiringNumber)
293−
294−semiringInt :: forall a b. (IsString a, IsString b) => (a, b)
295−semiringInt = (C.dataSemiring, C.semiringInt)
296−
297−ringNumber :: forall a b. (IsString a, IsString b) => (a, b)
298−ringNumber = (C.dataRing, C.ringNumber)
299−
300−ringInt :: forall a b. (IsString a, IsString b) => (a, b)
301−ringInt = (C.dataRing, C.ringInt)
302−
303−euclideanRingNumber :: forall a b. (IsString a, IsString b) => (a, b)
304−euclideanRingNumber = (C.dataEuclideanRing, C.euclideanRingNumber)
305−
306−-- eqNumber :: forall a b. (IsString a, IsString b) => (a, b)
307−-- eqNumber = (C.dataEq, C.eqNumber)
308−
309−eqInt :: forall a b. (IsString a, IsString b) => (a, b)
310−eqInt = (C.dataEq, C.eqInt)
311−
312−eqString :: forall a b. (IsString a, IsString b) => (a, b)
313−eqString = (C.dataEq, C.eqString)
314−
315−eqChar :: forall a b. (IsString a, IsString b) => (a, b)
316−eqChar = (C.dataEq, C.eqChar)
317−
318−eqBoolean :: forall a b. (IsString a, IsString b) => (a, b)
319−eqBoolean = (C.dataEq, C.eqBoolean)
320−
321−ordBoolean :: forall a b. (IsString a, IsString b) => (a, b)
322−ordBoolean = (C.dataOrd, C.ordBoolean)
323−
324−ordNumber :: forall a b. (IsString a, IsString b) => (a, b)
325−ordNumber = (C.dataOrd, C.ordNumber)
326−
327−ordInt :: forall a b. (IsString a, IsString b) => (a, b)
328−ordInt = (C.dataOrd, C.ordInt)
329−
330−ordString :: forall a b. (IsString a, IsString b) => (a, b)
331−ordString = (C.dataOrd, C.ordString)
332−
333−ordChar :: forall a b. (IsString a, IsString b) => (a, b)
334−ordChar = (C.dataOrd, C.ordChar)
335−
336−semigroupString :: forall a b. (IsString a, IsString b) => (a, b)
337−semigroupString = (C.dataSemigroup, C.semigroupString)
338−
339−boundedBoolean :: forall a b. (IsString a, IsString b) => (a, b)
340−boundedBoolean = (C.dataBounded, C.boundedBoolean)
341−
342−heytingAlgebraBoolean :: forall a b. (IsString a, IsString b) => (a, b)
343−heytingAlgebraBoolean = (C.dataHeytingAlgebra, C.heytingAlgebraBoolean)
344−
345−semigroupoidFn :: forall a b. (IsString a, IsString b) => (a, b)
346−semigroupoidFn = (C.controlSemigroupoid, C.semigroupoidFn)
347−
348−opAdd :: forall a b. (IsString a, IsString b) => (a, b)
349−opAdd = (C.dataSemiring, C.add)
350−
351−opMul :: forall a b. (IsString a, IsString b) => (a, b)
352−opMul = (C.dataSemiring, C.mul)
353−
354−opEq :: forall a b. (IsString a, IsString b) => (a, b)
355−opEq = (C.dataEq, C.eq)
356−
357−opNotEq :: forall a b. (IsString a, IsString b) => (a, b)
358−opNotEq = (C.dataEq, C.notEq)
359−
360−opLessThan :: forall a b. (IsString a, IsString b) => (a, b)
361−opLessThan = (C.dataOrd, C.lessThan)
362−
363−opLessThanOrEq :: forall a b. (IsString a, IsString b) => (a, b)
364−opLessThanOrEq = (C.dataOrd, C.lessThanOrEq)
365−
366−opGreaterThan :: forall a b. (IsString a, IsString b) => (a, b)
367−opGreaterThan = (C.dataOrd, C.greaterThan)
368−
369−opGreaterThanOrEq :: forall a b. (IsString a, IsString b) => (a, b)
370−opGreaterThanOrEq = (C.dataOrd, C.greaterThanOrEq)
371−
372−opAppend :: forall a b. (IsString a, IsString b) => (a, b)
373−opAppend = (C.dataSemigroup, C.append)
374−
375−opSub :: forall a b. (IsString a, IsString b) => (a, b)
376−opSub = (C.dataRing, C.sub)
377−
378−opNegate :: forall a b. (IsString a, IsString b) => (a, b)
379−opNegate = (C.dataRing, C.negate)
380−
381−opDiv :: forall a b. (IsString a, IsString b) => (a, b)
382−opDiv = (C.dataEuclideanRing, C.div)
383−
384−opConj :: forall a b. (IsString a, IsString b) => (a, b)
385−opConj = (C.dataHeytingAlgebra, C.conj)
386−
387−opDisj :: forall a b. (IsString a, IsString b) => (a, b)
388−opDisj = (C.dataHeytingAlgebra, C.disj)
389−
390−opNot :: forall a b. (IsString a, IsString b) => (a, b)
391−opNot = (C.dataHeytingAlgebra, C.not)
392−
393−unbox :: AST -> PSString -> AST
394−unbox e d = select . inlineCommonValues $ inlineCommonOperators e
395− where
396− select :: AST -> AST
397− select e' =
398− case e' of
399− Var{} -> unbox' e'
400− App{} -> unbox' e'
401− Indexer{} -> unbox' e'
402− _ -> e'
403− unbox' :: AST -> AST
404− unbox' e' = maybe e' (\t -> App Nothing (StringLiteral Nothing t) [e']) $ unboxType d
405−
406−unboxType :: PSString -> Maybe PSString
407−unboxType s = do
408− t <- decodeString s
409− t' <- unboxType' t
410− return $ mkString t'
411− where
412− unboxType' :: Text -> Maybe Text
413− unboxType' t
414− | t == C.eqInt ||
415− t == C.semiringInt ||
416− t == C.ringInt ||
417− t == C.ordInt ||
418− t == C.dataIntBits
419− = Just int
420− | t == C.semiringNumber ||
421− t == C.ringNumber ||
422− t == C.ordNumber ||
423− t == C.euclideanRingNumber
424− = Just float
425− | t == C.eqBoolean ||
426− t == C.ordBoolean ||
427− t == C.heytingAlgebraBoolean
428− = Just bool
429− | t == C.eqChar ||
430− t == C.eqString ||
431− t == C.ordChar ||
432− t == C.ordString ||
433− t == C.semigroupString
434− = Just string
435− | otherwise = Nothing
src/CodeGen/IL/Optimizer/MagicDo.hsdeleted−146
@@ -1,146 +0,0 @@
1−-- | This module implements the "Magic Do" optimization, which inlines calls to return
2−-- and bind for the Eff monad, as well as some of its actions.
3−module CodeGen.IL.Optimizer.MagicDo (magicDoEffect, magicDoEff, magicDoST, inlineST) where
4−
5−import Prelude.Compat
6−import Protolude (ordNub)
7−
8−import Data.Maybe (fromJust, isJust)
9−import Data.Text (Text)
10−
11−import Language.PureScript.CoreImp.AST
12−import Language.PureScript.CoreImp.Optimizer.Common hiding (isDict)
13−import Language.PureScript.PSString (PSString, decodeString, mkString)
14−import qualified Language.PureScript.Constants as C
15−
16−import CodeGen.IL.Common (undefinedName, unusedName)
17−import CodeGen.IL.Optimizer.Common
18−
19−-- | Inline type class dictionaries for >>= and return for the Eff monad
20−--
21−-- E.g.
22−--
23−-- Prelude[">>="](dict)(m1)(function(x) {
24−-- return ...;
25−-- })
26−--
27−-- becomes
28−--
29−-- function __do {
30−-- var x = m1();
31−-- ...
32−-- }
33−magicDoEff :: AST -> AST
34−magicDoEff = magicDo C.eff C.effDictionaries
35−
36−magicDoEffect :: AST -> AST
37−magicDoEffect = magicDo C.effect C.effectDictionaries
38−
39−magicDoST :: AST -> AST
40−magicDoST = magicDo C.st C.stDictionaries
41−
42−magicDo :: Text -> C.EffectDictionaries -> AST -> AST
43−magicDo effectModule C.EffectDictionaries{..} = everywhereTopDown convert
44− where
45− -- Desugar monomorphic calls to >>= and return for the Eff monad
46− convert :: AST -> AST
47− -- Desugar pure
48− convert (App _ (App _ pure' [val]) []) | isPure pure' = val
49− -- Desugar discard
50− convert (App _ (App _ bind [m]) [Function s1 Nothing [unused] (Block s2 il)]) | isDiscard bind && unused == unusedName =
51− Function s1 Nothing [] $ Block s2 (App s2 m [] : map applyReturns il )
52− -- Desugar bind
53− convert (App _ (App _ bind [m]) [Function s1 Nothing [arg] (Block s2 il)]) | isBind bind =
54− Function s1 Nothing [] $ Block s2 (VariableIntroduction s2 arg (Just (App s2 m [])) : map applyReturns il)
55− -- Desugar untilE
56− convert (App s1 (App _ f [arg]) []) | isEffFunc edUntil f =
57− App s1 (Function s1 Nothing [] (Block s1 [ While s1 (Unary s1 Not (App s1 arg [])) (Block s1 []), Return s1 $ ObjectLiteral s1 []])) []
58− -- Desugar whileE
59− convert (App _ (App _ (App s1 f [arg1]) [arg2]) []) | isEffFunc edWhile f =
60− App s1 (Function s1 Nothing [] (Block s1 [ While s1 (App s1 arg1 []) (Block s1 [ App s1 arg2 [] ]), Return s1 $ ObjectLiteral s1 []])) []
61− -- -- Inline __do returns
62− -- convert (Return _ (App _ (Function _ (Just ident) [] body) [])) | ident == fnName = body
63− -- Inline double applications
64− convert (App _ (App s1 (Function s2 Nothing [] (Block ss body)) []) []) =
65− App s1 (Function s2 Nothing [] (Block ss (applyReturns `fmap` body))) []
66− convert other = other
67− -- Check if an expression represents a monomorphic call to >>= for the Eff monad
68− isBind (App _ fn [dict]) | isDict (effectModule, edBindDict) dict && isBindPoly fn = True
69− isBind _ = False
70− -- Check if an expression represents a call to @discard@
71− isDiscard (App _ (App _ fn [dict1]) [dict2])
72− | isDict (C.controlBind, C.discardUnitDictionary) dict1 &&
73− isDict (effectModule, edBindDict) dict2 &&
74− isDiscardPoly fn = True
75− isDiscard _ = False
76−
77− -- Check if an expression represents a monomorphic call to pure or return for the Eff applicative
78− isPure (App _ fn [dict]) | isDict (effectModule, edApplicativeDict) dict && isPurePoly fn = True
79− isPure _ = False
80− -- Check if an expression represents the polymorphic >>= function
81− isBindPoly = isDict (C.controlBind, C.bind)
82− -- Check if an expression represents the polymorphic pure function
83− isPurePoly = isDict (C.controlApplicative, C.pure')
84− -- Check if an expression represents the polymorphic discard function
85− isDiscardPoly = isDict (C.controlBind, C.discard)
86− -- Check if an expression represents a function in the Effect module
87− isEffFunc name (Indexer _ (StringLiteral _ name') (Var _ eff)) = eff == effectModule && name == name'
88− isEffFunc _ _ = False
89−
90− applyReturns :: AST -> AST
91− applyReturns (Return ss ret) = Return ss (App ss ret [])
92− applyReturns (Block ss ils) = Block ss (map applyReturns ils)
93− applyReturns (While ss cond il) = While ss cond (applyReturns il)
94− applyReturns (For ss v lo hi il) = For ss v lo hi (applyReturns il)
95− applyReturns (ForIn ss v xs il) = ForIn ss v xs (applyReturns il)
96− applyReturns (IfElse ss cond t f) = IfElse ss cond (applyReturns t) (applyReturns `fmap` f)
97− applyReturns other = other
98−
99−-- | Inline functions in the ST module
100−inlineST :: AST -> AST
101−inlineST = everywhere convertBlock
102− where
103− -- Look for runST blocks and inline the STRefs there.
104− -- If all STRefs are used in the scope of the same runST, only using { read, write, modify }STRef then
105− -- we can be more aggressive about inlining, and actually turn STRefs into local variables.
106− convertBlock (App s1 f [arg]) | isSTFunc C.runST f =
107− let refs = ordNub . findSTRefsIn $ arg
108− usages = findAllSTUsagesIn arg
109− allUsagesAreLocalVars = all (\u -> let v = toVar u in isJust v && fromJust v `elem` refs) usages
110− localVarsDoNotEscape = all (\r -> length (r `appearingIn` arg) == length (filter (\u -> let v = toVar u in v == Just r) usages)) refs
111− in App s1 (everywhere (convert (allUsagesAreLocalVars && localVarsDoNotEscape)) arg) []
112− convertBlock other = other
113− -- Convert a block in a safe way, preserving object wrappers of references,
114− -- or in a more aggressive way, turning wrappers into local variables depending on the
115− -- agg(ressive) parameter.
116− convert agg (App s1 f [arg]) | isSTFunc C.newSTRef f =
117− Function s1 Nothing [] (Block s1 [Return s1 $ if agg then arg else ObjectLiteral s1 [(mkString C.stRefValue, arg)]])
118− convert agg (App _ (App s1 f [ref]) []) | isSTFunc C.readSTRef f =
119− if agg then ref else Indexer s1 (StringLiteral s1 C.stRefValue) ref
120− convert agg (App _ (App _ (App s1 f [arg]) [ref]) []) | isSTFunc C.writeSTRef f =
121− if agg then Assignment s1 ref arg else Assignment s1 (Indexer s1 (StringLiteral s1 C.stRefValue) ref) arg
122− convert agg (App _ (App _ (App s1 f [func]) [ref]) []) | isSTFunc C.modifySTRef f =
123− if agg then Assignment s1 ref (App s1 func [ref]) else Assignment s1 (Indexer s1 (StringLiteral s1 C.stRefValue) ref) (App s1 func [Indexer s1 (StringLiteral s1 C.stRefValue) ref])
124− convert _ other = other
125− -- Check if an expression represents a function in the ST module
126− isSTFunc name (Indexer _ (StringLiteral _ name') (Var _ st)) = st == C.st && name == name'
127− isSTFunc _ _ = False
128− -- Find all ST Refs initialized in this block
129− findSTRefsIn = everything (++) isSTRef
130− where
131− isSTRef (VariableIntroduction _ ident (Just (App _ (App _ f [_]) []))) | isSTFunc C.newSTRef f = [ident]
132− isSTRef _ = []
133− -- Find all STRefs used as arguments to readSTRef, writeSTRef, modifySTRef
134− findAllSTUsagesIn = everything (++) isSTUsage
135− where
136− isSTUsage (App _ (App _ f [ref]) []) | isSTFunc C.readSTRef f = [ref]
137− isSTUsage (App _ (App _ (App _ f [_]) [ref]) []) | isSTFunc C.writeSTRef f || isSTFunc C.modifySTRef f = [ref]
138− isSTUsage _ = []
139− -- Find all uses of a variable
140− appearingIn ref = everything (++) isVar
141− where
142− isVar e@(Var _ v) | v == ref = [e]
143− isVar _ = []
144− -- Convert a AST value to a String if it is a Var
145− toVar (Var _ v) = Just v
146− toVar _ = Nothing
src/CodeGen/IL/Optimizer/TCO.hsdeleted−141
@@ -1,141 +0,0 @@
1−module CodeGen.IL.Optimizer.TCO (tco, tcoLoop) where
2−
3−import Prelude.Compat
4−
5−import Data.Text (Text)
6−import Data.Monoid ((<>))
7−import Language.PureScript.CoreImp.AST
8−import Language.PureScript.AST.SourcePos (SourceSpan)
9−import Safe (headDef, tailSafe)
10−import CodeGen.IL.Common
11−
12−import qualified Language.PureScript.Constants as C
13−
14−tcoLoop :: Text
15−tcoLoop = "ṩtco_loop"
16−
17−tco :: AST -> AST -> AST
18−tco mn = everywhere convert where
19− tcoVar :: Text -> Text
20− tcoVar arg = "ṩtco_var_" <> arg
21−
22− copyVar :: Text -> Text
23− copyVar arg = "ṩcopy_" <> arg
24−
25− tcoDone :: Text
26− tcoDone = "ṩtco_done"
27−
28− tcoResult :: Text
29− tcoResult = "ṩtco_result"
30−
31− convert :: AST -> AST
32− convert fn@(Function ss (Just name) args _)
33− | isTailRecursive name body'
34− = replace (toLoop name outerArgs innerArgs body')
35− where
36− innerArgs = headDef [] argss
37− outerArgs = concat . reverse $ tailSafe argss
38− (argss, body', replace) = collectAllFunctionArgs [] id fn
39− convert (Assignment ss (Var _ name) fn@(Function _ Nothing _ _))
40− | isTailRecursive name body'
41− = Assignment ss (Var ss name) (replace (toLoop name outerArgs innerArgs body'))
42− where
43− innerArgs = headDef [] argss
44− outerArgs = concat . reverse $ tailSafe argss
45− (argss, body', replace) = collectAllFunctionArgs [] id fn
46− convert js = js
47−
48− collectAllFunctionArgs :: [[Text]] -> (AST -> AST) -> AST -> ([[Text]], AST, AST -> AST)
49− collectAllFunctionArgs allArgs f (Function s1 ident args (Block s2 (body@(Return _ _):_))) =
50− collectAllFunctionArgs (args : allArgs) (\b -> f (Function s1 ident (map copyVar args) (Block s2 [b]))) body
51− collectAllFunctionArgs allArgs f (Function ss ident args body@(Block _ _)) =
52− (args : allArgs, body, f . Function ss ident (map copyVar args))
53− collectAllFunctionArgs allArgs f (Return s1 (Function s2 ident args (Block s3 [body]))) =
54− collectAllFunctionArgs (args : allArgs) (\b -> f (Return s1 (Function s2 ident (map copyVar args) (Block s3 [b])))) body
55− collectAllFunctionArgs allArgs f (Return s1 (Function s2 ident args body@(Block _ _))) =
56− (args : allArgs, body, f . Return s1 . Function s2 ident (map copyVar args))
57− collectAllFunctionArgs allArgs f body = (allArgs, body, f)
58−
59− isTailRecursive :: Text -> AST -> Bool
60− isTailRecursive ident js = countSelfReferences js > 0 && allInTailPosition js where
61− countSelfReferences = everything (+) match where
62− match :: AST -> Int
63− match (Var _ ident') | ident == ident' = 1
64− match _ = 0
65−
66− allInTailPosition (Return _ expr)
67− | isSelfCall ident expr = countSelfReferences expr == 1
68− | otherwise = countSelfReferences expr == 0
69− allInTailPosition (While _ js1 body)
70− = countSelfReferences js1 == 0 && allInTailPosition body
71− allInTailPosition (For _ _ js1 js2 body)
72− = countSelfReferences js1 == 0 && countSelfReferences js2 == 0 && allInTailPosition body
73− allInTailPosition (ForIn _ _ js1 body)
74− = countSelfReferences js1 == 0 && allInTailPosition body
75− allInTailPosition (IfElse _ js1 body el)
76− = countSelfReferences js1 == 0 && allInTailPosition body && all allInTailPosition el
77− allInTailPosition (Block _ body)
78− = all allInTailPosition body
79− allInTailPosition (Throw _ js1)
80− = countSelfReferences js1 == 0
81− allInTailPosition (ReturnNoResult _)
82− = True
83− allInTailPosition (VariableIntroduction _ _ js1)
84− = all ((== 0) . countSelfReferences) js1
85− allInTailPosition (Assignment _ _ js1)
86− = countSelfReferences js1 == 0
87− allInTailPosition (Comment _ _ js1)
88− = allInTailPosition js1
89− allInTailPosition _
90− = False
91−
92− toLoop :: Text -> [Text] -> [Text] -> AST -> AST
93− toLoop ident outerArgs innerArgs js =
94− Block rootSS $
95− concatMap (\arg -> [ VariableIntroduction rootSS (tcoVar arg) . Just $
96− Var rootSS (copyVar arg) ]) (outerArgs ++ innerArgs) ++
97− [ Assignment rootSS (Var rootSS $ "var " <> tcoDone) $ BooleanLiteral Nothing False
98− , VariableIntroduction rootSS tcoResult Nothing
99− , Assignment rootSS (Var rootSS $ "var " <> tcoLoop) (Function rootSS (Just tcoLoop) (outerArgs ++ innerArgs) (Block rootSS [loopify js]))
100− , While rootSS (Unary Nothing Not (Var rootSS tcoDone))
101− (Block rootSS
102− [(Assignment rootSS (Var rootSS tcoResult) (App rootSS (Var rootSS tcoLoop) ((map (Var rootSS . tcoVar) outerArgs) ++ (map (Var rootSS . copyVar) innerArgs))))])
103− , Return rootSS (Var rootSS tcoResult)
104− ]
105− where
106− rootSS = Nothing
107−
108− loopify :: AST -> AST
109− loopify (Return ss ret)
110− | isSelfCall ident ret =
111− let
112− allArgumentValues = concat $ collectArgs [] ret
113− in
114− Block ss $
115− zipWith (\val arg ->
116− Assignment ss (Var ss (tcoVar arg)) val) allArgumentValues outerArgs
117− ++ zipWith (\val arg ->
118− Assignment ss (Var ss (copyVar arg)) val) (drop (length outerArgs) allArgumentValues) innerArgs
119− ++ [ ReturnNoResult ss ]
120− | otherwise = Block ss [ markDone ss, Return ss ret ]
121− loopify (ReturnNoResult ss) = Block ss [ markDone ss, ReturnNoResult ss ]
122− loopify (While ss cond body) = While ss cond (loopify body)
123− loopify (For ss i js1 js2 body) = For ss i js1 js2 (loopify body)
124− loopify (ForIn ss i js1 body) = ForIn ss i js1 (loopify body)
125− loopify (IfElse ss cond body el) = IfElse ss cond (loopify body) (fmap loopify el)
126− loopify (Block ss body) = Block ss (map loopify body)
127− loopify other = other
128−
129− markDone :: Maybe SourceSpan -> AST
130− markDone ss = Assignment ss (Var ss tcoDone) (BooleanLiteral ss True)
131−
132− collectArgs :: [[AST]] -> AST -> [[AST]]
133− collectArgs acc (App _ fn args') = collectArgs (args' : acc) fn
134− collectArgs acc _ = acc
135−
136− isSelfCall :: Text -> AST -> Bool
137− isSelfCall ident (App _ (Var _ ident') _) = ident == ident'
138− isSelfCall ident (App _ (Indexer _ (Var _ ident') (Var _ mn')) _) = mn' == "" && ident == ident'
139− isSelfCall ident (App _ (Indexer _ (Var _ ident') mn') _) = mn' == mn && ident == ident'
140− isSelfCall ident (App _ fn _) = isSelfCall ident fn
141− isSelfCall _ _ = False
src/CodeGen/IL/Printer.hsdeleted−527
@@ -1,527 +0,0 @@
1−-- | Pretty printer for the AST
2−module CodeGen.IL.Printer
3− ( prettyPrintIL
4− , prettyPrintIL1
5− , prettyPrintILWithSourceMaps
6− , interfaceSource
7− , implHeaderSource
8− , implFooterSource
9− , isLiteral
10− , modLabel
11− , modPrefix
12− , ffiLoader
13− ) where
14−
15−import Prelude.Compat
16−
17−import Control.Arrow ((<+>))
18−import Control.Monad (forM, mzero)
19−import Control.Monad.State (StateT, evalStateT)
20−import Control.PatternArrows
21−import Data.List (filter, (\\))
22−import qualified Control.Arrow as A
23−
24−import Data.Maybe (fromMaybe)
25−import Data.Monoid ((<>))
26−import Data.Text (Text)
27−import qualified Data.Text as T
28−
29−import Language.PureScript.AST (SourceSpan(..))
30−import Language.PureScript.CoreImp.AST
31−import Language.PureScript.Comments
32−import Language.PureScript.Crash
33−import Language.PureScript.Names (Ident, runIdent)
34−import Language.PureScript.Pretty.Common
35−import Language.PureScript.PSString (PSString, decodeString, mkString)
36−
37−import CodeGen.IL.Common
38−import CodeGen.IL.Optimizer.TCO (tcoLoop)
39−
40−import qualified Language.PureScript.Constants as C
41−
42−-- TODO (Christoph): Get rid of T.unpack / pack
43−
44−literals :: (Emit gen) => Pattern PrinterState AST gen
45−literals = mkPattern' match'
46− where
47− match' :: (Emit gen) => AST -> StateT PrinterState Maybe gen
48− match' il = (addMapping' (getSourceSpan il) <>) <$> match il
49−
50− match :: (Emit gen) => AST -> StateT PrinterState Maybe gen
51− match (NumericLiteral _ n) = return $ emit $ T.pack $ either show show n
52− match (StringLiteral _ s) = return $ emit $ stringLiteral s
53− match (BooleanLiteral _ True) = return $ emit "true"
54− match (BooleanLiteral _ False) = return $ emit "false"
55− match (ArrayLiteral _ xs) = mconcat <$> sequence
56− [ return . emit $ arrayType <> "{"
57− , intercalate (emit ", ") <$> forM xs prettyPrintIL'
58− , return $ emit "}"
59− ]
60− -- match (ObjectLiteral _ []) = return $ emit "std::initializer_list<std::pair<const string, boxed>>{}"
61− match (ObjectLiteral _ ps) = mconcat <$> sequence
62− [ return . emit $ dictType <> "{"
63− , withIndent $ do
64− ils <- forM ps $ \(key, value) -> do
65− value' <- prettyPrintIL' value
66− return $ objectPropertyToString key <> value'
67− return $ intercalate (emit " ") $ map (<> emit ",") ils
68− , return $ emit "}"
69− ]
70− where
71− objectPropertyToString :: (Emit gen) => PSString -> gen
72− objectPropertyToString s = emit $ stringLiteral s <> ": "
73− match (Block _ sts) = mconcat <$> sequence
74− [ return $ emit "{\n"
75− , withIndent $ prettyStatements sts
76− , return $ emit "\n"
77− , currentIndent
78− , return $ emit "}"
79− ]
80− match (Var _ ident) | ident == C.undefined = return $ emit undefinedName
81− match (Var _ ident) = return $ emit ident
82− match (VariableIntroduction _ ident value) = mconcat <$> sequence
83− [ return . emit $ varDecl <> " " <> ident <> " " <> anyType
84− , maybe (return mempty) (fmap (emit " = " <>) . prettyPrintIL') value
85− ]
86− match (Assignment _ target value) = mconcat <$> sequence
87− [ prettyPrintIL' target
88− , return $ emit " = "
89− , prettyPrintIL' value
90− ]
91− match (App _ val []) = mconcat <$> sequence
92− [ return $ emit "Run("
93− , prettyPrintIL' val
94− , return $ emit ")"
95− ]
96− match (App _ (StringLiteral _ u) [arg])
97− | Just ty <- decodeString u = mconcat <$> sequence
98− [ prettyPrintIL' arg
99− , return $ emit ".("
100− , return $ emit ty
101− , return $ emit ")"
102− ]
103− match (App _ (Var _ fn) [arg]) | fn == arrayLengthFn = mconcat <$> sequence
104− [ return $ emit fn
105− , return $ emit "("
106− , prettyPrintIL' arg
107− , return $ emit ")"
108− ]
109− match (App _ (Var _ fn) args) | fn == indexFn = mconcat <$> sequence
110− [ return $ emit fn
111− , return $ emit "("
112− , intercalate (emit ", ") <$> forM args prettyPrintIL'
113− , return $ emit ")"
114− ]
115− match (App _ (Var _ fn) args) | fn == tcoLoop = mconcat <$> sequence
116− [ return $ emit fn
117− , return $ emit "("
118− , intercalate (emit ", ") <$> forM args prettyPrintIL'
119− , return $ emit ")"
120− ]
121− match (App _ (App Nothing (StringLiteral Nothing fnx) [fn@Function{}]) args)
122− | Just ftype <- decodeString fnx
123− , "Fn" `T.isPrefixOf` ftype = mconcat <$> sequence
124− [ prettyPrintIL' fn
125− , return $ emit "("
126− , intercalate (emit ", ") <$> forM args prettyPrintIL'
127− , return $ emit ")"
128− ]
129− match (App _ (App Nothing (StringLiteral Nothing fnx) [fn]) args)
130− | Just ftype <- decodeString fnx
131− , "Fn" `T.isPrefixOf` ftype = mconcat <$> sequence
132− [ prettyPrintIL' fn
133− , return $ emit ".("
134− , return $ emit ftype
135− , return $ emit ")("
136− , intercalate (emit ", ") <$> forM args prettyPrintIL'
137− , return $ emit ")"
138− ]
139− match app@(App{})
140− | (val, args) <- unApp app []
141− , length args > 1
142− = mconcat <$> sequence
143− [ return $ emit "Apply("
144− , prettyPrintIL' val
145− , return $ emit ", "
146− , intercalate (emit ", ") <$> forM args prettyPrintIL'
147− , return $ emit ")"
148− ]
149− match (App _ val args) = mconcat <$> sequence
150− [ return $ emit "Apply("
151− , prettyPrintIL' val
152− , return $ emit ", "
153− , intercalate (emit ", ") <$> forM args prettyPrintIL'
154− , return $ emit ")"
155− ]
156− match (Function _ (Just name) [] (Block _ [Return _ ret]))
157− | isComplexLiteral ret = mconcat <$> sequence
158− [ return $ emit "\n"
159− , return . emit $ varDecl <> " " <> initName name <> " Once\n"
160− , prettyPrintIL' $ VariableIntroduction Nothing (valueName name) Nothing
161− , return $ emit "\n\n"
162− , return $ emit "func "
163− , return . emit $ withPrefix name
164− , return . emit $ "() " <> anyType <> " "
165− , return $ emit "{\n"
166− , withIndent $ do
167− indentString <- currentIndent
168− return $ indentString <> (emit $ initName name <> ".Do(func() {\n") <>
169− indentString <> indentString <> (emit $ valueName name <> " = ")
170− , withIndent $ do
171− case ret of
172− Function _ Nothing args body -> mconcat <$> sequence
173− [ return $ emit "func("
174− , return . emit $ intercalate ", " (renderArg anyType <$> args)
175− , return . emit $ ") " <> anyType <> " "
176− , prettyPrintIL' body
177− ]
178− _ -> do
179− prettyPrintIL' ret
180− , return $ emit "\n"
181− , withIndent $ do
182− indentString <- currentIndent
183− return $ indentString <> (emit $ "})\n" <> "return " <> valueName name <>"\n")
184− , return $ emit "}\n\n"
185− ]
186− match (Function _ (Just name) [] ret) = mconcat <$> sequence
187− [ return $ emit "func "
188− , return . emit $ withPrefix name
189− , return . emit $ "() " <> anyType <> " "
190− , prettyPrintIL' ret
191− ]
192− match (Function _ _ args ret) = mconcat <$> sequence
193− [ return $ emit "func("
194− , return . emit $ intercalate ", " (renderArg anyType <$> args)
195− , return . emit $ ") " <> anyType <> " "
196− , prettyPrintIL' ret
197− ]
198− match (Indexer _ (Var _ name) (Var _ "")) = mconcat <$> sequence
199− [ prettyPrintIL' (Var Nothing $ withPrefix name)
200− , return $ emit "()"
201− ]
202− match (Indexer _ (Var _ name) val) = mconcat <$> sequence
203− [ prettyPrintIL' val
204− , return $ emit "."
205− , prettyPrintIL' (Var Nothing $ withPrefix name)
206− , return $ emit "()"
207− ]
208− match (Indexer _ prop@StringLiteral{} val@ObjectLiteral{}) = mconcat <$> sequence
209− [ prettyPrintIL' val
210− , return $ emit "["
211− , prettyPrintIL' prop
212− , return $ emit "]"
213− ]
214− match (Indexer _ prop@StringLiteral{} val) = mconcat <$> sequence
215− [ prettyPrintIL' val
216− , return $ emit ".("
217− , return $ emit dictType
218− , return $ emit ")["
219− , prettyPrintIL' prop
220− , return $ emit "]"
221− ]
222− match (Indexer _ index val@ArrayLiteral{}) = mconcat <$> sequence
223− [ prettyPrintIL' val
224− , return $ emit "["
225− , prettyPrintIL' index
226− , return $ emit "]"
227− ]
228− match (Indexer _ index val) = mconcat <$> sequence
229− [ prettyPrintIL' val
230− , return $ emit ".("
231− , return $ emit arrayType
232− , return $ emit ")["
233− , prettyPrintIL' index
234− , return $ emit "]"
235− ]
236− match (InstanceOf _ val ty) = mconcat <$> sequence
237− [ return $ emit "Is("
238− , prettyPrintIL' val
239− , return $ emit ", "
240− , prettyPrintIL' ty
241− , return $ emit ")"
242− ]
243− match (While _ cond sts) = mconcat <$> sequence
244− [ return $ emit "for "
245− , prettyPrintIL' cond
246− , return $ emit " "
247− , prettyPrintIL' sts
248− ]
249− match (For _ ident start end sts) = mconcat <$> sequence
250− [ return $ emit $ "for var " <> ident <> " = "
251− , prettyPrintIL' start
252− , return $ emit $ "; " <> ident <> " < "
253− , prettyPrintIL' end
254− , return $ emit $ "; " <> ident <> "++ "
255− , prettyPrintIL' sts
256− ]
257− match (ForIn _ ident obj sts) = mconcat <$> sequence
258− [ return $ emit $ "for var " <> ident <> " in "
259− , prettyPrintIL' obj
260− , return $ emit " "
261− , prettyPrintIL' sts
262− ]
263− match (IfElse _ (Binary _ EqualTo cond@Binary{} (BooleanLiteral Nothing True)) thens elses) = mconcat <$> sequence
264− [ return $ emit "if "
265− , prettyPrintIL' cond
266− , return $ emit " "
267− , prettyPrintIL' thens
268− , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintIL') elses
269− ]
270− match (IfElse _ (Binary _ EqualTo cond@Binary{} (BooleanLiteral Nothing False)) thens elses) = mconcat <$> sequence
271− [ return $ emit "if !("
272− , prettyPrintIL' cond
273− , return $ emit ") "
274− , prettyPrintIL' thens
275− , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintIL') elses
276− ]
277− match (IfElse _ cond thens elses) = mconcat <$> sequence
278− [ return $ emit "if "
279− , prettyPrintIL' cond
280− , return $ emit " "
281− , prettyPrintIL' thens
282− , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintIL') elses
283− ]
284− match (Return _ value) = mconcat <$> sequence
285− [ return $ emit "return "
286− , prettyPrintIL' value
287− ]
288− match (ReturnNoResult _) = return . emit $ "return " <> undefinedName
289− -- match (Throw _ _) = return mempty
290− match (Throw _ value) = mconcat <$> sequence
291− [ return $ emit "panic("
292− , prettyPrintIL' value
293− , return $ emit ")"
294− ]
295− match (Comment _ com il) = mconcat <$> sequence
296− [ return $ emit "\n"
297− , mconcat <$> forM com comment
298− , prettyPrintIL' il
299− ]
300− match _ = mzero
301−
302− comment :: (Emit gen) => Comment -> StateT PrinterState Maybe gen
303− comment (LineComment com) = fmap mconcat $ sequence $
304− [ currentIndent
305− , return $ emit "//" <> emit com <> emit "\n"
306− ]
307− comment (BlockComment com) = fmap mconcat $ sequence $
308− [ currentIndent
309− , return $ emit "/**\n"
310− ] ++
311− map asLine (T.lines com) ++
312− [ currentIndent
313− , return $ emit " */\n"
314− , currentIndent
315− ]
316− where
317− asLine :: (Emit gen) => Text -> StateT PrinterState Maybe gen
318− asLine s = do
319− i <- currentIndent
320− return $ i <> emit " * " <> (emit . removeComments) s <> emit "\n"
321−
322− removeComments :: Text -> Text
323− removeComments t =
324− case T.stripPrefix "*/" t of
325− Just rest -> removeComments rest
326− Nothing -> case T.uncons t of
327− Just (x, xs) -> x `T.cons` removeComments xs
328− Nothing -> ""
329−
330−unary' :: (Emit gen) => UnaryOperator -> (AST -> Text) -> Operator PrinterState AST gen
331−unary' op mkStr = Wrap match (<>)
332− where
333− match :: (Emit gen) => Pattern PrinterState AST (gen, AST)
334− match = mkPattern match'
335− where
336− match' (Unary _ op' val) | op' == op = Just (emit $ mkStr val, val)
337− match' _ = Nothing
338−
339−unary :: (Emit gen) => UnaryOperator -> Text -> Operator PrinterState AST gen
340−unary op str = unary' op (const str)
341−
342−negateOperator :: (Emit gen) => Operator PrinterState AST gen
343−negateOperator = unary' Negate (\v -> if isNegate v then "- " else "-")
344− where
345− isNegate (Unary _ Negate _) = True
346− isNegate _ = False
347−
348−binary :: (Emit gen) => BinaryOperator -> Text -> Operator PrinterState AST gen
349−binary op str = AssocL match (\v1 v2 -> v1 <> emit (" " <> str <> " ") <> v2)
350− where
351− match :: Pattern PrinterState AST (AST, AST)
352− match = mkPattern match'
353− where
354− match' (Binary _ op' v1 v2) | op' == op = Just (v1, v2)
355− match' _ = Nothing
356−
357−isLiteral :: AST -> Bool
358−isLiteral Function{} = True
359−isLiteral NumericLiteral{} = True
360−isLiteral StringLiteral{} = True
361−isLiteral BooleanLiteral{} = True
362−isLiteral ObjectLiteral{} = True
363−isLiteral ArrayLiteral{} = True
364−isLiteral _ = False
365−
366−isComplexLiteral :: AST -> Bool
367−-- isComplexLiteral Function{} = True
368−isComplexLiteral ObjectLiteral{} = True
369−isComplexLiteral ArrayLiteral{} = True
370−isComplexLiteral _ = False
371−
372−unApp :: AST -> [AST] -> (AST, [AST])
373−unApp (App _ val [arg]) args = unApp val (arg : args)
374−unApp other args = (other, args)
375−
376−prettyStatements :: (Emit gen) => [AST] -> StateT PrinterState Maybe gen
377−prettyStatements sts = do
378− ils <- forM sts prettyPrintIL'
379− indentString <- currentIndent
380− return $ intercalate (emit "\n") $ map (indentString <>) ils
381−
382−-- | Generate a pretty-printed string representing a collection of C++ expressions at the same indentation level
383−prettyPrintILWithSourceMaps :: [AST] -> (Text, [SMap])
384−prettyPrintILWithSourceMaps il =
385− let StrPos (_, s, mp) = (fromMaybe (internalError "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyStatements) il
386− in (s, mp)
387−
388−prettyPrintIL :: [AST] -> Text
389−prettyPrintIL = maybe (internalError "Incomplete pattern") runPlainString . flip evalStateT (PrinterState 0) . prettyStatements
390−
391−-- | Generate an indented, pretty-printed string representing a C++ expression
392−prettyPrintIL' :: (Emit gen) => AST -> StateT PrinterState Maybe gen
393−prettyPrintIL' = A.runKleisli $ runPattern matchValue
394− where
395− matchValue :: (Emit gen) => Pattern PrinterState AST gen
396− matchValue = buildPrettyPrinter operators (literals <+> fmap parensPos matchValue)
397− operators :: (Emit gen) => OperatorTable PrinterState AST gen
398− operators =
399− OperatorTable [ [ unary New "?" ]
400− , [ unary Not "!"
401− , unary BitwiseNot "~"
402− , unary Positive "+"
403− , negateOperator ]
404− , [ binary Multiply "*"
405− , binary Divide "/"
406− , binary Modulus "%" ]
407− , [ binary Add "+"
408− , binary Subtract "-" ]
409− , [ binary ShiftLeft "<<"
410− , binary ShiftRight ">>" ]
411− , [ binary LessThan "<"
412− , binary LessThanOrEqualTo "<="
413− , binary GreaterThan ">"
414− , binary GreaterThanOrEqualTo ">=" ]
415− , [ binary EqualTo "=="
416− , binary NotEqualTo "!=" ]
417− , [ binary BitwiseAnd "&" ]
418− , [ binary BitwiseXor "^" ]
419− , [ binary BitwiseOr "|" ]
420− , [ binary And "&&" ]
421− , [ binary Or "||" ]
422− ]
423−
424−prettyPrintIL1 :: AST -> Text
425−prettyPrintIL1 = maybe (internalError "Incomplete pattern") runPlainString . flip evalStateT (PrinterState 0) . prettyPrintIL'
426−
427−stringLiteral :: PSString -> Text
428−stringLiteral pss | Just s <- decodeString pss = stringLiteral' s
429− where
430− stringLiteral' :: Text -> Text
431− stringLiteral' s = "\"" <> T.concatMap encodeChar s <> "\""
432− encodeChar :: Char -> Text
433− encodeChar '\0' = "\\x00"
434− encodeChar '\b' = "\\b"
435− encodeChar '\t' = "\\t"
436− encodeChar '\n' = "\\n"
437− encodeChar '\v' = "\\v"
438− encodeChar '\f' = "\\f"
439− encodeChar '\r' = "\\r"
440− encodeChar '"' = "\\\""
441− encodeChar '\\' = "\\\\"
442− encodeChar c = T.singleton $ c
443−stringLiteral _ = "\"\\uFFFD\""
444−
445−interfaceSource :: Text -> [(Text,Bool)] -> [Ident] -> Text
446−interfaceSource _ _ _ = ""
447−
448−implHeaderSource :: Text -> [Text] -> Text -> Text
449−implHeaderSource mn imports otherPrefix =
450− "// Code generated by psgo. DO NOT EDIT.\n\n" <>
451− "package " <> (if mn == "Main" || mn == "Test_Main" then "main" else mn) <> "\n\n" <>
452− "import . \"" <> runtime <> "\"\n" <>
453− (if mn == "Main" || mn == "Test_Main"
454− then "import _ \"" <> otherPrefix <> "/" <> ffiLoader <> "\"\n"
455− else "\n") <>
456− "import (\n" <>
457− (T.concat $ formatImport <$> imports) <> ")\n\n" <>
458− "type _ = Any\n\n"
459− where
460− formatImport :: Text -> Text
461− formatImport s =
462− "\t\"" <> otherPrefix <> "/" <> modPrefix <> "/" <> moduleRenamer s <> "\"\n"
463− moduleRenamer :: Text -> Text
464− moduleRenamer s
465− | (s', sfx) <- T.breakOn moduleRenamerMarker s,
466− not $ T.null sfx = s'
467− moduleRenamer s = s
468−
469−implFooterSource :: Text -> [Ident] -> Text
470−implFooterSource mn foreigns =
471− "\n\n\n" <>
472− (if null foreigns
473− then ""
474− else ("// Foreign values\n\n" <>
475− "var " <> foreignDict <> " = "<> foreignMod <> "(\"" <> mn <> "\")\n\n" <>
476− (T.concat $ (\foreign' ->
477− let name = moduleIdentToIL foreign' in
478− varDecl <> " " <> initName name <> " Once\n" <>
479− varDecl <> " " <> valueName name <> " " <> anyType <> "\n\n" <>
480− "func " <>
481− withPrefix name <>
482− "() Any { \n" <>
483− " " <> initName name <> ".Do(func() {\n" <>
484− " " <> valueName name <> " = " <>
485− "Get(" <> foreignDict <> ", " <>
486− (stringLiteral . mkString $ runIdent foreign') <> ")\n" <>
487− " })\n" <>
488− " return " <> valueName name <> "\n" <>
489− "}\n\n") <$> foreigns))) <>
490− if mn == "Main" || mn == "Test.Main" then mainSource else "\n"
491− where
492− mainSource :: Text
493− mainSource = "\
494− \func main() {\n\
495− \ Run(Ꞌmain())\n\
496− \}\n\n\
497− \"
498−
499−varDecl :: Text
500−varDecl = "var"
501−
502−renderArg :: Text -> Text -> Text
503−renderArg decl arg = arg <> " " <> decl
504−
505−foreignMod :: Text
506−foreignMod = "Foreign"
507−
508−foreignDict :: Text
509−foreignDict = "foreign"
510−
511−modLabel :: Text
512−modLabel = "purescript-native"
513−
514−modPrefix :: Text
515−modPrefix = modLabel <> "/output"
516−
517−runtime :: Text
518−runtime = "github.com/" <> modLabel <> "/go-runtime"
519−
520−ffiLoader :: Text
521−ffiLoader = modLabel <> "/ffi-loader"
522−
523−initName :: Text -> Text
524−initName s = "ᛌ" <> s <> "_once"
525−
526−valueName :: Text -> Text
527−valueName s = "ᛧ" <> s
src/Data/Generics/Extras.hsnew file+24
@@ -0,0 +1,24 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Data.Generics.Extras
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+{-# LANGUAGE Rank2Types #-}
16+
17+module Data.Generics.Extras where
18+
19+import Data.Data
20+
21+everywhereM' :: (Monad m, Data d) => (forall d. (Data d) => d -> m d) -> d -> m d
22+everywhereM' f x = do
23+ y <- f x
24+ gmapM (everywhereM' f) y
src/Language/PureScript.hsnew file+38
@@ -0,0 +1,38 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+module Language.PureScript (module P, compile) where
16+
17+import Language.PureScript.Values as P
18+import Language.PureScript.Types as P
19+import Language.PureScript.Kinds as P
20+import Language.PureScript.Declarations as P
21+import Language.PureScript.Names as P
22+import Language.PureScript.Parser as P
23+import Language.PureScript.CodeGen as P
24+import Language.PureScript.TypeChecker as P
25+import Language.PureScript.Pretty as P
26+import Language.PureScript.Optimize as P
27+import Language.PureScript.Operators as P
28+
29+import Data.List (intercalate)
30+import Data.Maybe (mapMaybe)
31+
32+compile :: [Declaration] -> Either String (String, String, Environment)
33+compile decls = do
34+ bracketted <- rebracket decls
35+ (_, env) <- runCheck (typeCheckAll bracketted)
36+ let js = prettyPrintJS . map optimize . concat . mapMaybe (\decl -> declToJs Nothing global decl env) $ bracketted
37+ let exts = intercalate "\n" . mapMaybe (externToPs 0 global env) $ bracketted
38+ return (js, exts, env)
src/Language/PureScript/CodeGen.hsnew file+18
@@ -0,0 +1,18 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.CodeGen
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+module Language.PureScript.CodeGen (module C) where
16+
17+import Language.PureScript.CodeGen.JS as C
18+import Language.PureScript.CodeGen.Externs as C
src/Language/PureScript/CodeGen/Externs.hsnew file+42
@@ -0,0 +1,42 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.CodeGen.Externs
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+module Language.PureScript.CodeGen.Externs (
16+ externToPs
17+) where
18+
19+import Data.List (intercalate)
20+import Data.Maybe (mapMaybe)
21+import qualified Data.Map as M
22+import Language.PureScript.Declarations
23+import Language.PureScript.TypeChecker.Monad
24+import Language.PureScript.Pretty
25+import Language.PureScript.Names
26+
27+externToPs :: Int -> ModulePath -> Environment -> Declaration -> Maybe String
28+externToPs indent path env (ValueDeclaration name _) = do
29+ (ty, _) <- M.lookup (path, name) $ names env
30+ return $ replicate indent ' ' ++ "foreign import " ++ show name ++ " :: " ++ prettyPrintType ty
31+externToPs indent path env (DataDeclaration name _ _) = do
32+ (kind, _) <- M.lookup (path, name) $ types env
33+ return $ replicate indent ' ' ++ "foreign import data " ++ show name ++ " :: " ++ prettyPrintKind kind
34+externToPs indent path env (ExternMemberDeclaration member name ty) =
35+ return $ replicate indent ' ' ++ "foreign import member " ++ show member ++ " " ++ show name ++ " :: " ++ prettyPrintType ty
36+externToPs indent path env (ExternDataDeclaration name kind) =
37+ return $ replicate indent ' ' ++ "foreign import data " ++ show name ++ " :: " ++ prettyPrintKind kind
38+externToPs indent path env (TypeSynonymDeclaration name args ty) =
39+ return $ replicate indent ' ' ++ "type " ++ show name ++ " " ++ unwords args ++ " = " ++ prettyPrintType ty
40+externToPs indent path env (ModuleDeclaration name decls) =
41+ return $ replicate indent ' ' ++ "module " ++ show name ++ " where\n" ++ unlines (mapMaybe (externToPs (indent + 2) (subModule path name) env) decls)
42+externToPs _ _ _ _ = Nothing
src/Language/PureScript/CodeGen/JS.hsnew file+175
@@ -0,0 +1,175 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.CodeGen.JS
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+module Language.PureScript.CodeGen.JS (
16+ module AST,
17+ declToJs
18+) where
19+
20+import Data.Char
21+import Data.Maybe (fromMaybe, mapMaybe)
22+import Data.List (intercalate)
23+import qualified Data.Map as M
24+import qualified Control.Arrow as A
25+import Control.Arrow ((<+>), second)
26+import Control.Monad (forM)
27+import Control.Applicative
28+
29+import Language.PureScript.TypeChecker (Environment, names)
30+import Language.PureScript.Types
31+import Language.PureScript.Values
32+import Language.PureScript.Names
33+import Language.PureScript.Declarations
34+import Language.PureScript.Pretty.Common
35+import Language.PureScript.CodeGen.Monad
36+import Language.PureScript.CodeGen.JS.AST as AST
37+
38+declToJs :: Maybe Ident -> ModulePath -> Declaration -> Environment -> Maybe [JS]
39+declToJs mod mp (ValueDeclaration ident (Abs args ret)) _ =
40+ Just $ JSFunction (Just ident) args (JSBlock [JSReturn (valueToJs mp ret)]) :
41+ maybe [] (return . setProperty (identToJs ident) (JSVar ident)) mod
42+declToJs mod mp (ValueDeclaration ident val) _ =
43+ Just $ JSVariableIntroduction ident (Just (valueToJs mp val)) :
44+ maybe [] (return . setProperty (identToJs ident) (JSVar ident)) mod
45+declToJs mod _ (ExternMemberDeclaration member ident _) _ =
46+ Just $ JSFunction (Just ident) [Ident "value"] (JSBlock [JSReturn (JSAccessor member (JSVar (Ident "value")))]) :
47+ maybe [] (return . setProperty (show ident) (JSVar ident)) mod
48+declToJs mod mp (DataDeclaration _ _ ctors) _ =
49+ Just $ flip concatMap ctors $ \(pn@(ProperName ctor), maybeTy) ->
50+ let
51+ ctorJs =
52+ case maybeTy of
53+ Nothing -> JSVariableIntroduction (Ident ctor) (Just (JSObjectLiteral [ ("ctor", JSStringLiteral (show (Qualified mp pn))) ]))
54+ Just _ -> JSFunction (Just (Ident ctor)) [Ident "value"]
55+ (JSBlock [JSReturn
56+ (JSObjectLiteral [ ("ctor", JSStringLiteral (show (Qualified mp pn)))
57+ , ("value", JSVar (Ident "value")) ])])
58+ in ctorJs : maybe [] (return . setProperty ctor (JSVar (Ident ctor))) mod
59+declToJs mod mp (ModuleDeclaration pn@(ProperName name) decls) env =
60+ Just $ [ JSVariableIntroduction (Ident name) Nothing
61+ , JSApp (JSFunction Nothing [Ident name]
62+ (JSBlock (concat $ mapMaybe (\decl -> declToJs (Just (Ident name)) (subModule mp pn) decl env) decls)))
63+ [JSAssignment (JSAssignVariable (Ident name))
64+ (JSBinary Or (JSVar (Ident name)) (JSObjectLiteral []))]] ++
65+ maybe [] (return . setProperty name (JSVar (Ident name))) mod
66+declToJs mod omp (ImportDeclaration mp idents) env =
67+ Just $ case idents of
68+ Nothing ->
69+ let idents = map snd . filter ((== mp) . fst) . M.keys $ names env
70+ in map mkLocal idents
71+ Just idents -> map mkLocal idents
72+ where mkLocal ident = JSVariableIntroduction ident (Just (qualifiedToJS identToJs (Qualified mp ident)))
73+declToJs _ _ _ _ = Nothing
74+
75+setProperty :: String -> JS -> Ident -> JS
76+setProperty prop val mod = JSAssignment (JSAssignProperty prop (JSAssignVariable mod)) val
77+
78+valueToJs :: ModulePath -> Value -> JS
79+valueToJs _ (NumericLiteral n) = JSNumericLiteral n
80+valueToJs _ (StringLiteral s) = JSStringLiteral s
81+valueToJs _ (BooleanLiteral b) = JSBooleanLiteral b
82+valueToJs m (ArrayLiteral xs) = JSArrayLiteral (map (valueToJs m) xs)
83+valueToJs m (ObjectLiteral ps) = JSObjectLiteral (map (second (valueToJs m)) ps)
84+valueToJs m (ObjectUpdate o ps) = JSApp (JSAccessor "extend" (JSVar (Ident "Object"))) [ valueToJs m o, JSObjectLiteral (map (second (valueToJs m)) ps)]
85+valueToJs m (Constructor name) = qualifiedToJS runProperName name
86+valueToJs m (Block sts) = JSApp (JSFunction Nothing [] (JSBlock (map (statementToJs m) sts))) []
87+valueToJs m (Case value binders) = runGen (bindersToJs m binders (valueToJs m value))
88+valueToJs m (IfThenElse cond th el) = JSConditional (valueToJs m cond) (valueToJs m th) (valueToJs m el)
89+valueToJs m (Accessor prop val) = JSAccessor prop (valueToJs m val)
90+valueToJs m (Indexer index val) = JSIndexer (valueToJs m index) (valueToJs m val)
91+valueToJs m (App val args) = JSApp (valueToJs m val) (map (valueToJs m) args)
92+valueToJs m (Abs args val) = JSFunction Nothing args (JSBlock [JSReturn (valueToJs m val)])
93+valueToJs m (Unary op val) = JSUnary op (valueToJs m val)
94+valueToJs m (Binary op v1 v2) = JSBinary op (valueToJs m v1) (valueToJs m v2)
95+valueToJs m (Var ident) = qualifiedToJS identToJs ident
96+valueToJs m (TypedValue val _) = valueToJs m val
97+
98+qualifiedToJS :: (a -> String) -> Qualified a -> JS
99+qualifiedToJS f (Qualified (ModulePath parts) a) =
100+ delimited (f a : reverse (map show parts))
101+ where delimited [part] = JSVar (Ident (part))
102+ delimited (part:parts) = JSAccessor part (delimited parts)
103+
104+bindersToJs :: ModulePath -> [(Binder, Value)] -> JS -> Gen JS
105+bindersToJs m binders val = do
106+ valName <- fresh
107+ jss <- forM binders $ \(binder, result) -> binderToJs m valName [JSReturn (valueToJs m result)] binder
108+ return $ JSApp (JSFunction Nothing [Ident valName] (JSBlock (concat jss ++ [JSThrow (JSStringLiteral "Failed pattern match")])))
109+ [val]
110+
111+binderToJs :: ModulePath -> String -> [JS] -> Binder -> Gen [JS]
112+binderToJs _ varName done NullBinder = return done
113+binderToJs _ varName done (StringBinder str) =
114+ return [JSIfElse (JSBinary EqualTo (JSVar (Ident varName)) (JSStringLiteral str)) (JSBlock done) Nothing]
115+binderToJs _ varName done (NumberBinder num) =
116+ return [JSIfElse (JSBinary EqualTo (JSVar (Ident varName)) (JSNumericLiteral num)) (JSBlock done) Nothing]
117+binderToJs _ varName done (BooleanBinder True) =
118+ return [JSIfElse (JSVar (Ident varName)) (JSBlock done) Nothing]
119+binderToJs _ varName done (BooleanBinder False) =
120+ return [JSIfElse (JSUnary Not (JSVar (Ident varName))) (JSBlock done) Nothing]
121+binderToJs _ varName done (VarBinder ident) =
122+ return (JSVariableIntroduction ident (Just (JSVar (Ident varName))) : done)
123+binderToJs m varName done (NullaryBinder ctor) =
124+ return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar (Ident varName))) (JSStringLiteral (show (uncurry Qualified $ qualify m ctor)))) (JSBlock done) Nothing]
125+binderToJs m varName done (UnaryBinder ctor b) = do
126+ value <- fresh
127+ js <- binderToJs m value done b
128+ return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar (Ident varName))) (JSStringLiteral (show (uncurry Qualified $ qualify m ctor)))) (JSBlock (JSVariableIntroduction (Ident value) (Just (JSAccessor "value" (JSVar (Ident varName)))) : js)) Nothing]
129+binderToJs m varName done (ObjectBinder bs) = go done bs
130+ where
131+ go :: [JS] -> [(String, Binder)] -> Gen [JS]
132+ go done [] = return done
133+ go done ((prop, binder):bs) = do
134+ propVar <- fresh
135+ done' <- go done bs
136+ js <- binderToJs m propVar done' binder
137+ return (JSVariableIntroduction (Ident propVar) (Just (JSAccessor prop (JSVar (Ident varName)))) : js)
138+binderToJs m varName done (ArrayBinder bs rest) = do
139+ js <- go done rest 0 bs
140+ return [JSIfElse (JSBinary cmp (JSAccessor "length" (JSVar (Ident varName))) (JSNumericLiteral (Left (fromIntegral $ length bs)))) (JSBlock js) Nothing]
141+ where
142+ cmp :: BinaryOperator
143+ cmp = maybe EqualTo (const GreaterThanOrEqualTo) rest
144+ go :: [JS] -> Maybe Binder -> Integer -> [Binder] -> Gen [JS]
145+ go done Nothing _ [] = return done
146+ go done (Just binder) index [] = do
147+ restVar <- fresh
148+ js <- binderToJs m restVar done binder
149+ return (JSVariableIntroduction (Ident restVar) (Just (JSApp (JSAccessor "slice" (JSVar (Ident varName))) [JSNumericLiteral (Left index)])) : js)
150+ go done rest index (binder:bs) = do
151+ elVar <- fresh
152+ done' <- go done rest (index + 1) bs
153+ js <- binderToJs m elVar done' binder
154+ return (JSVariableIntroduction (Ident elVar) (Just (JSIndexer (JSNumericLiteral (Left index)) (JSVar (Ident varName)))) : js)
155+binderToJs m varName done (NamedBinder ident binder) = do
156+ js <- binderToJs m varName done binder
157+ return (JSVariableIntroduction ident (Just (JSVar (Ident varName))) : js)
158+binderToJs m varName done (GuardedBinder cond binder) = binderToJs m varName done' binder
159+ where
160+ done' = [JSIfElse (valueToJs m cond) (JSBlock done) Nothing]
161+
162+statementToJs :: ModulePath -> Statement -> JS
163+statementToJs m (VariableIntroduction ident value) = JSVariableIntroduction ident (Just (valueToJs m value))
164+statementToJs m (Assignment target value) = JSAssignment (JSAssignVariable target) (valueToJs m value)
165+statementToJs m (While cond sts) = JSWhile (valueToJs m cond) (JSBlock (map (statementToJs m) sts))
166+statementToJs m (For ident start end sts) = JSFor ident (valueToJs m start) (valueToJs m end) (JSBlock (map (statementToJs m) sts))
167+statementToJs m (ForEach ident arr sts) = JSApp (JSAccessor "forEach" (valueToJs m arr)) [JSFunction Nothing [ident] (JSBlock (map (statementToJs m) sts))]
168+statementToJs m (If ifst) = ifToJs ifst
169+ where
170+ ifToJs :: IfStatement -> JS
171+ ifToJs (IfStatement cond thens elses) = JSIfElse (valueToJs m cond) (JSBlock (map (statementToJs m) thens)) (fmap elseToJs elses)
172+ elseToJs :: ElseStatement -> JS
173+ elseToJs (Else sts) = JSBlock (map (statementToJs m) sts)
174+ elseToJs (ElseIf ifst) = ifToJs ifst
175+statementToJs m (Return value) = JSReturn (valueToJs m value)
src/Language/PureScript/CodeGen/JS/AST.hsnew file+49
@@ -0,0 +1,49 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.CodeGen.JS.AST
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+{-# LANGUAGE DeriveDataTypeable #-}
16+
17+module Language.PureScript.CodeGen.JS.AST where
18+
19+import Language.PureScript.Names
20+import Language.PureScript.Values
21+
22+import Data.Data
23+
24+data JS
25+ = JSNumericLiteral (Either Integer Double)
26+ | JSStringLiteral String
27+ | JSBooleanLiteral Bool
28+ | JSUnary UnaryOperator JS
29+ | JSBinary BinaryOperator JS JS
30+ | JSArrayLiteral [JS]
31+ | JSIndexer JS JS
32+ | JSObjectLiteral [(String, JS)]
33+ | JSAccessor String JS
34+ | JSFunction (Maybe Ident) [Ident] JS
35+ | JSApp JS [JS]
36+ | JSVar Ident
37+ | JSConditional JS JS JS
38+ | JSBlock [JS]
39+ | JSVariableIntroduction Ident (Maybe JS)
40+ | JSAssignment JSAssignment JS
41+ | JSWhile JS JS
42+ | JSFor Ident JS JS JS
43+ | JSIfElse JS JS (Maybe JS)
44+ | JSReturn JS
45+ | JSThrow JS deriving (Show, Data, Typeable)
46+
47+data JSAssignment
48+ = JSAssignVariable Ident
49+ | JSAssignProperty String JSAssignment deriving (Show, Data, Typeable)
src/Language/PureScript/CodeGen/Monad.hsnew file+31
@@ -0,0 +1,31 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.CodeGen.Monad
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
16+
17+module Language.PureScript.CodeGen.Monad where
18+
19+import Control.Monad.State
20+import Control.Applicative
21+
22+newtype Gen a = Gen { unGen :: State Int a } deriving (Functor, Applicative, Monad, MonadState Int)
23+
24+runGen :: Gen a -> a
25+runGen = flip evalState 0 . unGen
26+
27+fresh :: Gen String
28+fresh = do
29+ n <- get
30+ modify (+ 1)
31+ return $ '_' : show n
src/Language/PureScript/Declarations.hsnew file+43
@@ -0,0 +1,43 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Declarations
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+{-# LANGUAGE DeriveDataTypeable #-}
16+
17+module Language.PureScript.Declarations where
18+
19+import Language.PureScript.Values
20+import Language.PureScript.Types
21+import Language.PureScript.Names
22+import Language.PureScript.Kinds
23+
24+import qualified Data.Data as D
25+
26+type Precedence = Integer
27+
28+data Associativity = Infixl | Infixr deriving (Show, D.Data, D.Typeable)
29+
30+data Fixity = Fixity Associativity Precedence deriving (Show, D.Data, D.Typeable)
31+
32+data Declaration
33+ = DataDeclaration ProperName [String] [(ProperName, Maybe Type)]
34+ | TypeSynonymDeclaration ProperName [String] Type
35+ | TypeDeclaration Ident PolyType
36+ | ValueDeclaration Ident Value
37+ | ExternDeclaration Ident PolyType
38+ | ExternMemberDeclaration String Ident PolyType
39+ | ExternDataDeclaration ProperName Kind
40+ | FixityDeclaration Fixity String
41+ | ModuleDeclaration ProperName [Declaration]
42+ | ImportDeclaration ModulePath (Maybe [Ident])
43+ deriving (Show, D.Data, D.Typeable)
src/Language/PureScript/Kinds.hsnew file+26
@@ -0,0 +1,26 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Kinds
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+{-# LANGUAGE DeriveDataTypeable #-}
16+
17+module Language.PureScript.Kinds where
18+
19+import Data.Data
20+import Language.PureScript.Unknown
21+
22+data Kind
23+ = KUnknown (Unknown Kind)
24+ | Star
25+ | Row
26+ | FunKind Kind Kind deriving (Show, Eq, Data, Typeable)
src/Language/PureScript/Names.hsnew file+51
@@ -0,0 +1,51 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Names
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+{-# LANGUAGE DeriveDataTypeable #-}
16+
17+module Language.PureScript.Names where
18+
19+import Data.Data
20+import Data.List (intercalate)
21+
22+data Ident = Ident String | Op String deriving (Eq, Ord, Data, Typeable)
23+
24+instance Show Ident where
25+ show (Ident s) = s
26+ show (Op op) = '(':op ++ ")"
27+
28+newtype ProperName = ProperName { runProperName :: String } deriving (Eq, Ord, Data, Typeable)
29+
30+instance Show ProperName where
31+ show = runProperName
32+
33+data ModulePath = ModulePath [ProperName] deriving (Eq, Ord, Data, Typeable)
34+
35+instance Show ModulePath where
36+ show (ModulePath segments) = intercalate "." $ map show segments
37+
38+subModule :: ModulePath -> ProperName -> ModulePath
39+subModule (ModulePath mp) name = ModulePath (mp ++ [name])
40+
41+global :: ModulePath
42+global = ModulePath []
43+
44+data Qualified a = Qualified ModulePath a deriving (Eq, Ord, Data, Typeable)
45+
46+instance (Show a) => Show (Qualified a) where
47+ show (Qualified (ModulePath names) a) = intercalate ":" (map show names ++ [show a])
48+
49+qualify :: ModulePath -> Qualified a -> (ModulePath, a)
50+qualify mp (Qualified (ModulePath []) a) = (mp, a)
51+qualify _ (Qualified mp a) = (mp, a)
src/Language/PureScript/Operators.hsnew file+129
@@ -0,0 +1,129 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Operators
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+{-# LANGUAGE Rank2Types #-}
16+
17+module Language.PureScript.Operators (
18+ rebracket
19+) where
20+
21+import Language.PureScript.Names
22+import Language.PureScript.Declarations
23+import Language.PureScript.Values
24+
25+import qualified Data.Data as D
26+import Data.Function (on)
27+import Data.List (groupBy, sortBy)
28+import qualified Data.Map as M
29+import qualified Data.Generics as G
30+import qualified Data.Generics.Extras as G
31+import Control.Monad.State
32+import Control.Applicative
33+import qualified Text.Parsec as P
34+import qualified Text.Parsec.Pos as P
35+import qualified Text.Parsec.Expr as P
36+
37+rebracket :: [Declaration] -> Either String [Declaration]
38+rebracket ds = do
39+ m <- collectFixities ds
40+ let opTable = customOperatorTable m
41+ ds' <- G.everywhereM' (G.mkM (matchOperators opTable)) ds
42+ return $ G.everywhere (G.mkT removeParens) ds'
43+
44+removeParens :: Value -> Value
45+removeParens (Parens val) = val
46+removeParens val = val
47+
48+customOperatorTable :: M.Map (Qualified Ident) Fixity -> [[(Qualified Ident, Value -> Value -> Value, Associativity)]]
49+customOperatorTable fixities =
50+ let
51+ applyUserOp name t1 t2 = App (App (Var name) [t1]) [t2]
52+ userOps = map (\(name, Fixity a p) -> (name, applyUserOp name, p, a)) . M.toList $ fixities
53+ sorted = sortBy (compare `on` (\(_, _, p, _) -> p)) (userOps ++ builtIns)
54+ groups = groupBy ((==) `on` (\(_, _, p, _) -> p)) sorted
55+ in
56+ map (map (\(name, f, _, a) -> (name, f, a))) groups
57+
58+type Chain = [Either Value (Qualified Ident)]
59+
60+matchOperators :: [[(Qualified Ident, Value -> Value -> Value, Associativity)]] -> Value -> Either String Value
61+matchOperators ops val = G.everywhereM' (G.mkM parseChains) val
62+ where
63+ parseChains :: Value -> Either String Value
64+ parseChains b@(BinaryNoParens _ _ _) = bracketChain (extendChain b)
65+ parseChains val = return val
66+ extendChain :: Value -> Chain
67+ extendChain (BinaryNoParens name l r) = Left l : Right name : extendChain r
68+ extendChain val = [Left val]
69+ bracketChain :: Chain -> Either String Value
70+ bracketChain = either (Left . show) Right . P.parse (P.buildExpressionParser opTable parseValue <* P.eof) "operator expression"
71+ opTable = map (map (\(name, f, a) -> P.Infix (P.try (matchOp name) >> return f) (toAssoc a))) ops
72+ ++ [[P.Infix (P.try (parseOp >>= \ident -> return (\t1 t2 -> App (App (Var ident) [t1]) [t2]))) P.AssocLeft]]
73+
74+toAssoc :: Associativity -> P.Assoc
75+toAssoc Infixl = P.AssocLeft
76+toAssoc Infixr = P.AssocRight
77+
78+parseValue :: P.Parsec Chain () Value
79+parseValue = P.token show (const (P.initialPos "")) (either Just (const Nothing)) P.<?> "expression"
80+
81+parseOp :: P.Parsec Chain () (Qualified Ident)
82+parseOp = P.token show (const (P.initialPos "")) (either (const Nothing) Just) P.<?> "operator"
83+
84+matchOp :: Qualified Ident -> P.Parsec Chain () ()
85+matchOp op = do
86+ ident <- parseOp
87+ guard (ident == op)
88+
89+collectFixities :: [Declaration] -> Either String (M.Map (Qualified Ident) Fixity)
90+collectFixities = go M.empty global
91+ where
92+ go :: M.Map (Qualified Ident) Fixity -> ModulePath -> [Declaration] -> Either String (M.Map (Qualified Ident) Fixity)
93+ go m _ [] = return m
94+ go m p (FixityDeclaration fixity name : rest) = do
95+ let qual = Qualified p (Op name)
96+ when (qual `M.member` m) (Left $ "redefined fixity for " ++ show name)
97+ go (M.insert qual fixity m) p rest
98+ go m p (ModuleDeclaration name decls : rest) = do
99+ m' <- go m (subModule p name) decls
100+ go m' p rest
101+ go m p (_:ds) = go m p ds
102+
103+globalOp :: String -> Qualified Ident
104+globalOp = Qualified global . Op
105+
106+builtIns :: [(Qualified Ident, Value -> Value -> Value, Precedence, Associativity)]
107+builtIns = [ (globalOp "<", Binary LessThan, 3, Infixl)
108+ , (globalOp "<=", Binary LessThanOrEqualTo, 3, Infixl)
109+ , (globalOp ">", Binary GreaterThan, 3, Infixl)
110+ , (globalOp ">=", Binary GreaterThanOrEqualTo, 3, Infixl)
111+ , (globalOp "!!", flip Indexer, 4, Infixl)
112+ , (globalOp "*", Binary Multiply, 5, Infixl)
113+ , (globalOp "/", Binary Divide, 5, Infixl)
114+ , (globalOp "%", Binary Modulus, 5, Infixl)
115+ , (globalOp "++", Binary Concat, 6, Infixr)
116+ , (globalOp "+", Binary Add, 7, Infixl)
117+ , (globalOp "-", Binary Subtract, 7, Infixl)
118+ , (globalOp "<<", Binary ShiftLeft, 8, Infixl)
119+ , (globalOp ">>", Binary ShiftRight, 8, Infixl)
120+ , (globalOp ">>>", Binary ZeroFillShiftRight, 8, Infixl)
121+ , (globalOp "==", Binary EqualTo, 9, Infixl)
122+ , (globalOp "!=", Binary NotEqualTo, 9, Infixl)
123+ , (globalOp "&", Binary BitwiseAnd, 10, Infixl)
124+ , (globalOp "^", Binary BitwiseXor, 10, Infixl)
125+ , (globalOp "|", Binary BitwiseOr, 10, Infixl)
126+ , (globalOp "&&", Binary And, 11, Infixr)
127+ , (globalOp "||", Binary Or, 11, Infixr)
128+ ]
129+
src/Language/PureScript/Optimize.hsnew file+95
@@ -0,0 +1,95 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Optimize
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+module Language.PureScript.Optimize (
16+ optimize
17+) where
18+
19+import Data.Data
20+import Data.Generics
21+
22+import Language.PureScript.Names
23+import Language.PureScript.CodeGen.JS.AST
24+
25+optimize :: JS -> JS
26+optimize = removeUnusedVariables . unThunk . etaConvert . inlineVariables
27+
28+replaceIdent :: (Data d) => Ident -> JS -> d -> d
29+replaceIdent var1 js = everywhere (mkT replace)
30+ where
31+ replace (JSVar var2) | var1 == var2 = js
32+ replace js = js
33+
34+isReassigned :: (Data d) => Ident -> d -> Bool
35+isReassigned var1 = everything (||) (mkQ False check)
36+ where
37+ check :: JS -> Bool
38+ check (JSAssignment (JSAssignVariable var2) _) | var1 == var2 = True
39+ check _ = False
40+
41+isUsed :: (Data d) => Ident -> d -> Bool
42+isUsed var1 = everything (||) (mkQ False check)
43+ where
44+ check :: JS -> Bool
45+ check (JSVar var2) | var1 == var2 = True
46+ check (JSAssignment target _) | var1 == targetVariable target = True
47+ check _ = False
48+ targetVariable :: JSAssignment -> Ident
49+ targetVariable (JSAssignVariable var) = var
50+ targetVariable (JSAssignProperty _ tgt) = targetVariable tgt
51+
52+shouldInline :: JS -> Bool
53+shouldInline (JSVar _) = True
54+shouldInline (JSNumericLiteral _) = True
55+shouldInline (JSStringLiteral _) = True
56+shouldInline (JSBooleanLiteral _) = True
57+shouldInline (JSAccessor _ val) = shouldInline val
58+shouldInline (JSIndexer index val) = shouldInline index && shouldInline val
59+shouldInline _ = False
60+
61+inlineVariables :: JS -> JS
62+inlineVariables = everywhere (mkT removeFromBlock)
63+ where
64+ removeFromBlock :: JS -> JS
65+ removeFromBlock (JSBlock sts) = JSBlock (go sts)
66+ removeFromBlock js = js
67+ go :: [JS] -> [JS]
68+ go [] = []
69+ go (JSVariableIntroduction var (Just js) : sts) | shouldInline js && not (isReassigned var sts) = go (replaceIdent var js sts)
70+ go (s:sts) = s : go sts
71+
72+removeUnusedVariables :: JS -> JS
73+removeUnusedVariables = everywhere (mkT removeFromBlock)
74+ where
75+ removeFromBlock :: JS -> JS
76+ removeFromBlock (JSBlock sts) = JSBlock (go sts)
77+ removeFromBlock js = js
78+ go :: [JS] -> [JS]
79+ go [] = []
80+ go (JSVariableIntroduction var _ : sts) | not (isUsed var sts) = go sts
81+ go (s:sts) = s : go sts
82+
83+etaConvert :: JS -> JS
84+etaConvert = everywhere (mkT convert)
85+ where
86+ convert :: JS -> JS
87+ convert (JSBlock [JSReturn (JSApp (JSFunction Nothing [ident] (JSBlock body)) [arg])]) | shouldInline arg = JSBlock (replaceIdent ident arg body)
88+ convert js = js
89+
90+unThunk :: JS -> JS
91+unThunk = everywhere (mkT convert)
92+ where
93+ convert :: JS -> JS
94+ convert (JSBlock [JSReturn (JSApp (JSFunction Nothing [] (JSBlock body)) [])]) = JSBlock body
95+ convert js = js
src/Language/PureScript/Parser.hsnew file+22
@@ -0,0 +1,22 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Parser
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+module Language.PureScript.Parser (module P) where
16+
17+import Language.PureScript.Parser.Common as P
18+import Language.PureScript.Parser.Types as P
19+import Language.PureScript.Parser.Values as P
20+import Language.PureScript.Parser.State as P
21+import Language.PureScript.Parser.Kinds as P
22+import Language.PureScript.Parser.Declarations as P
src/Language/PureScript/Parser/Common.hsnew file+203
@@ -0,0 +1,203 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Parser.Common
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+{-# LANGUAGE FlexibleContexts #-}
16+
17+module Language.PureScript.Parser.Common where
18+
19+import Data.Char (isSpace)
20+import Control.Applicative
21+import Control.Monad
22+import Control.Monad.State
23+import Language.PureScript.Parser.State
24+import qualified Data.Map as M
25+import qualified Text.Parsec as P
26+import qualified Text.Parsec.Pos as P
27+import qualified Text.Parsec.Token as PT
28+
29+import Language.PureScript.Names
30+
31+reservedNames :: [String]
32+reservedNames = [ "case"
33+ , "of"
34+ , "data"
35+ , "type"
36+ , "var"
37+ , "val"
38+ , "while"
39+ , "for"
40+ , "foreach"
41+ , "if"
42+ , "then"
43+ , "else"
44+ , "return"
45+ , "true"
46+ , "false"
47+ , "foreign"
48+ , "import"
49+ , "member"
50+ , "forall"
51+ , "do"
52+ , "until"
53+ , "in"
54+ , "break"
55+ , "catch"
56+ , "continue"
57+ , "debugger"
58+ , "default"
59+ , "delete"
60+ , "finally"
61+ , "function"
62+ , "instanceof"
63+ , "new"
64+ , "switch"
65+ , "this"
66+ , "throw"
67+ , "try"
68+ , "typeof"
69+ , "void"
70+ , "with"
71+ , "Number"
72+ , "String"
73+ , "Boolean"
74+ , "infixl"
75+ , "infixr"
76+ , "module" ]
77+
78+builtInOperators :: [String]
79+builtInOperators = [ "~", "-", "<=", ">=", "<", ">", "*", "/", "%", "++", "+", "<<", ">>>", ">>"
80+ , "==", "!=", "&&", "||", "&", "^", "|", "!!", "!" ]
81+
82+reservedOpNames :: [String]
83+reservedOpNames = builtInOperators ++ [ "->" ]
84+
85+identStart :: P.Parsec String u Char
86+identStart = P.lower <|> P.oneOf "_$"
87+
88+properNameStart :: P.Parsec String u Char
89+properNameStart = P.upper
90+
91+identLetter :: P.Parsec String u Char
92+identLetter = P.alphaNum <|> P.oneOf "_'"
93+
94+opStart :: P.Parsec String u Char
95+opStart = P.oneOf "!#$%&*+/<=>?@^|~"
96+
97+opLetter :: P.Parsec String u Char
98+opLetter = P.oneOf ":#$%&*+./<=>?@^|"
99+
100+langDef = PT.LanguageDef
101+ { PT.reservedNames = reservedNames
102+ , PT.reservedOpNames = reservedOpNames
103+ , PT.commentStart = "{-"
104+ , PT.commentEnd = "-}"
105+ , PT.commentLine = "--"
106+ , PT.nestedComments = True
107+ , PT.identStart = identStart
108+ , PT.identLetter = identLetter
109+ , PT.opStart = opStart
110+ , PT.opLetter = opLetter
111+ , PT.caseSensitive = True
112+ }
113+
114+tokenParser = PT.makeTokenParser langDef
115+
116+lexeme = PT.lexeme tokenParser
117+identifier = PT.identifier tokenParser
118+reserved = PT.reserved tokenParser
119+reservedOp = PT.reservedOp tokenParser
120+operator = PT.operator tokenParser
121+stringLiteral = PT.stringLiteral tokenParser
122+whiteSpace = PT.whiteSpace tokenParser
123+squares = PT.squares tokenParser
124+semi = PT.semi tokenParser
125+comma = PT.comma tokenParser
126+colon = PT.colon tokenParser
127+dot = PT.dot tokenParser
128+natural = PT.natural tokenParser
129+
130+parens = P.between (lexeme $ P.char '(') (lexeme $ indented *> P.char ')') . (indented *>)
131+braces = P.between (lexeme $ P.char '{') (lexeme $ indented *> P.char '}') . (indented *>)
132+angles = P.between (lexeme $ P.char '<') (lexeme $ indented *> P.char '>') . (indented *>)
133+
134+sepBy p s = P.sepBy (indented *> p) (indented *> s)
135+sepBy1 p s = P.sepBy1 (indented *> p) (indented *> s)
136+
137+semiSep = flip sepBy semi
138+semiSep1 = flip sepBy1 semi
139+commaSep = flip sepBy comma
140+commaSep1 = flip sepBy1 comma
141+
142+tick = lexeme $ P.char '`'
143+pipe = lexeme $ P.char '|'
144+
145+properName :: P.Parsec String u ProperName
146+properName = lexeme $ ProperName <$> P.try ((:) <$> P.upper <*> many (PT.identLetter langDef) P.<?> "name")
147+
148+parseQualified :: P.Parsec String ParseState a -> P.Parsec String ParseState (Qualified a)
149+parseQualified parser = part global
150+ where
151+ part path = (do name <- P.try (properName <* delimiter)
152+ part (subModule path name))
153+ <|> (Qualified path <$> P.try parser)
154+ delimiter = indented *> colon <* P.notFollowedBy colon
155+
156+integerOrFloat :: P.Parsec String u (Either Integer Double)
157+integerOrFloat = (Left <$> P.try (PT.natural tokenParser) <|>
158+ Right <$> P.try (PT.float tokenParser)) P.<?> "number"
159+
160+augment :: P.Stream s m t => P.ParsecT s u m a -> P.ParsecT s u m b -> (a -> b -> a) -> P.ParsecT s u m a
161+augment p q f = flip (maybe id $ flip f) <$> p <*> P.optionMaybe q
162+
163+fold :: P.Stream s m t => P.ParsecT s u m a -> P.ParsecT s u m b -> (a -> b -> a) -> P.ParsecT s u m a
164+fold first more combine = do
165+ a <- first
166+ bs <- P.many more
167+ return $ foldl combine a bs
168+
169+buildPostfixParser :: P.Stream s m t => [P.ParsecT s u m (a -> a)] -> P.ParsecT s u m a -> P.ParsecT s u m a
170+buildPostfixParser f x = fold x (P.choice f) (flip ($))
171+
172+operatorOrBuiltIn :: P.Parsec String u String
173+operatorOrBuiltIn = P.try operator <|> P.choice (map (\s -> P.try (reservedOp s) >> return s) builtInOperators)
174+
175+parseIdent :: P.Parsec String ParseState Ident
176+parseIdent = (Ident <$> identifier) <|> (Op <$> parens operatorOrBuiltIn)
177+
178+parseIdentInfix :: P.Parsec String ParseState (Qualified Ident)
179+parseIdentInfix = (P.between tick tick (parseQualified (Ident <$> identifier))) <|> parseQualified (Op <$> operatorOrBuiltIn)
180+
181+mark :: P.Parsec String ParseState a -> P.Parsec String ParseState a
182+mark p = do
183+ current <- indentationLevel <$> P.getState
184+ pos <- P.sourceColumn <$> P.getPosition
185+ P.modifyState $ \st -> st { indentationLevel = pos }
186+ a <- p
187+ P.modifyState $ \st -> st { indentationLevel = current }
188+ return a
189+
190+checkIndentation :: (P.Column -> P.Column -> Bool) -> P.Parsec String ParseState ()
191+checkIndentation rel = do
192+ col <- P.sourceColumn <$> P.getPosition
193+ current <- indentationLevel <$> P.getState
194+ guard (col `rel` current)
195+
196+indented :: P.Parsec String ParseState ()
197+indented = checkIndentation (>) P.<?> "indentation"
198+
199+same :: P.Parsec String ParseState ()
200+same = checkIndentation (==) P.<?> "no indentation"
201+
202+runIndentParser :: P.Parsec String ParseState a -> String -> Either P.ParseError a
203+runIndentParser p = P.runParser p (ParseState 0) ""
src/Language/PureScript/Parser/Declarations.hsnew file+123
@@ -0,0 +1,123 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Parser.Declarations
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+module Language.PureScript.Parser.Declarations (
16+ parseDeclaration,
17+ parseDeclarations
18+) where
19+
20+import Data.Char
21+import Data.List
22+import Data.Maybe
23+import Data.Function
24+import Control.Applicative
25+import Control.Arrow (Arrow(..))
26+import Control.Monad.State
27+import qualified Data.Map as M
28+import qualified Text.Parsec as P
29+import qualified Text.Parsec.Pos as P
30+
31+import Language.PureScript.Names
32+import Language.PureScript.Values
33+import Language.PureScript.Types
34+import Language.PureScript.Parser.State
35+import Language.PureScript.Parser.Common
36+import Language.PureScript.Declarations
37+import Language.PureScript.Parser.Values
38+import Language.PureScript.Parser.Types
39+import Language.PureScript.Parser.Kinds
40+
41+parseDataDeclaration :: P.Parsec String ParseState Declaration
42+parseDataDeclaration = do
43+ reserved "data"
44+ name <- indented *> properName
45+ tyArgs <- many (indented *> identifier)
46+ lexeme $ indented *> P.char '='
47+ ctors <- sepBy1 ((,) <$> properName <*> P.optionMaybe (indented *> parseType)) pipe
48+ return $ DataDeclaration name tyArgs ctors
49+
50+parseTypeDeclaration :: P.Parsec String ParseState Declaration
51+parseTypeDeclaration =
52+ TypeDeclaration <$> P.try (parseIdent <* lexeme (indented *> P.string "::"))
53+ <*> parsePolyType
54+
55+parseTypeSynonymDeclaration :: P.Parsec String ParseState Declaration
56+parseTypeSynonymDeclaration =
57+ TypeSynonymDeclaration <$> (P.try (reserved "type") *> indented *> properName)
58+ <*> many (indented *> identifier)
59+ <*> (lexeme (indented *> P.char '=') *> parseType)
60+
61+parseValueDeclaration :: P.Parsec String ParseState Declaration
62+parseValueDeclaration =
63+ ValueDeclaration <$> P.try (parseIdent <* lexeme (indented *> P.char '='))
64+ <*> parseValue
65+
66+parseExternDeclaration :: P.Parsec String ParseState Declaration
67+parseExternDeclaration = P.try (reserved "foreign") *> indented *> (reserved "import") *> indented *>
68+ (ExternDataDeclaration <$> (P.try (reserved "data") *> indented *> properName)
69+ <*> (lexeme (indented *> P.string "::") *> parseKind)
70+ <|> ExternDeclaration <$> parseIdent
71+ <*> (lexeme (indented *> P.string "::") *> parsePolyType)
72+ <|> ExternMemberDeclaration <$> (P.try (reserved "member") *> indented *> stringLiteral)
73+ <*> (indented *> parseIdent)
74+ <*> (lexeme (indented *> P.string "::") *> parsePolyType))
75+
76+parseAssociativity :: P.Parsec String ParseState Associativity
77+parseAssociativity =
78+ (P.try (reserved "infixl") >> return Infixl) <|>
79+ (P.try (reserved "infixr") >> return Infixr)
80+
81+parseFixity :: P.Parsec String ParseState Fixity
82+parseFixity = Fixity <$> parseAssociativity <*> (indented *> natural)
83+
84+parseFixityDeclaration :: P.Parsec String ParseState Declaration
85+parseFixityDeclaration = do
86+ fixity <- parseFixity
87+ indented
88+ name <- operator
89+ return $ FixityDeclaration fixity name
90+
91+parseModuleDeclaration :: P.Parsec String ParseState Declaration
92+parseModuleDeclaration = do
93+ reserved "module"
94+ indented
95+ name <- properName
96+ lexeme $ P.string "where"
97+ decls <- mark (P.many (same *> parseDeclaration))
98+ return $ ModuleDeclaration name decls
99+
100+parseModulePath :: P.Parsec String ParseState ModulePath
101+parseModulePath = ModulePath <$> properName `sepBy1` dot
102+
103+parseImportDeclaration :: P.Parsec String ParseState Declaration
104+parseImportDeclaration = do
105+ reserved "import"
106+ indented
107+ modulePath <- parseModulePath
108+ idents <- P.optionMaybe $ parens $ commaSep1 parseIdent
109+ return $ ImportDeclaration modulePath idents
110+
111+parseDeclaration :: P.Parsec String ParseState Declaration
112+parseDeclaration = P.choice
113+ [ parseDataDeclaration
114+ , parseTypeDeclaration
115+ , parseTypeSynonymDeclaration
116+ , parseValueDeclaration
117+ , parseExternDeclaration
118+ , parseFixityDeclaration
119+ , parseModuleDeclaration
120+ , parseImportDeclaration ] P.<?> "declaration"
121+
122+parseDeclarations :: P.Parsec String ParseState [Declaration]
123+parseDeclarations = whiteSpace *> mark (P.many (same *> parseDeclaration)) <* P.eof
src/Language/PureScript/Parser/Kinds.hsnew file+41
@@ -0,0 +1,41 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Parser.Kinds
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+module Language.PureScript.Parser.Kinds (
16+ parseKind
17+) where
18+
19+import Language.PureScript.Kinds
20+import Language.PureScript.Parser.State
21+import Language.PureScript.Parser.Common
22+import Control.Applicative
23+import qualified Text.Parsec as P
24+import qualified Text.Parsec.Expr as P
25+
26+parseStar :: P.Parsec String ParseState Kind
27+parseStar = const Star <$> lexeme (P.char '*')
28+
29+parseRow :: P.Parsec String ParseState Kind
30+parseRow = const Row <$> lexeme (P.char '#')
31+
32+parseTypeAtom :: P.Parsec String ParseState Kind
33+parseTypeAtom = indented *> P.choice (map P.try
34+ [ parseStar
35+ , parseRow
36+ , parens parseKind ])
37+
38+parseKind :: P.Parsec String ParseState Kind
39+parseKind = P.buildExpressionParser operators parseTypeAtom P.<?> "kind"
40+ where
41+ operators = [ [ P.Infix (lexeme (P.try (P.string "->")) >> return FunKind) P.AssocRight ] ]
src/Language/PureScript/Parser/State.hsnew file+26
@@ -0,0 +1,26 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Parser.State
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+module Language.PureScript.Parser.State where
16+
17+import Language.PureScript.Names
18+import Language.PureScript.Declarations
19+
20+import qualified Text.Parsec as P
21+import qualified Data.Map as M
22+
23+data ParseState = ParseState
24+ { indentationLevel :: P.Column } deriving Show
25+
26+
src/Language/PureScript/Parser/Types.hsnew file+105
@@ -0,0 +1,105 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Parser.Types
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+module Language.PureScript.Parser.Types (
16+ parseType,
17+ parsePolyType,
18+ parseRow
19+) where
20+
21+import Language.PureScript.Types
22+import Language.PureScript.Parser.State
23+import Language.PureScript.Parser.Common
24+import Control.Applicative
25+import qualified Text.Parsec as P
26+import qualified Text.Parsec.Expr as P
27+import Control.Arrow (Arrow(..))
28+import Control.Monad (unless)
29+
30+parseNumber :: P.Parsec String ParseState Type
31+parseNumber = const Number <$> reserved "Number"
32+
33+parseString :: P.Parsec String ParseState Type
34+parseString = const String <$> reserved "String"
35+
36+parseBoolean :: P.Parsec String ParseState Type
37+parseBoolean = const Boolean <$> reserved "Boolean"
38+
39+parseArray :: P.Parsec String ParseState Type
40+parseArray = squares $ Array <$> parseType
41+
42+parseObject :: P.Parsec String ParseState Type
43+parseObject = braces $ Object <$> parseRow
44+
45+parseFunction :: P.Parsec String ParseState Type
46+parseFunction = do
47+ args <- lexeme $ parens $ commaSep parsePolyType
48+ lexeme $ P.string "->"
49+ resultType <- parseType
50+ return $ Function args resultType
51+
52+parseTypeVariable :: P.Parsec String ParseState Type
53+parseTypeVariable = TypeVar <$> identifier
54+
55+parseTypeConstructor :: P.Parsec String ParseState Type
56+parseTypeConstructor = TypeConstructor <$> parseQualified properName
57+
58+parseForAll :: P.Parsec String ParseState Type
59+parseForAll = (mkForAll <$> (P.try (reserved "forall") *> P.many1 (indented *> identifier) <* indented <* dot)
60+ <*> parseType)
61+
62+parseTypeAtom :: P.Parsec String ParseState Type
63+parseTypeAtom = indented *> P.choice (map P.try
64+ [ parseNumber
65+ , parseString
66+ , parseBoolean
67+ , parseArray
68+ , parseObject
69+ , parseFunction
70+ , parseTypeVariable
71+ , parseTypeConstructor
72+ , parseForAll
73+ , parens parseType ])
74+
75+parseAnyType :: P.Parsec String ParseState Type
76+parseAnyType = (P.buildExpressionParser operators . buildPostfixParser postfixTable $ parseTypeAtom) P.<?> "type"
77+ where
78+ postfixTable :: [P.Parsec String ParseState (Type -> Type)]
79+ postfixTable = [ flip TypeApp <$> P.try (indented *> parseTypeAtom) ]
80+ operators = [ [ P.Infix (lexeme (P.try (P.string "->")) >> return (\t1 t2 -> Function [t1] t2)) P.AssocRight ] ]
81+
82+parseType :: P.Parsec String ParseState Type
83+parseType = do
84+ ty <- parseAnyType
85+ unless (isMonoType ty) $ P.unexpected "polymorphic type"
86+ return ty
87+
88+parsePolyType :: P.Parsec String ParseState PolyType
89+parsePolyType = do
90+ ty <- parseAnyType
91+ unless (isPolyType ty) $ P.unexpected "polymorphic type"
92+ return ty
93+
94+parseNameAndType :: P.Parsec String ParseState (String, Type)
95+parseNameAndType = (,) <$> (indented *> identifier <* indented <* lexeme (P.string "::")) <*> parseType
96+
97+parseRowEnding :: P.Parsec String ParseState Row
98+parseRowEnding = P.option REmpty (RowVar <$> (lexeme (indented *> P.char '|') *> indented *> identifier))
99+
100+parseRow :: P.Parsec String ParseState Row
101+parseRow = (fromList <$> (commaSep parseNameAndType) <*> parseRowEnding) P.<?> "row"
102+ where
103+ fromList :: [(String, Type)] -> Row -> Row
104+ fromList [] r = r
105+ fromList ((name, t):ts) r = RCons name t (fromList ts r)
src/Language/PureScript/Parser/Values.hsnew file+259
@@ -0,0 +1,259 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Parser.Values
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+module Language.PureScript.Parser.Values (
16+ parseValue,
17+ parseBinder
18+) where
19+
20+import Language.PureScript.Values
21+import Language.PureScript.Names
22+import Language.PureScript.Declarations
23+import Language.PureScript.Parser.State
24+import Data.Function (on)
25+import Data.List
26+import Data.Functor.Identity
27+import qualified Data.Map as M
28+import qualified Language.PureScript.Parser.Common as C
29+import Control.Applicative
30+import qualified Text.Parsec as P
31+import Text.Parsec.Expr
32+import Control.Monad
33+import Control.Arrow (Arrow(..))
34+import Language.PureScript.Parser.Types
35+import Language.PureScript.Types
36+
37+booleanLiteral :: P.Parsec String ParseState Bool
38+booleanLiteral = (C.reserved "true" >> return True) P.<|> (C.reserved "false" >> return False)
39+
40+parseNumericLiteral :: P.Parsec String ParseState Value
41+parseNumericLiteral = NumericLiteral <$> C.integerOrFloat
42+
43+parseStringLiteral :: P.Parsec String ParseState Value
44+parseStringLiteral = StringLiteral <$> C.stringLiteral
45+
46+parseBooleanLiteral :: P.Parsec String ParseState Value
47+parseBooleanLiteral = BooleanLiteral <$> booleanLiteral
48+
49+parseArrayLiteral :: P.Parsec String ParseState Value
50+parseArrayLiteral = ArrayLiteral <$> C.squares (C.commaSep parseValue)
51+
52+parseObjectLiteral :: P.Parsec String ParseState Value
53+parseObjectLiteral = ObjectLiteral <$> C.braces (C.commaSep parseIdentifierAndValue)
54+
55+parseIdentifierAndValue :: P.Parsec String ParseState (String, Value)
56+parseIdentifierAndValue = (,) <$> (C.indented *> C.identifier <* C.indented <* C.colon)
57+ <*> (C.indented *> parseValue)
58+
59+parseAbs :: P.Parsec String ParseState Value
60+parseAbs = do
61+ C.lexeme $ P.char '\\'
62+ args <- P.many (C.indented *> (P.try singleArg <|> manyArgs))
63+ C.lexeme $ C.indented *> P.string "->"
64+ value <- parseValue
65+ return $ toFunction args value
66+ where
67+ manyArgs :: P.Parsec String ParseState (Value -> Value)
68+ manyArgs = do
69+ args <- C.parens (C.commaSep C.parseIdent)
70+ return $ Abs args
71+ singleArg :: P.Parsec String ParseState (Value -> Value)
72+ singleArg = Abs . return <$> C.parseIdent
73+ toFunction :: [Value -> Value] -> Value -> Value
74+ toFunction [] value = Abs [] value
75+ toFunction args value = foldr (($)) value args
76+
77+parseApp :: P.Parsec String ParseState Value
78+parseApp = App <$> parseValue
79+ <*> (C.indented *> C.parens (C.commaSep parseValue))
80+
81+parseVar :: P.Parsec String ParseState Value
82+parseVar = Var <$> C.parseQualified C.parseIdent
83+
84+parseConstructor :: P.Parsec String ParseState Value
85+parseConstructor = Constructor <$> C.parseQualified C.properName
86+
87+parseCase :: P.Parsec String ParseState Value
88+parseCase = Case <$> P.between (P.try (C.reserved "case")) (C.indented *> C.reserved "of") parseValue
89+ <*> (C.indented *> C.mark (P.many (C.same *> C.mark parseCaseAlternative)))
90+
91+parseCaseAlternative :: P.Parsec String ParseState (Binder, Value)
92+parseCaseAlternative = (,) <$> (parseGuardedBinder <* C.lexeme (P.string "->"))
93+ <*> parseValue
94+ P.<?> "case alternative"
95+
96+parseIfThenElse :: P.Parsec String ParseState Value
97+parseIfThenElse = IfThenElse <$> (P.try (C.reserved "if") *> C.indented *> parseValue)
98+ <*> (C.indented *> C.reserved "then" *> C.indented *> parseValue)
99+ <*> (C.indented *> C.reserved "else" *> C.indented *> parseValue)
100+
101+parseBlock :: P.Parsec String ParseState Value
102+parseBlock = Block <$> (P.try (C.reserved "do") *> parseManyStatements)
103+
104+parseManyStatements :: P.Parsec String ParseState [Statement]
105+parseManyStatements = C.indented *> C.mark (P.many (C.same *> C.mark parseStatement)) P.<?> "block"
106+
107+parseValueAtom :: P.Parsec String ParseState Value
108+parseValueAtom = C.indented *> P.choice
109+ [ P.try parseNumericLiteral
110+ , P.try parseStringLiteral
111+ , P.try parseBooleanLiteral
112+ , parseArrayLiteral
113+ , parseObjectLiteral
114+ , parseAbs
115+ , P.try parseConstructor
116+ , P.try parseVar
117+ , parseBlock
118+ , parseCase
119+ , parseIfThenElse
120+ , Parens <$> C.parens parseValue ]
121+
122+parsePropertyUpdate :: P.Parsec String ParseState (String, Value)
123+parsePropertyUpdate = do
124+ name <- C.lexeme C.identifier
125+ C.lexeme $ C.indented *> P.char '='
126+ value <- C.indented *> parseValue
127+ return (name, value)
128+
129+parseValue :: P.Parsec String ParseState Value
130+parseValue =
131+ (buildExpressionParser operators
132+ . C.buildPostfixParser postfixTable2
133+ $ indexersAndAccessors) P.<?> "expression"
134+ where
135+ indexersAndAccessors = C.buildPostfixParser postfixTable1 parseValueAtom
136+ postfixTable1 = [ Accessor <$> (C.indented *> C.dot *> C.indented *> C.identifier)
137+ , P.try $ flip ObjectUpdate <$> (C.indented *> C.braces (C.commaSep1 (C.indented *> parsePropertyUpdate))) ]
138+ postfixTable2 = [ P.try (C.indented *> indexersAndAccessors >>= \t2 -> return (\t1 -> App t1 [t2]))
139+ , P.try $ flip App <$> (C.indented *> C.parens (C.commaSep parseValue))
140+ , flip TypedValue <$> (P.try (C.lexeme (C.indented *> P.string "::")) *> parsePolyType) ]
141+ operators = [ [ Prefix $ C.lexeme (P.try $ C.indented *> C.reservedOp "!") >> return (Unary Not)
142+ , Prefix $ C.lexeme (P.try $ C.indented *> C.reservedOp "~") >> return (Unary BitwiseNot)
143+ , Prefix $ C.lexeme (P.try $ C.indented *> C.reservedOp "-") >> return (Unary Negate)
144+ , Prefix $ C.lexeme (P.try $ C.indented *> C.reservedOp "+") >> return id ]
145+ , [ Infix (C.lexeme (P.try (C.indented *> C.parseIdentInfix P.<?> "operator") >>= \ident ->
146+ return (BinaryNoParens ident))) AssocRight ]
147+ ]
148+
149+parseVariableIntroduction :: P.Parsec String ParseState Statement
150+parseVariableIntroduction = do
151+ C.reserved "var"
152+ name <- C.indented *> C.parseIdent
153+ C.lexeme $ C.indented *> P.char '='
154+ value <- parseValue
155+ return $ VariableIntroduction name value
156+
157+parseAssignment :: P.Parsec String ParseState Statement
158+parseAssignment = do
159+ tgt <- C.parseIdent
160+ C.lexeme $ C.indented *> P.char '='
161+ value <- parseValue
162+ return $ Assignment tgt value
163+
164+parseWhile :: P.Parsec String ParseState Statement
165+parseWhile = While <$> (C.reserved "while" *> C.indented *> parseValue <* C.indented <* C.colon)
166+ <*> parseManyStatements
167+
168+parseFor :: P.Parsec String ParseState Statement
169+parseFor = For <$> (C.reserved "for" *> C.indented *> C.parseIdent)
170+ <*> (C.indented *> C.lexeme (P.string "<-") *> parseValue)
171+ <*> (C.indented *> C.reserved "until" *> parseValue <* C.colon)
172+ <*> parseManyStatements
173+
174+parseForEach :: P.Parsec String ParseState Statement
175+parseForEach = ForEach <$> (C.reserved "foreach" *> C.indented *> C.parseIdent)
176+ <*> (C.indented *> C.reserved "in" *> parseValue <* C.colon)
177+ <*> parseManyStatements
178+
179+parseIf :: P.Parsec String ParseState Statement
180+parseIf = If <$> parseIfStatement
181+
182+parseIfStatement :: P.Parsec String ParseState IfStatement
183+parseIfStatement =
184+ IfStatement <$> (C.reserved "if" *> C.indented *> parseValue <* C.indented <* C.colon)
185+ <*> parseManyStatements
186+ <*> P.optionMaybe (C.same *> parseElseStatement)
187+
188+parseElseStatement :: P.Parsec String ParseState ElseStatement
189+parseElseStatement = C.reserved "else" >> (ElseIf <$> (C.indented *> parseIfStatement)
190+ <|> Else <$> (C.indented *> C.colon *> parseManyStatements))
191+
192+parseReturn :: P.Parsec String ParseState Statement
193+parseReturn = Return <$> (C.reserved "return" *> parseValue)
194+
195+parseStatement :: P.Parsec String ParseState Statement
196+parseStatement = P.choice (map P.try
197+ [ parseVariableIntroduction
198+ , parseAssignment
199+ , parseWhile
200+ , parseFor
201+ , parseForEach
202+ , parseIf
203+ , parseReturn ]) P.<?> "statement"
204+
205+parseStringBinder :: P.Parsec String ParseState Binder
206+parseStringBinder = StringBinder <$> C.stringLiteral
207+
208+parseBooleanBinder :: P.Parsec String ParseState Binder
209+parseBooleanBinder = BooleanBinder <$> booleanLiteral
210+
211+parseNumberBinder :: P.Parsec String ParseState Binder
212+parseNumberBinder = NumberBinder <$> C.integerOrFloat
213+
214+parseVarBinder :: P.Parsec String ParseState Binder
215+parseVarBinder = VarBinder <$> C.parseIdent
216+
217+parseNullaryBinder :: P.Parsec String ParseState Binder
218+parseNullaryBinder = NullaryBinder <$> C.lexeme (C.parseQualified C.properName)
219+
220+parseUnaryBinder :: P.Parsec String ParseState Binder
221+parseUnaryBinder = UnaryBinder <$> C.lexeme (C.parseQualified C.properName) <*> (C.indented *> parseBinder)
222+
223+parseObjectBinder :: P.Parsec String ParseState Binder
224+parseObjectBinder = ObjectBinder <$> C.braces (C.commaSep (C.indented *> parseIdentifierAndBinder))
225+
226+parseArrayBinder :: P.Parsec String ParseState Binder
227+parseArrayBinder = C.squares $ ArrayBinder <$> (C.commaSep (C.indented *> parseBinder))
228+ <*> P.optionMaybe (C.indented *> C.colon *> C.indented *> parseBinder)
229+
230+parseNamedBinder :: P.Parsec String ParseState Binder
231+parseNamedBinder = NamedBinder <$> (C.parseIdent <* C.indented <* C.lexeme (P.char '@'))
232+ <*> (C.indented *> parseBinder)
233+
234+parseNullBinder :: P.Parsec String ParseState Binder
235+parseNullBinder = C.lexeme (P.char '_') *> P.notFollowedBy C.identLetter *> return NullBinder
236+
237+parseIdentifierAndBinder :: P.Parsec String ParseState (String, Binder)
238+parseIdentifierAndBinder = do
239+ name <- C.lexeme C.identifier
240+ C.lexeme $ C.indented *> P.char '='
241+ binder <- C.indented *> parseBinder
242+ return (name, binder)
243+
244+parseBinder :: P.Parsec String ParseState Binder
245+parseBinder = P.choice (map P.try
246+ [ parseNullBinder
247+ , parseStringBinder
248+ , parseBooleanBinder
249+ , parseNumberBinder
250+ , parseNamedBinder
251+ , parseVarBinder
252+ , parseUnaryBinder
253+ , parseNullaryBinder
254+ , parseObjectBinder
255+ , parseArrayBinder
256+ , C.parens parseBinder ]) P.<?> "binder"
257+
258+parseGuardedBinder :: P.Parsec String ParseState Binder
259+parseGuardedBinder = flip ($) <$> parseBinder <*> P.option id (GuardedBinder <$> (C.indented *> C.lexeme (P.char '|') *> C.indented *> parseValue))
src/Language/PureScript/Pretty.hsnew file+23
@@ -0,0 +1,23 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Pretty
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+module Language.PureScript.Pretty (module P) where
16+
17+import Language.PureScript.Pretty.Kinds as P
18+import Language.PureScript.Pretty.Values as P
19+import Language.PureScript.Pretty.Types as P
20+import Language.PureScript.Pretty.JS as P
21+
22+
23+
src/Language/PureScript/Pretty/Common.hsnew file+86
@@ -0,0 +1,86 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Pretty.Common
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+{-# LANGUAGE GeneralizedNewtypeDeriving, GADTs #-}
16+
17+module Language.PureScript.Pretty.Common where
18+
19+import Data.Char
20+import Data.Maybe (fromMaybe)
21+import Data.List (nub, intersperse, intercalate)
22+import Data.Function (fix)
23+import Control.Monad.State
24+import Control.Applicative (Applicative(..), Alternative(..))
25+import qualified Control.Category as C
26+import Control.Category ((>>>))
27+import qualified Control.Arrow as A
28+import Control.Arrow ((***), (<+>))
29+
30+import Language.PureScript.Names
31+import Language.PureScript.Values
32+import Language.PureScript.Types
33+import Language.PureScript.Declarations
34+
35+identToJs :: Ident -> String
36+identToJs (Ident name) = name
37+identToJs (Op op) = concatMap opCharToString op
38+ where
39+ opCharToString :: Char -> String
40+ opCharToString = (:) '$'. show . ord
41+
42+newtype Pattern u a b = Pattern { runPattern :: A.Kleisli (StateT u Maybe) a b } deriving (C.Category, A.Arrow, A.ArrowZero, A.ArrowPlus)
43+
44+instance Functor (Pattern u a) where
45+ fmap f (Pattern p) = Pattern $ A.Kleisli $ fmap f . A.runKleisli p
46+
47+pattern :: Pattern u a b -> u -> a -> Maybe b
48+pattern p u = flip evalStateT u . A.runKleisli (runPattern p)
49+
50+mkPattern :: (a -> Maybe b) -> Pattern u a b
51+mkPattern f = Pattern $ A.Kleisli (lift . f)
52+
53+mkPattern' :: (a -> StateT u Maybe b) -> Pattern u a b
54+mkPattern' = Pattern . A.Kleisli
55+
56+parens :: String -> String
57+parens s = ('(':s) ++ ")"
58+
59+chainl :: Pattern u a (a, a) -> (r -> r -> r) -> Pattern u a r -> Pattern u a r
60+chainl split f p = fix $ \c -> split >>> ((c <+> p) *** p) >>> A.arr (uncurry f)
61+
62+chainr :: Pattern u a (a, a) -> (r -> r -> r) -> Pattern u a r -> Pattern u a r
63+chainr split f p = fix $ \c -> split >>> (p *** (c <+> p)) >>> A.arr (uncurry f)
64+
65+wrap :: Pattern u a (s, a) -> (s -> r -> r) -> Pattern u a r -> Pattern u a r
66+wrap split f p = fix $ \c -> split >>> (C.id *** (c <+> p)) >>> A.arr (uncurry f)
67+
68+split :: Pattern u a (s, t) -> (s -> t -> r) -> Pattern u a r -> Pattern u a r
69+split s f p = s >>> A.arr (uncurry f)
70+
71+data OperatorTable u a r = OperatorTable { runOperatorTable :: [ [Operator u a r] ] }
72+
73+data Operator u a r where
74+ AssocL :: Pattern u a (a, a) -> (r -> r -> r) -> Operator u a r
75+ AssocR :: Pattern u a (a, a) -> (r -> r -> r) -> Operator u a r
76+ Wrap :: Pattern u a (s, a) -> (s -> r -> r) -> Operator u a r
77+ Split :: Pattern u a (s, t) -> (s -> t -> r) -> Operator u a r
78+
79+buildPrettyPrinter :: OperatorTable u a r -> Pattern u a r -> Pattern u a r
80+buildPrettyPrinter table p = foldl (\p' ops -> foldl1 (<+>) (flip map ops $ \op ->
81+ case op of
82+ AssocL pat g -> chainl pat g p'
83+ AssocR pat g -> chainr pat g p'
84+ Wrap pat g -> wrap pat g p'
85+ Split pat g -> split pat g p'
86+ ) <+> p') p $ runOperatorTable table
src/Language/PureScript/Pretty/JS.hsnew file+225
@@ -0,0 +1,225 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Pretty.JS
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+module Language.PureScript.Pretty.JS (
16+ prettyPrintJS
17+) where
18+
19+import Language.PureScript.Names
20+import Language.PureScript.Values
21+import Language.PureScript.Pretty.Common
22+import Language.PureScript.CodeGen.JS.AST
23+
24+import Data.List
25+import Data.Maybe (fromMaybe)
26+import qualified Control.Arrow as A
27+import Control.Arrow ((***), (<+>), first, second)
28+import Control.Applicative
29+import Control.Monad.State
30+
31+newtype PrinterState = PrinterState { indent :: Int } deriving (Show, Eq, Ord)
32+
33+blockIndent :: Int
34+blockIndent = 4
35+
36+withIndent :: StateT PrinterState Maybe String -> StateT PrinterState Maybe String
37+withIndent s = do
38+ current <- get
39+ modify $ \s -> s { indent = indent s + blockIndent }
40+ result <- s
41+ modify $ \s -> s { indent = indent s - blockIndent }
42+ return result
43+
44+currentIndent :: StateT PrinterState Maybe String
45+currentIndent = do
46+ current <- get
47+ return $ replicate (indent current) ' '
48+
49+literals :: Pattern PrinterState JS String
50+literals = mkPattern' match
51+ where
52+ match :: JS -> StateT PrinterState Maybe String
53+ match (JSNumericLiteral n) = return $ either show show n
54+ match (JSStringLiteral s) = return $ show s
55+ match (JSBooleanLiteral True) = return "true"
56+ match (JSBooleanLiteral False) = return "false"
57+ match (JSArrayLiteral xs) = fmap concat $ sequence
58+ [ return "[ "
59+ , fmap (intercalate ", ") $ forM xs prettyPrintJS'
60+ , return " ]"
61+ ]
62+ match (JSObjectLiteral ps) = fmap concat $ sequence
63+ [ return "{\n"
64+ , withIndent $ do
65+ jss <- forM ps $ \(key, value) -> fmap ((key ++ ": ") ++) . prettyPrintJS' $ value
66+ indentString <- currentIndent
67+ return $ intercalate ", \n" $ map (indentString ++) jss
68+ , return "\n"
69+ , currentIndent
70+ , return "}"
71+ ]
72+ match (JSBlock sts) = fmap concat $ sequence
73+ [ return "{\n"
74+ , withIndent $ do
75+ jss <- forM sts prettyPrintJS'
76+ indentString <- currentIndent
77+ return $ intercalate "\n" $ map (++ "; ") $ map (indentString ++) jss
78+ , return "\n"
79+ , currentIndent
80+ , return "}"
81+ ]
82+ match (JSVar ident) = return (identToJs ident)
83+ match (JSVariableIntroduction ident value) = fmap concat $ sequence
84+ [ return "var "
85+ , return $ identToJs ident
86+ , maybe (return "") (fmap (" = " ++) . prettyPrintJS') value
87+ ]
88+ match (JSAssignment target value) = fmap concat $ sequence
89+ [ return $ targetToJs target
90+ , return " = "
91+ , prettyPrintJS' value
92+ ]
93+ match (JSWhile cond sts) = fmap concat $ sequence
94+ [ return "while ("
95+ , prettyPrintJS' cond
96+ , return ") "
97+ , prettyPrintJS' sts
98+ ]
99+ match (JSFor ident start end sts) = fmap concat $ sequence
100+ [ return $ "for (" ++ identToJs ident ++ " = "
101+ , prettyPrintJS' start
102+ , return $ "; " ++ identToJs ident ++ " < "
103+ , prettyPrintJS' end
104+ , return $ "; " ++ identToJs ident ++ "++) "
105+ , prettyPrintJS' sts
106+ ]
107+ match (JSIfElse cond thens elses) = fmap concat $ sequence
108+ [ return "if ("
109+ , prettyPrintJS' cond
110+ , return ") "
111+ , prettyPrintJS' thens
112+ , maybe (return "") (fmap (" else " ++) . prettyPrintJS') elses
113+ ]
114+ match (JSReturn value) = fmap concat $ sequence
115+ [ return "return "
116+ , prettyPrintJS' value
117+ ]
118+ match (JSThrow value) = fmap concat $ sequence
119+ [ return "throw "
120+ , prettyPrintJS' value
121+ ]
122+ match _ = mzero
123+
124+targetToJs :: JSAssignment -> String
125+targetToJs (JSAssignVariable ident) = identToJs ident
126+targetToJs (JSAssignProperty prop target) = targetToJs target ++ "." ++ prop
127+
128+conditional :: Pattern PrinterState JS ((JS, JS), JS)
129+conditional = mkPattern match
130+ where
131+ match (JSConditional cond th el) = Just ((th, el), cond)
132+ match _ = Nothing
133+
134+accessor :: Pattern PrinterState JS (String, JS)
135+accessor = mkPattern match
136+ where
137+ match (JSAccessor prop val) = Just (prop, val)
138+ match _ = Nothing
139+
140+indexer :: Pattern PrinterState JS (String, JS)
141+indexer = mkPattern' match
142+ where
143+ match (JSIndexer index val) = (,) <$> prettyPrintJS' index <*> pure val
144+ match _ = mzero
145+
146+lam :: Pattern PrinterState JS ((Maybe Ident, [Ident]), JS)
147+lam = mkPattern match
148+ where
149+ match (JSFunction name args ret) = Just ((name, args), ret)
150+ match _ = Nothing
151+
152+app :: Pattern PrinterState JS (String, JS)
153+app = mkPattern' match
154+ where
155+ match (JSApp val args) = do
156+ jss <- mapM prettyPrintJS' args
157+ return (intercalate ", " jss, val)
158+ match _ = mzero
159+
160+unary :: UnaryOperator -> String -> Operator PrinterState JS String
161+unary op str = Wrap pattern (++)
162+ where
163+ pattern :: Pattern PrinterState JS (String, JS)
164+ pattern = mkPattern match
165+ where
166+ match (JSUnary op' val) | op' == op = Just (str, val)
167+ match _ = Nothing
168+
169+binary :: BinaryOperator -> String -> Operator PrinterState JS String
170+binary op str = AssocR pattern (\v1 v2 -> v1 ++ " " ++ str ++ " " ++ v2)
171+ where
172+ pattern :: Pattern PrinterState JS (JS, JS)
173+ pattern = mkPattern match
174+ where
175+ match (JSBinary op' v1 v2) | op' == op = Just (v1, v2)
176+ match _ = Nothing
177+
178+prettyPrintJS1 :: JS -> String
179+prettyPrintJS1 = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyPrintJS'
180+
181+prettyPrintJS :: [JS] -> String
182+prettyPrintJS sts = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) $ do
183+ jss <- forM sts prettyPrintJS'
184+ indentString <- currentIndent
185+ return $ intercalate "\n" $ map (++ "; ") $ map (indentString ++) jss
186+
187+prettyPrintJS' :: JS -> StateT PrinterState Maybe String
188+prettyPrintJS' = A.runKleisli $ runPattern matchValue
189+ where
190+ matchValue :: Pattern PrinterState JS String
191+ matchValue = buildPrettyPrinter operators (literals <+> fmap parens matchValue)
192+ operators :: OperatorTable PrinterState JS String
193+ operators =
194+ OperatorTable [ [ Wrap accessor $ \prop val -> val ++ "." ++ prop ]
195+ , [ Wrap indexer $ \index val -> val ++ "[" ++ index ++ "]" ]
196+ , [ Wrap app $ \args val -> val ++ "(" ++ args ++ ")" ]
197+ , [ Wrap lam $ \(name, args) ret -> "function "
198+ ++ maybe "" identToJs name
199+ ++ "(" ++ intercalate ", " (map identToJs args) ++ ") "
200+ ++ ret ]
201+ , [ Wrap conditional $ \(th, el) cond -> cond ++ " ? " ++ prettyPrintJS1 th ++ " : " ++ prettyPrintJS1 el ]
202+ , [ binary LessThan "<" ]
203+ , [ binary LessThanOrEqualTo "<=" ]
204+ , [ binary GreaterThan ">" ]
205+ , [ binary GreaterThanOrEqualTo ">=" ]
206+ , [ unary Not "!" ]
207+ , [ unary BitwiseNot "~" ]
208+ , [ unary Negate "-" ]
209+ , [ binary Multiply "*" ]
210+ , [ binary Divide "/" ]
211+ , [ binary Modulus "%" ]
212+ , [ binary Concat "+" ]
213+ , [ binary Add "+" ]
214+ , [ binary Subtract "-" ]
215+ , [ binary ShiftLeft "<<" ]
216+ , [ binary ShiftRight ">>" ]
217+ , [ binary ZeroFillShiftRight ">>>" ]
218+ , [ binary EqualTo "===" ]
219+ , [ binary NotEqualTo "!==" ]
220+ , [ binary BitwiseAnd "&" ]
221+ , [ binary BitwiseXor "^" ]
222+ , [ binary BitwiseOr "|" ]
223+ , [ binary And "&&" ]
224+ , [ binary Or "||" ]
225+ ]
src/Language/PureScript/Pretty/Kinds.hsnew file+51
@@ -0,0 +1,51 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Pretty.Kinds
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+module Language.PureScript.Pretty.Kinds (
16+ prettyPrintKind
17+) where
18+
19+import Data.Maybe (fromMaybe)
20+import Data.List (intersperse, intercalate)
21+import qualified Control.Arrow as A
22+import Control.Arrow ((<+>))
23+import qualified Data.Map as M
24+import Control.Applicative
25+
26+import Language.PureScript.Kinds
27+import Language.PureScript.Pretty.Common
28+import Language.PureScript.Unknown
29+
30+typeLiterals :: Pattern () Kind String
31+typeLiterals = mkPattern match
32+ where
33+ match Star = Just "*"
34+ match Row = Just "#"
35+ match (KUnknown (Unknown u)) = Just $ 'u' : show u
36+ match _ = Nothing
37+
38+funKind :: Pattern () Kind (Kind, Kind)
39+funKind = mkPattern match
40+ where
41+ match (FunKind arg ret) = Just (arg, ret)
42+ match _ = Nothing
43+
44+prettyPrintKind :: Kind -> String
45+prettyPrintKind = fromMaybe (error "Incomplete pattern") . pattern matchKind ()
46+ where
47+ matchKind :: Pattern () Kind String
48+ matchKind = buildPrettyPrinter operators (typeLiterals <+> fmap parens matchKind)
49+ operators :: OperatorTable () Kind String
50+ operators =
51+ OperatorTable [ [ AssocR funKind $ \arg ret -> arg ++ " -> " ++ ret ] ]
src/Language/PureScript/Pretty/Types.hsnew file+94
@@ -0,0 +1,94 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Pretty.Types
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+module Language.PureScript.Pretty.Types (
16+ prettyPrintType,
17+ prettyPrintRow
18+) where
19+
20+import Data.Maybe (fromMaybe)
21+import Data.List (intersperse, intercalate)
22+import qualified Control.Arrow as A
23+import Control.Arrow ((<+>))
24+import qualified Data.Map as M
25+import Control.Applicative
26+
27+import Language.PureScript.Values
28+import Language.PureScript.Types
29+import Language.PureScript.Names
30+import Language.PureScript.Declarations
31+import Language.PureScript.TypeChecker.Monad
32+import Language.PureScript.Pretty.Common
33+import Language.PureScript.Unknown
34+
35+typeLiterals :: Pattern () Type String
36+typeLiterals = mkPattern match
37+ where
38+ match Number = Just "Number"
39+ match String = Just "String"
40+ match Boolean = Just "Boolean"
41+ match (Array ty) = Just $ "[" ++ prettyPrintType ty ++ "]"
42+ match (Object row) = Just $ "{ " ++ prettyPrintRow row ++ " }"
43+ match (TypeVar var) = Just var
44+ match (TypeConstructor ctor) = Just $ show ctor
45+ match (TUnknown (Unknown u)) = Just $ 'u' : show u
46+ match (Skolem s) = Just $ 's' : show s
47+ match (SaturatedTypeSynonym name args) = Just $ show name ++ "<" ++ intercalate "," (map prettyPrintType args) ++ ">"
48+ match (ForAll ident ty) = Just $ "forall " ++ ident ++ ". " ++ prettyPrintType ty
49+ match _ = Nothing
50+
51+prettyPrintRow :: Row -> String
52+prettyPrintRow = (\(tys, tail) -> intercalate ", " (map (uncurry nameAndTypeToPs) tys) ++ tailToPs tail) . toList []
53+ where
54+ nameAndTypeToPs :: String -> Type -> String
55+ nameAndTypeToPs name ty = name ++ " :: " ++ prettyPrintType ty
56+ tailToPs :: Row -> String
57+ tailToPs REmpty = ""
58+ tailToPs (RUnknown (Unknown u)) = " | u" ++ show u
59+ tailToPs (RowVar var) = " | " ++ var
60+ tailToPs (RSkolem s) = " | s" ++ show s
61+ toList :: [(String, Type)] -> Row -> ([(String, Type)], Row)
62+ toList tys (RCons name ty row) = toList ((name, ty):tys) row
63+ toList tys r = (tys, r)
64+
65+typeApp :: Pattern () Type (Type, Type)
66+typeApp = mkPattern match
67+ where
68+ match (TypeApp f x) = Just (f, x)
69+ match _ = Nothing
70+
71+singleArgumentFunction :: Pattern () Type (Type, Type)
72+singleArgumentFunction = mkPattern match
73+ where
74+ match (Function [arg] ret) = Just (arg, ret)
75+ match _ = Nothing
76+
77+function :: Pattern () Type ([Type], Type)
78+function = mkPattern match
79+ where
80+ match (Function args ret) = Just (args, ret)
81+ match _ = Nothing
82+
83+prettyPrintType :: Type -> String
84+prettyPrintType = fromMaybe (error "Incomplete pattern") . pattern matchType ()
85+ where
86+ matchType :: Pattern () Type String
87+ matchType = buildPrettyPrinter operators (typeLiterals <+> fmap parens matchType)
88+ operators :: OperatorTable () Type String
89+ operators =
90+ OperatorTable [ [ AssocL typeApp $ \f x -> f ++ " " ++ x ]
91+ , [ AssocR singleArgumentFunction $ \arg ret -> arg ++ " -> " ++ ret
92+ , Wrap function $ \args ret -> "(" ++ intercalate ", " (map prettyPrintType args) ++ ") -> " ++ ret
93+ ]
94+ ]
src/Language/PureScript/Pretty/Values.hsnew file+193
@@ -0,0 +1,193 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Pretty.Values
4+-- Copyright : Kinds.hs(c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+module Language.PureScript.Pretty.Values (
16+ prettyPrintValue,
17+ prettyPrintBinder
18+) where
19+
20+import Data.Char
21+import Data.Maybe (fromMaybe)
22+import Data.List (intercalate)
23+import qualified Control.Arrow as A
24+import Control.Arrow ((<+>))
25+import Control.Applicative
26+
27+import Language.PureScript.Types
28+import Language.PureScript.Values
29+import Language.PureScript.Names
30+import Language.PureScript.Pretty.Common
31+import Language.PureScript.Pretty.Types
32+
33+literals :: Pattern () Value String
34+literals = mkPattern match
35+ where
36+ match (NumericLiteral n) = Just $ either show show n
37+ match (StringLiteral s) = Just $ show s
38+ match (BooleanLiteral True) = Just "true"
39+ match (BooleanLiteral False) = Just "false"
40+ match (ArrayLiteral xs) = Just $ "[" ++ intercalate ", " (map prettyPrintValue xs) ++ "]"
41+ match (ObjectLiteral ps) = Just $ "{" ++ intercalate ", " (map (uncurry prettyPrintObjectProperty) ps) ++ "}"
42+ match (Constructor name) = Just $ show name
43+ match (Block sts) = Just $ "do { " ++ intercalate " ; " (map prettyPrintStatement sts) ++ " }"
44+ match (Case value binders) = Just $ "case " ++ prettyPrintValue value ++ " of { " ++ intercalate " ; " (map (uncurry prettyPrintCaseAlternative) binders) ++ " }"
45+ match (Var ident) = Just $ show ident
46+ match _ = Nothing
47+
48+prettyPrintCaseAlternative :: Binder -> Value -> String
49+prettyPrintCaseAlternative binder val = prettyPrintBinder binder ++ " -> " ++ prettyPrintValue val
50+
51+ifThenElse :: Pattern () Value ((Value, Value), Value)
52+ifThenElse = mkPattern match
53+ where
54+ match (IfThenElse cond th el) = Just ((th, el), cond)
55+ match _ = Nothing
56+
57+accessor :: Pattern () Value (String, Value)
58+accessor = mkPattern match
59+ where
60+ match (Accessor prop val) = Just (prop, val)
61+ match _ = Nothing
62+
63+indexer :: Pattern () Value (Value, Value)
64+indexer = mkPattern match
65+ where
66+ match (Indexer index val) = Just (index, val)
67+ match _ = Nothing
68+
69+objectUpdate :: Pattern () Value ([String], Value)
70+objectUpdate = mkPattern match
71+ where
72+ match (ObjectUpdate o ps) = Just (flip map ps $ \(key, val) -> key ++ " = " ++ prettyPrintValue val, o)
73+ match _ = Nothing
74+
75+app :: Pattern () Value (String, Value)
76+app = mkPattern match
77+ where
78+ match (App val args) = Just (intercalate "," (map prettyPrintValue args), val)
79+ match _ = Nothing
80+
81+lam :: Pattern () Value ([String], Value)
82+lam = mkPattern match
83+ where
84+ match (Abs args val) = Just (map show args, val)
85+ match _ = Nothing
86+
87+typed :: Pattern () Value (PolyType, Value)
88+typed = mkPattern match
89+ where
90+ match (TypedValue val ty) = Just (ty, val)
91+ match _ = Nothing
92+
93+unary :: UnaryOperator -> String -> Operator () Value String
94+unary op str = Wrap pattern (++)
95+ where
96+ pattern :: Pattern () Value (String, Value)
97+ pattern = mkPattern match
98+ where
99+ match (Unary op' val) | op' == op = Just (str, val)
100+ match _ = Nothing
101+
102+binary :: BinaryOperator -> String -> Operator () Value String
103+binary op str = AssocR pattern (\v1 v2 -> v1 ++ " " ++ str ++ " " ++ v2)
104+ where
105+ pattern :: Pattern () Value (Value, Value)
106+ pattern = mkPattern match
107+ where
108+ match (Binary op' v1 v2) | op' == op = Just (v1, v2)
109+ match _ = Nothing
110+
111+prettyPrintValue :: Value -> String
112+prettyPrintValue = fromMaybe (error "Incomplete pattern") . pattern matchValue ()
113+ where
114+ matchValue :: Pattern () Value String
115+ matchValue = buildPrettyPrinter operators (literals <+> fmap parens matchValue)
116+ operators :: OperatorTable () Value String
117+ operators =
118+ OperatorTable [ [ Wrap accessor $ \prop val -> val ++ "." ++ prop ]
119+ , [ Wrap objectUpdate $ \ps val -> val ++ "{ " ++ intercalate ", " ps ++ " }" ]
120+ , [ Wrap app $ \args val -> val ++ "(" ++ args ++ ")" ]
121+ , [ Split lam $ \args val -> "\\" ++ intercalate ", " args ++ " -> " ++ prettyPrintValue val ]
122+ , [ Wrap ifThenElse $ \(th, el) cond -> cond ++ " ? " ++ prettyPrintValue th ++ " : " ++ prettyPrintValue el ]
123+ , [ Wrap typed $ \ty val -> val ++ " :: " ++ prettyPrintType ty ]
124+ , [ AssocR indexer (\index val -> val ++ " !! " ++ index) ]
125+ , [ binary LessThan "<" ]
126+ , [ binary LessThanOrEqualTo "<=" ]
127+ , [ binary GreaterThan ">" ]
128+ , [ binary GreaterThanOrEqualTo ">=" ]
129+ , [ unary Not "!" ]
130+ , [ unary BitwiseNot "~" ]
131+ , [ unary Negate "-" ]
132+ , [ binary Multiply "*" ]
133+ , [ binary Divide "/" ]
134+ , [ binary Modulus "%" ]
135+ , [ binary Concat "++" ]
136+ , [ binary Add "+" ]
137+ , [ binary Subtract "-" ]
138+ , [ binary ShiftLeft "<<" ]
139+ , [ binary ShiftRight ">>" ]
140+ , [ binary ZeroFillShiftRight ">>>" ]
141+ , [ binary EqualTo "==" ]
142+ , [ binary NotEqualTo "!=" ]
143+ , [ binary BitwiseAnd "&" ]
144+ , [ binary BitwiseXor "^" ]
145+ , [ binary BitwiseOr "|" ]
146+ , [ binary And "&&" ]
147+ , [ binary Or "||" ]
148+ ]
149+
150+prettyPrintBinder :: Binder -> String
151+prettyPrintBinder NullBinder = "_"
152+prettyPrintBinder (StringBinder str) = show str
153+prettyPrintBinder (NumberBinder num) = either show show num
154+prettyPrintBinder (BooleanBinder True) = "true"
155+prettyPrintBinder (BooleanBinder False) = "false"
156+prettyPrintBinder (VarBinder ident) = show ident
157+prettyPrintBinder (NullaryBinder ctor) = show ctor
158+prettyPrintBinder (UnaryBinder ctor b) = show ctor ++ prettyPrintBinder b
159+prettyPrintBinder (ObjectBinder bs) = "{ " ++ intercalate ", " (map (uncurry prettyPrintObjectPropertyBinder) bs) ++ " }"
160+prettyPrintBinder (ArrayBinder bs rest) = "[ " ++ intercalate ", " (map prettyPrintBinder bs) ++ maybe "" (("; " ++) . prettyPrintBinder) rest ++ " ]"
161+prettyPrintBinder (NamedBinder ident binder) = show ident ++ "@" ++ prettyPrintBinder binder
162+prettyPrintBinder (GuardedBinder cond binder) = prettyPrintBinder binder ++ " | " ++ prettyPrintValue cond
163+
164+prettyPrintObjectPropertyBinder :: String -> Binder -> String
165+prettyPrintObjectPropertyBinder key binder = key ++ ": " ++ prettyPrintBinder binder
166+
167+prettyPrintObjectProperty :: String -> Value -> String
168+prettyPrintObjectProperty key value = key ++ ": " ++ prettyPrintValue value
169+
170+prettyPrintStatement :: Statement -> String
171+prettyPrintStatement (VariableIntroduction ident value) = "var " ++ show ident ++ " = " ++ prettyPrintValue value
172+prettyPrintStatement (Assignment target value) = show target ++ " = " ++ prettyPrintValue value
173+prettyPrintStatement (While cond sts) = "while " ++ prettyPrintValue cond ++ ": {" ++ intercalate ";" (map prettyPrintStatement sts) ++ " }"
174+prettyPrintStatement (For ident start end sts) = "for " ++ show ident
175+ ++ " <- " ++ prettyPrintValue start
176+ ++ " until " ++ prettyPrintValue end ++ ": {"
177+ ++ intercalate "; " (map prettyPrintStatement sts) ++ " }"
178+prettyPrintStatement (ForEach ident arr sts) = "foreach " ++ show ident
179+ ++ " in " ++ prettyPrintValue arr ++ ": {"
180+ ++ intercalate "; " (map prettyPrintStatement sts) ++ " }"
181+prettyPrintStatement (If ifst) = prettyPrintIfStatement ifst
182+prettyPrintStatement (Return value) = "return " ++ prettyPrintValue value
183+
184+prettyPrintIfStatement :: IfStatement -> String
185+prettyPrintIfStatement (IfStatement cond thens elst) =
186+ "if "
187+ ++ prettyPrintValue cond ++ ": {"
188+ ++ intercalate "; " (map prettyPrintStatement thens) ++ " }"
189+ ++ maybe "" prettyPrintElseStatement elst
190+
191+prettyPrintElseStatement :: ElseStatement -> String
192+prettyPrintElseStatement (Else sts) = "else: {" ++ intercalate "; " (map prettyPrintStatement sts) ++ " }"
193+prettyPrintElseStatement (ElseIf ifst) = "else " ++ prettyPrintIfStatement ifst
src/Language/PureScript/TypeChecker.hsnew file+137
@@ -0,0 +1,137 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.TypeChecker
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+{-# LANGUAGE FlexibleInstances #-}
16+
17+module Language.PureScript.TypeChecker (
18+ module T,
19+ typeCheckAll
20+) where
21+
22+import Language.PureScript.TypeChecker.Monad as T
23+import Language.PureScript.TypeChecker.Kinds as T
24+import Language.PureScript.TypeChecker.Types as T
25+import Language.PureScript.TypeChecker.Synonyms as T
26+
27+import Data.List
28+import Data.Maybe
29+import Data.Function
30+import qualified Data.Map as M
31+
32+import Language.PureScript.Values
33+import Language.PureScript.Types
34+import Language.PureScript.Names
35+import Language.PureScript.Kinds
36+import Language.PureScript.Declarations
37+
38+import Control.Monad (forM_)
39+import Control.Monad.State
40+import Control.Monad.Error
41+
42+typeCheckAll :: [Declaration] -> Check ()
43+typeCheckAll [] = return ()
44+typeCheckAll (DataDeclaration name args dctors : rest) = do
45+ rethrow (("Error in type constructor " ++ show name ++ ":\n") ++) $ do
46+ env <- getEnv
47+ modulePath <- checkModulePath `fmap` get
48+ guardWith (show name ++ " is already defined") $ not $ M.member (modulePath, name) (types env)
49+ ctorKind <- kindsOf (Just name) args (mapMaybe snd dctors)
50+ putEnv $ env { types = M.insert (modulePath, name) (ctorKind, Data) (types env) }
51+ forM_ dctors $ \(dctor, maybeTy) ->
52+ rethrow (("Error in data constructor " ++ show name ++ ":\n") ++) $ do
53+ env' <- getEnv
54+ guardWith (show dctor ++ " is already defined") $ not $ M.member (modulePath, dctor) (dataConstructors env')
55+ let retTy = foldl TypeApp (TypeConstructor (Qualified modulePath name)) (map TypeVar args)
56+ let dctorTy = maybe retTy (\ty -> Function [ty] retTy) maybeTy
57+ let polyType = mkForAll args dctorTy
58+ putEnv $ env' { dataConstructors = M.insert (modulePath, dctor) polyType (dataConstructors env') }
59+ typeCheckAll rest
60+typeCheckAll (TypeSynonymDeclaration name args ty : rest) = do
61+ rethrow (("Error in type synonym " ++ show name ++ ":\n") ++) $ do
62+ env <- getEnv
63+ modulePath <- checkModulePath `fmap` get
64+ guardWith (show name ++ " is already defined") $ not $ M.member (modulePath, name) (types env)
65+ kind <- kindsOf (Just name) args [ty]
66+ putEnv $ env { types = M.insert (modulePath, name) (kind, TypeSynonym) (types env)
67+ , typeSynonyms = M.insert (modulePath, name) (args, ty) (typeSynonyms env) }
68+ typeCheckAll rest
69+typeCheckAll (TypeDeclaration name ty : ValueDeclaration name' val : rest) | name == name' =
70+ typeCheckAll (ValueDeclaration name (TypedValue val ty) : rest)
71+typeCheckAll (TypeDeclaration name _ : _) = throwError $ "Orphan type declaration for " ++ show name
72+typeCheckAll (ValueDeclaration name val : rest) = do
73+ rethrow (("Error in declaration " ++ show name ++ ":\n") ++) $ do
74+ env <- getEnv
75+ modulePath <- checkModulePath `fmap` get
76+ case M.lookup (modulePath, name) (names env) of
77+ Just ty -> throwError $ show name ++ " is already defined"
78+ Nothing -> do
79+ ty <- typeOf (Just name) val
80+ putEnv (env { names = M.insert (modulePath, name) (ty, Value) (names env) })
81+ typeCheckAll rest
82+typeCheckAll (ExternDataDeclaration name kind : rest) = do
83+ env <- getEnv
84+ modulePath <- checkModulePath `fmap` get
85+ guardWith (show name ++ " is already defined") $ not $ M.member (modulePath, name) (types env)
86+ putEnv $ env { types = M.insert (modulePath, name) (kind, TypeSynonym) (types env) }
87+ typeCheckAll rest
88+typeCheckAll (ExternMemberDeclaration member name ty : rest) = do
89+ rethrow (("Error in foreign import member declaration " ++ show name ++ ":\n") ++) $ do
90+ env <- getEnv
91+ modulePath <- checkModulePath `fmap` get
92+ kind <- kindOf ty
93+ guardWith "Expected kind *" $ kind == Star
94+ case M.lookup (modulePath, name) (names env) of
95+ Just _ -> throwError $ show name ++ " is already defined"
96+ Nothing -> case ty of
97+ (ForAll _ (Function [_] _)) -> do
98+ putEnv (env { names = M.insert (modulePath, name) (ty, Extern) (names env)
99+ , members = M.insert (modulePath, name) member (members env) })
100+ _ -> throwError "Foreign member declarations must have function types, with an single argument."
101+ typeCheckAll rest
102+typeCheckAll (ExternDeclaration name ty : rest) = do
103+ rethrow (("Error in foreign import declaration " ++ show name ++ ":\n") ++) $ do
104+ env <- getEnv
105+ modulePath <- checkModulePath `fmap` get
106+ kind <- kindOf ty
107+ guardWith "Expected kind *" $ kind == Star
108+ case M.lookup (modulePath, name) (names env) of
109+ Just _ -> throwError $ show name ++ " is already defined"
110+ Nothing -> putEnv (env { names = M.insert (modulePath, name) (ty, Extern) (names env) })
111+ typeCheckAll rest
112+typeCheckAll (FixityDeclaration _ name : rest) = do
113+ typeCheckAll rest
114+ env <- getEnv
115+ modulePath <- checkModulePath `fmap` get
116+ guardWith ("Fixity declaration with no binding: " ++ name) $ M.member (modulePath, Op name) $ names env
117+typeCheckAll (ModuleDeclaration name decls : rest) = do
118+ withModule name $ typeCheckAll decls
119+ typeCheckAll rest
120+typeCheckAll (ImportDeclaration modulePath idents : rest) = do
121+ env <- getEnv
122+ currentModule <- checkModulePath `fmap` get
123+ rethrow errorMessage $ do
124+ guardWith ("Module " ++ show modulePath ++ " does not exist") $ moduleExists env
125+ case idents of
126+ Nothing -> bindIdents (map snd $ filterModule env) currentModule env
127+ Just idents -> bindIdents idents currentModule env
128+ typeCheckAll rest
129+ where errorMessage = (("Error in import declaration " ++ show modulePath ++ ":\n") ++)
130+ filterModule = filter ((== modulePath) . fst) . M.keys . names
131+ moduleExists env = not $ null $ filterModule env
132+ bindIdents idents currentModule env =
133+ forM_ idents $ \ident -> do
134+ guardWith (show currentModule ++ "." ++ show ident ++ " is already defined") $ (currentModule, ident) `M.notMember` names env
135+ case (modulePath, ident) `M.lookup` names env of
136+ Just (pt, _) -> modifyEnv (\e -> e { names = M.insert (currentModule, ident) (pt, Alias modulePath ident) (names e) })
137+ Nothing -> throwError (show modulePath ++ "." ++ show ident ++ " is undefined")
src/Language/PureScript/TypeChecker/Kinds.hsnew file+132
@@ -0,0 +1,132 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.TypeChecker.Kinds
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+{-# LANGUAGE DeriveDataTypeable #-}
16+
17+module Language.PureScript.TypeChecker.Kinds (
18+ kindsOf,
19+ kindOf
20+) where
21+
22+import Data.List
23+import Data.Maybe (fromMaybe)
24+import Data.Function
25+import Data.Data
26+
27+import Language.PureScript.Types
28+import Language.PureScript.Kinds
29+import Language.PureScript.Names
30+import Language.PureScript.Declarations
31+import Language.PureScript.TypeChecker.Monad
32+import Language.PureScript.Pretty
33+import Language.PureScript.Unknown
34+
35+import Control.Monad.State
36+import Control.Monad.Error
37+
38+import Control.Applicative
39+import Control.Arrow (Kleisli(..), (***))
40+import qualified Control.Category as C
41+
42+import qualified Data.Map as M
43+
44+instance Unifiable Kind where
45+ unknown = KUnknown
46+ isUnknown (KUnknown u) = Just u
47+ isUnknown _ = Nothing
48+ KUnknown u1 ~~ KUnknown u2 | u1 == u2 = return ()
49+ KUnknown u ~~ k = replace u k
50+ k ~~ KUnknown u = replace u k
51+ Star ~~ Star = return ()
52+ Row ~~ Row = return ()
53+ FunKind k1 k2 ~~ FunKind k3 k4 = do
54+ k1 ~~ k3
55+ k2 ~~ k4
56+ k1 ~~ k2 = throwError $ "Cannot unify " ++ prettyPrintKind k1 ++ " with " ++ prettyPrintKind k2 ++ "."
57+ apply s (KUnknown u) = runSubstitution s u
58+ apply s (FunKind k1 k2) = FunKind (apply s k1) (apply s k2)
59+ apply _ k = k
60+ unknowns (KUnknown (Unknown u)) = [u]
61+ unknowns (FunKind k1 k2) = unknowns k1 ++ unknowns k2
62+ unknowns _ = []
63+
64+kindOf :: Type -> Check Kind
65+kindOf ty = fmap (\(k, _, _) -> k) . runSubst $ starIfUnknown <$> infer Nothing M.empty ty
66+
67+kindsOf :: Maybe ProperName -> [String] -> [Type] -> Check Kind
68+kindsOf name args ts = fmap (starIfUnknown . (\(k, _, _) -> k)) . runSubst $ do
69+ tyCon <- fresh
70+ kargs <- replicateM (length args) fresh
71+ ks <- inferAll (fmap (\pn -> (pn, tyCon)) name) (M.fromList (zip args kargs)) ts
72+ tyCon ~~ foldr FunKind Star kargs
73+ forM_ ks $ \k -> k ~~ Star
74+ return tyCon
75+
76+starIfUnknown :: Kind -> Kind
77+starIfUnknown (KUnknown _) = Star
78+starIfUnknown (FunKind k1 k2) = FunKind (starIfUnknown k1) (starIfUnknown k2)
79+starIfUnknown k = k
80+
81+inferAll :: Maybe (ProperName, Kind) -> M.Map String Kind -> [Type] -> Subst Check [Kind]
82+inferAll name m = mapM (infer name m)
83+
84+infer :: Maybe (ProperName, Kind) -> M.Map String Kind -> Type -> Subst Check Kind
85+infer name m (Array t) = do
86+ k <- infer name m t
87+ k ~~ Star
88+ return Star
89+infer name m (Object row) = do
90+ k <- inferRow name m row
91+ k ~~ Row
92+ return Star
93+infer name m (Function args ret) = do
94+ ks <- inferAll name m args
95+ k <- infer name m ret
96+ k ~~ Star
97+ forM ks $ \k -> k ~~ Star
98+ return Star
99+infer _ m (TypeVar v) =
100+ case M.lookup v m of
101+ Just k -> return k
102+ Nothing -> throwError $ "Unbound type variable " ++ v
103+infer (Just (name, k)) m c@(TypeConstructor v@(Qualified (ModulePath []) pn)) | name == pn = return k
104+infer name m (TypeConstructor v) = do
105+ env <- lift getEnv
106+ modulePath <- checkModulePath `fmap` lift get
107+ case M.lookup (qualify modulePath v) (types env) of
108+ Nothing -> throwError $ "Unknown type constructor '" ++ show v ++ "'"
109+ Just (kind, _) -> return kind
110+infer name m (TypeApp t1 t2) = do
111+ k0 <- fresh
112+ k1 <- infer name m t1
113+ k2 <- infer name m t2
114+ k1 ~~ FunKind k2 k0
115+ return k0
116+infer name m (ForAll ident ty) = do
117+ k <- fresh
118+ infer name (M.insert ident k m) ty
119+infer _ m t = return Star
120+
121+inferRow :: Maybe (ProperName, Kind) -> M.Map String Kind -> Row -> Subst Check Kind
122+inferRow _ m (RowVar v) = do
123+ case M.lookup v m of
124+ Just k -> return k
125+ Nothing -> throwError $ "Unbound row variable " ++ v
126+inferRow _ m r@REmpty = return Row
127+inferRow name m r@(RCons _ ty row) = do
128+ k1 <- infer name m ty
129+ k2 <- inferRow name m row
130+ k1 ~~ Star
131+ k2 ~~ Row
132+ return Row
src/Language/PureScript/TypeChecker/Monad.hsnew file+156
@@ -0,0 +1,156 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.TypeChecker.Monad
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances, RankNTypes, DeriveDataTypeable,
16+ GADTs, StandaloneDeriving, MultiParamTypeClasses, FlexibleContexts #-}
17+
18+module Language.PureScript.TypeChecker.Monad where
19+
20+import Language.PureScript.Types
21+import Language.PureScript.Kinds
22+import Language.PureScript.Names
23+import Language.PureScript.Unknown
24+
25+import Data.Data
26+import Data.Maybe
27+import Data.Monoid
28+import Data.Typeable
29+import Control.Applicative
30+import Control.Monad.State
31+import Control.Monad.Error
32+
33+import Control.Arrow ((***), first, second)
34+
35+import qualified Data.Map as M
36+
37+data NameKind = Value | Extern | Alias ModulePath Ident deriving Show
38+
39+data TypeDeclarationKind = Data | ExternData | TypeSynonym deriving Show
40+
41+data Environment = Environment
42+ { names :: M.Map (ModulePath, Ident) (Type, NameKind)
43+ , types :: M.Map (ModulePath, ProperName) (Kind, TypeDeclarationKind)
44+ , dataConstructors :: M.Map (ModulePath, ProperName) Type
45+ , typeSynonyms :: M.Map (ModulePath, ProperName) ([String], Type)
46+ , members :: M.Map (ModulePath, Ident) String
47+ } deriving (Show)
48+
49+emptyEnvironment :: Environment
50+emptyEnvironment = Environment M.empty M.empty M.empty M.empty M.empty
51+
52+data AnyUnifiable where
53+ AnyUnifiable :: forall t. (Unifiable t) => t -> AnyUnifiable
54+
55+data CheckState = CheckState { checkEnv :: Environment
56+ , checkNextVar :: Int
57+ , checkModulePath :: ModulePath
58+ }
59+
60+newtype Check a = Check { unCheck :: StateT CheckState (Either String) a }
61+ deriving (Functor, Monad, Applicative, MonadPlus, MonadState CheckState, MonadError String)
62+
63+getEnv :: Check Environment
64+getEnv = fmap checkEnv get
65+
66+putEnv :: Environment -> Check ()
67+putEnv env = modify (\s -> s { checkEnv = env })
68+
69+modifyEnv :: (Environment -> Environment) -> Check ()
70+modifyEnv f = modify (\s -> s { checkEnv = f (checkEnv s) })
71+
72+runCheck :: Check a -> Either String (a, Environment)
73+runCheck c = do
74+ (a, s) <- flip runStateT (CheckState emptyEnvironment 0 global) $ unCheck c
75+ return (a, checkEnv s)
76+
77+guardWith :: (MonadError e m) => e -> Bool -> m ()
78+guardWith _ True = return ()
79+guardWith e False = throwError e
80+
81+rethrow :: (MonadError e m) => (e -> e) -> m a -> m a
82+rethrow f = flip catchError $ \e -> throwError (f e)
83+
84+withModule :: ProperName -> Check a -> Check a
85+withModule name act = do
86+ original <- checkModulePath `fmap` get
87+ modify $ \s -> s { checkModulePath = subModule (checkModulePath s) name }
88+ a <- act
89+ modify $ \s -> s { checkModulePath = original }
90+ return a
91+
92+newtype Substitution = Substitution { runSubstitution :: forall t. (Unifiable t) => Unknown t -> t }
93+
94+instance Monoid Substitution where
95+ mempty = Substitution unknown
96+ s1 `mappend` s2 = Substitution $ \u -> apply s1 (apply s2 (unknown u))
97+
98+data SubstState = SubstState { substSubst :: Substitution
99+ , substFutureEscapeChecks :: [AnyUnifiable] }
100+
101+newtype Subst m a = Subst { unSubst :: StateT SubstState m a }
102+ deriving (Functor, Monad, Applicative, MonadPlus, MonadTrans)
103+
104+deriving instance (MonadError String m) => MonadError String (Subst m)
105+
106+runSubst :: (Unifiable a, Monad m) => Subst m a -> m (a, Substitution, [AnyUnifiable])
107+runSubst subst = do
108+ (a, s) <- flip runStateT (SubstState mempty []) . unSubst $ subst
109+ return (apply (substSubst s) a, substSubst s, substFutureEscapeChecks s)
110+
111+substituteWith :: (Typeable t) => (Unknown t -> t) -> Substitution
112+substituteWith f = Substitution $ \u -> fromMaybe (unknown u) $ do
113+ u1 <- cast u
114+ cast (f u1)
115+
116+substituteOne :: (Unifiable t) => Unknown t -> t -> Substitution
117+substituteOne u t = substituteWith $ \u1 ->
118+ case u1 of
119+ u2 | u2 == u -> t
120+ | otherwise -> unknown u2
121+
122+replace :: (Unifiable t) => Unknown t -> t -> Subst Check ()
123+replace u t' = do
124+ sub <- substSubst <$> Subst get
125+ let t = apply sub t'
126+ occursCheck u t
127+ let current = apply sub $ unknown u
128+ case isUnknown current of
129+ Just u1 | u1 == u -> return ()
130+ _ -> current ~~ t
131+ Subst . modify $ \s -> s { substSubst = substituteOne u t <> substSubst s }
132+
133+class (Typeable t, Data t, Show t) => Unifiable t where
134+ unknown :: Unknown t -> t
135+ (~~) :: t -> t -> Subst Check ()
136+ isUnknown :: t -> Maybe (Unknown t)
137+ apply :: Substitution -> t -> t
138+ unknowns :: t -> [Int]
139+
140+occursCheck :: (Unifiable t) => Unknown s -> t -> Subst Check ()
141+occursCheck (Unknown u) t =
142+ case isUnknown t of
143+ Nothing -> guardWith "Occurs check fails" (u `notElem` unknowns t)
144+ _ -> return ()
145+
146+fresh' :: Subst Check Int
147+fresh' = do
148+ n <- lift $ checkNextVar <$> get
149+ lift . modify $ \s -> s { checkNextVar = succ (checkNextVar s) }
150+ return n
151+
152+fresh :: (Unifiable t) => Subst Check t
153+fresh = unknown . Unknown <$> fresh'
154+
155+escapeCheckLater :: (Unifiable t) => t -> Subst Check ()
156+escapeCheckLater t = Subst . modify $ \s -> s { substFutureEscapeChecks = AnyUnifiable t : substFutureEscapeChecks s }
src/Language/PureScript/TypeChecker/Synonyms.hsnew file+51
@@ -0,0 +1,51 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.TypeChecker.Synonyms
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+module Language.PureScript.TypeChecker.Synonyms (
16+ saturateTypeSynonym,
17+ saturateAllTypeSynonyms
18+) where
19+
20+import Language.PureScript.Types
21+import Language.PureScript.Declarations
22+import Language.PureScript.Names
23+
24+import Data.Maybe (fromMaybe)
25+import Data.Data
26+import Data.Generics
27+import Data.Generics.Extras
28+import Control.Arrow
29+import Control.Monad.Writer
30+import Control.Monad.Error
31+import qualified Data.Map as M
32+
33+buildTypeSubstitution :: Qualified ProperName -> Int -> Type -> Either String (Maybe Type)
34+buildTypeSubstitution name n = go n []
35+ where
36+ go :: Int -> [Type] -> Type -> Either String (Maybe Type)
37+ go 0 args (TypeConstructor ctor) | name == ctor = return (Just $ SaturatedTypeSynonym ctor args)
38+ go n _ (TypeConstructor ctor) | n > 0 && name == ctor = throwError $ "Partially applied type synonym " ++ show name
39+ go n args (TypeApp f arg) = go (n - 1) (arg:args) f
40+ go _ _ _ = return Nothing
41+
42+saturateTypeSynonym :: (Data d) => Qualified ProperName -> Int -> d -> Either String d
43+saturateTypeSynonym name n = everywhereM' (mkM replace)
44+ where
45+ replace t = fmap (fromMaybe t) $ buildTypeSubstitution name n t
46+
47+saturateAllTypeSynonyms :: (Data d) => [(Qualified ProperName, Int)] -> d -> Either String d
48+saturateAllTypeSynonyms syns d = foldM (\d (name, n) -> saturateTypeSynonym name n d) d syns
49+
50+
51+
src/Language/PureScript/TypeChecker/Types.hsnew file+730
@@ -0,0 +1,730 @@
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 #-}
16+
17+module Language.PureScript.TypeChecker.Types (
18+ typeOf
19+) where
20+
21+import Data.List
22+import Data.Maybe (isJust, fromMaybe)
23+import Data.Function
24+import qualified Data.Data as D
25+import Data.Generics (everywhere, everywhereM, everything, mkT, mkM, mkQ, extM, extQ)
26+
27+import Language.PureScript.Values
28+import Language.PureScript.Types
29+import Language.PureScript.Kinds
30+import Language.PureScript.Names
31+import Language.PureScript.TypeChecker.Monad
32+import Language.PureScript.TypeChecker.Kinds
33+import Language.PureScript.TypeChecker.Synonyms
34+import Language.PureScript.Pretty
35+import Language.PureScript.Unknown
36+
37+import Control.Monad.State
38+import Control.Monad.Error
39+
40+import Control.Applicative
41+import Control.Arrow (Arrow(..), Kleisli(..), (***), (&&&), second)
42+import qualified Control.Category as C
43+
44+import qualified Data.Map as M
45+
46+instance Unifiable Type where
47+ unknown = TUnknown
48+ isUnknown (TUnknown u) = Just u
49+ isUnknown _ = Nothing
50+ (~~) = unifyTypes
51+ apply s (TUnknown u) = runSubstitution s u
52+ apply s (SaturatedTypeSynonym name tys) = SaturatedTypeSynonym name $ map (apply s) tys
53+ apply s (ForAll idents ty) = ForAll idents $ apply s ty
54+ apply s (Array t) = Array (apply s t)
55+ apply s (Object r) = Object (apply s r)
56+ apply s (Function args ret) = Function (map (apply s) args) (apply s ret)
57+ apply s (TypeApp t1 t2) = TypeApp (apply s t1) (apply s t2)
58+ apply _ t = t
59+ unknowns (TUnknown (Unknown u)) = [u]
60+ unknowns (SaturatedTypeSynonym _ tys) = concatMap unknowns tys
61+ unknowns (ForAll idents ty) = unknowns ty
62+ unknowns (Array t) = unknowns t
63+ unknowns (Object r) = unknowns r
64+ unknowns (Function args ret) = concatMap unknowns args ++ unknowns ret
65+ unknowns (TypeApp t1 t2) = unknowns t1 ++ unknowns t2
66+ unknowns _ = []
67+
68+instance Unifiable Row where
69+ unknown = RUnknown
70+ isUnknown (RUnknown u) = Just u
71+ isUnknown _ = Nothing
72+ r1 ~~ r2 =
73+ let
74+ (s1, r1') = rowToList r1
75+ (s2, r2') = rowToList r2
76+ int = [ (t1, t2) | (name, t1) <- s1, (name', t2) <- s2, name == name' ]
77+ sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ]
78+ sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ]
79+ in do
80+ forM_ int (uncurry (~~))
81+ unifyRows sd1 r1' sd2 r2'
82+ where
83+ unifyRows :: [(String, Type)] -> Row -> [(String, Type)] -> Row -> Subst Check ()
84+ unifyRows [] (RUnknown u) sd r = replace u (rowFromList (sd, r))
85+ unifyRows sd r [] (RUnknown u) = replace u (rowFromList (sd, r))
86+ unifyRows ns@((name, ty):row) r others u@(RUnknown un) = do
87+ occursCheck un ty
88+ forM row $ \(_, ty) -> occursCheck un ty
89+ u' <- fresh
90+ u ~~ RCons name ty u'
91+ unifyRows row r others u'
92+ unifyRows [] REmpty [] REmpty = return ()
93+ unifyRows [] (RowVar v1) [] (RowVar v2) | v1 == v2 = return ()
94+ unifyRows [] (RSkolem s1) [] (RSkolem s2) | s1 == s2 = return ()
95+ unifyRows sd1 r1 sd2 r2 = throwError $ "Cannot unify " ++ prettyPrintRow (rowFromList (sd1, r1)) ++ " with " ++ prettyPrintRow (rowFromList (sd2, r2)) ++ "."
96+ apply s (RUnknown u) = runSubstitution s u
97+ apply s (RCons name ty r) = RCons name (apply s ty) (apply s r)
98+ apply _ r = r
99+ unknowns (RUnknown (Unknown u)) = [u]
100+ unknowns (RCons _ ty r) = unknowns ty ++ unknowns r
101+ unknowns _ = []
102+
103+unifyTypes :: Type -> Type -> Subst Check ()
104+unifyTypes t1 t2 = rethrow (\e -> "Error unifying type " ++ prettyPrintType t1 ++ " with type " ++ prettyPrintType t2 ++ ":\n" ++ e) $ do
105+ unifyTypes' t1 t2
106+ where
107+ unifyTypes' (TUnknown u1) (TUnknown u2) | u1 == u2 = return ()
108+ unifyTypes' (TUnknown u) t = replace u t
109+ unifyTypes' t (TUnknown u) = replace u t
110+ unifyTypes' (SaturatedTypeSynonym name1 args1) (SaturatedTypeSynonym name2 args2)
111+ | name1 == name2 = zipWithM_ unifyTypes args1 args2
112+ unifyTypes' (SaturatedTypeSynonym name args) ty = do
113+ env <- lift getEnv
114+ modulePath <- checkModulePath `fmap` lift get
115+ case M.lookup (qualify modulePath name) (typeSynonyms env) of
116+ Just (synArgs, body) -> do
117+ let m = M.fromList $ zip synArgs args
118+ let replaced = replaceTypeVars m body
119+ replaced `unifyTypes` ty
120+ Nothing -> error "Type synonym was not defined"
121+ unifyTypes' ty s@(SaturatedTypeSynonym _ _) = s `unifyTypes` ty
122+ unifyTypes' (ForAll ident1 ty1) (ForAll ident2 ty2) = do
123+ sk <- skolemize ident1 ty1
124+ replaced <- replaceVarsWithUnknowns [ident2] ty2
125+ sk `unifyTypes` replaced
126+ unifyTypes' (ForAll ident ty1) ty2 = do
127+ sk <- skolemize ident ty1
128+ sk `unifyTypes` ty2
129+ unifyTypes' ty f@(ForAll _ _) = f `unifyTypes` ty
130+ unifyTypes' Number Number = return ()
131+ unifyTypes' String String = return ()
132+ unifyTypes' Boolean Boolean = return ()
133+ unifyTypes' (Array s) (Array t) = s `unifyTypes` t
134+ unifyTypes' (Object row1) (Object row2) = row1 ~~ row2
135+ unifyTypes' (Function args1 ret1) (Function args2 ret2) = do
136+ guardWith "Function applied to incorrect number of args" $ length args1 == length args2
137+ zipWithM_ unifyTypes args1 args2
138+ ret1 `unifyTypes` ret2
139+ unifyTypes' (TypeVar v1) (TypeVar v2) | v1 == v2 = return ()
140+ unifyTypes' (TypeConstructor c1) (TypeConstructor c2) = do
141+ modulePath <- checkModulePath `fmap` lift get
142+ guardWith ("Cannot unify " ++ show c1 ++ " with " ++ show c2 ++ ".") (qualify modulePath c1 == qualify modulePath c2)
143+ unifyTypes' (TypeApp t1 t2) (TypeApp t3 t4) = do
144+ t1 `unifyTypes` t3
145+ t2 `unifyTypes` t4
146+ unifyTypes' (Skolem s1) (Skolem s2) | s1 == s2 = return ()
147+ unifyTypes' t1 t2 = throwError $ "Cannot unify " ++ prettyPrintType t1 ++ " with " ++ prettyPrintType t2 ++ "."
148+
149+isFunction :: Value -> Bool
150+isFunction (Abs _ _) = True
151+isFunction (TypedValue untyped _) = isFunction untyped
152+isFunction _ = False
153+
154+typeOf :: Maybe Ident -> Value -> Check Type
155+typeOf name val = do
156+ (ty, sub, checks) <- runSubst $ case name of
157+ Just ident | isFunction val ->
158+ do me <- fresh
159+ ty <- infer (M.singleton ident me) val
160+ me ~~ ty
161+ return ty
162+ _ -> infer M.empty val
163+ escapeCheck checks ty sub
164+ return $ varIfUnknown $ desaturateAllTypeSynonyms $ setifyAll ty
165+
166+escapeCheck :: [AnyUnifiable] -> Type -> Substitution -> Check ()
167+escapeCheck checks ty sub =
168+ let
169+ visibleUnknowns = nub $ unknowns ty
170+ in
171+ forM_ checks $ \check -> case check of
172+ AnyUnifiable t -> do
173+ let unsolvedUnknowns = nub . unknowns $ apply sub t
174+ guardWith "Escape check fails" $ null $ unsolvedUnknowns \\ visibleUnknowns
175+
176+setify :: Row -> Row
177+setify = rowFromList . first (M.toList . M.fromList) . rowToList
178+
179+setifyAll :: (D.Data d) => d -> d
180+setifyAll = everywhere (mkT setify)
181+
182+findTypeVars :: (D.Data d) => d -> [String]
183+findTypeVars = everything (++) (mkQ [] f)
184+ where
185+ f :: Type -> [String]
186+ f (TypeVar v) = [v]
187+ f _ = []
188+
189+varIfUnknown :: Type -> Type
190+varIfUnknown ty =
191+ let
192+ (ty', m) = flip runState M.empty $ everywhereM (flip extM g $ mkM f) ty
193+ in
194+ mkForAll (sort $ nub $ M.elems m ++ findTypeVars ty) ty'
195+ where
196+ f :: Type -> State (M.Map Int String) Type
197+ f (TUnknown (Unknown n)) = do
198+ m <- get
199+ case M.lookup n m of
200+ Nothing -> do
201+ let name = 't' : show (M.size m)
202+ put $ M.insert n name m
203+ return $ TypeVar name
204+ Just name -> return $ TypeVar name
205+ f t = return t
206+ g :: Row -> State (M.Map Int String) Row
207+ g (RUnknown (Unknown n)) = do
208+ m <- get
209+ case M.lookup n m of
210+ Nothing -> do
211+ let name = 'r' : show (M.size m)
212+ put $ M.insert n name m
213+ return $ RowVar name
214+ Just name -> return $ RowVar name
215+ g r = return r
216+
217+replaceTypeVars :: M.Map String Type -> Type -> Type
218+replaceTypeVars m = everywhere (mkT replace)
219+ where
220+ replace (TypeVar v) = case M.lookup v m of
221+ Just ty -> ty
222+ _ -> TypeVar v
223+ replace t = t
224+
225+replaceRowVars :: M.Map String Row -> Type -> Type
226+replaceRowVars m = everywhere (mkT replace)
227+ where
228+ replace (RowVar v) = case M.lookup v m of
229+ Just r -> r
230+ _ -> RowVar v
231+ replace t = t
232+
233+replaceVarsWithUnknowns :: [String] -> Type -> Subst Check Type
234+replaceVarsWithUnknowns idents = flip evalStateT M.empty . everywhereM (flip extM f $ mkM g)
235+ where
236+ f :: Type -> StateT (M.Map String Int) (Subst Check) Type
237+ f (TypeVar var) | var `elem` idents = do
238+ m <- get
239+ n <- lift fresh'
240+ case M.lookup var m of
241+ Nothing -> do
242+ put (M.insert var n m)
243+ return $ TUnknown (Unknown n)
244+ Just u -> return $ TUnknown (Unknown u)
245+ f t = return t
246+ g :: Row -> StateT (M.Map String Int) (Subst Check) Row
247+ g (RowVar var) | var `elem` idents = do
248+ m <- get
249+ n <- lift fresh'
250+ case M.lookup var m of
251+ Nothing -> do
252+ put (M.insert var n m)
253+ return $ RUnknown (Unknown n)
254+ Just u -> return $ RUnknown (Unknown u)
255+ g r = return r
256+
257+replaceAllTypeSynonyms :: (D.Data d) => d -> Check d
258+replaceAllTypeSynonyms d = do
259+ env <- getEnv
260+ let syns = map (\((path, name), (args, _)) -> (Qualified path name, length args)) . M.toList $ typeSynonyms env
261+ either throwError return $ saturateAllTypeSynonyms syns d
262+
263+desaturateAllTypeSynonyms :: (D.Data d) => d -> d
264+desaturateAllTypeSynonyms = everywhere (mkT replace)
265+ where
266+ replace (SaturatedTypeSynonym name args) = foldl TypeApp (TypeConstructor name) args
267+ replace t = t
268+
269+ensureNoDuplicateProperties :: [(String, Value)] -> Check ()
270+ensureNoDuplicateProperties ps = guardWith "Duplicate property names" $ length (nub . map fst $ ps) == length ps
271+
272+infer :: M.Map Ident Type -> Value -> Subst Check Type
273+infer m val = rethrow (\e -> "Error inferring type of term " ++ prettyPrintValue val ++ ":\n" ++ e) $ do
274+ ty <- infer' m val
275+ escapeCheckLater ty
276+ return ty
277+
278+infer' _ (NumericLiteral _) = return Number
279+infer' _ (StringLiteral _) = return String
280+infer' _ (BooleanLiteral _) = return Boolean
281+infer' m (ArrayLiteral vals) = do
282+ ts <- mapM (infer m) vals
283+ arr <- fresh
284+ forM_ ts $ \t -> arr ~~ Array t
285+ return arr
286+infer' m (Unary op val) = do
287+ t <- infer m val
288+ inferUnary op t
289+infer' m (Binary op left right) = do
290+ t1 <- infer m left
291+ t2 <- infer m right
292+ inferBinary op t1 t2
293+infer' m (ObjectLiteral ps) = do
294+ lift $ ensureNoDuplicateProperties ps
295+ ts <- mapM (infer m . snd) ps
296+ let fields = zipWith (\(name, _) t -> (name, t)) ps ts
297+ return $ Object $ typesToRow fields
298+infer' m (ObjectUpdate o ps) = do
299+ lift $ ensureNoDuplicateProperties ps
300+ obj <- infer m o
301+ row <- fresh
302+ ts <- mapM (infer m . snd) ps
303+ let tys = zipWith (\(name, _) t -> (name, t)) ps ts
304+ obj ~~ Object (rowFromList (tys, row))
305+ return obj
306+infer' m (Indexer index val) = do
307+ el <- fresh
308+ check m index Number
309+ check m val (Array el)
310+ return el
311+infer' m (Accessor prop val) = do
312+ field <- fresh
313+ rest <- fresh
314+ check m val (Object (RCons prop field rest))
315+ return field
316+infer' m (Abs args ret) = do
317+ ts <- replicateM (length args) fresh
318+ let m' = m `M.union` M.fromList (zip args ts)
319+ body <- infer m' ret
320+ return $ Function ts body
321+infer' m (App f xs) = do
322+ t1 <- infer m f
323+ ret <- fresh
324+ checkFunctionApplication m t1 xs ret
325+ return ret
326+infer' m (Var var@(Qualified mp name)) = do
327+ case mp of
328+ ModulePath [] ->
329+ case M.lookup name m of
330+ Just ty -> lift $ replaceAllTypeSynonyms ty
331+ Nothing -> lookupGlobal
332+ _ -> lookupGlobal
333+ where
334+ lookupGlobal = do
335+ env <- lift getEnv
336+ modulePath <- checkModulePath `fmap` lift get
337+ case M.lookup (qualify modulePath var) (names env) of
338+ Nothing -> throwError $ show var ++ " is undefined"
339+ Just (ty, _) -> lift $ replaceAllTypeSynonyms ty
340+infer' m (Block ss) = do
341+ ret <- fresh
342+ (allCodePathsReturn, _) <- checkBlock m M.empty ret ss
343+ guardWith "Block is missing a return statement" allCodePathsReturn
344+ return ret
345+infer' m (Constructor c) = do
346+ env <- lift getEnv
347+ modulePath <- checkModulePath `fmap` lift get
348+ case M.lookup (qualify modulePath c) (dataConstructors env) of
349+ Nothing -> throwError $ "Constructor " ++ show c ++ " is undefined"
350+ Just ty -> lift $ replaceAllTypeSynonyms ty
351+infer' m (Case val binders) = do
352+ t1 <- infer m val
353+ ret <- fresh
354+ checkBinders m t1 ret binders
355+ return ret
356+infer' m (IfThenElse cond th el) = do
357+ check m cond Boolean
358+ t2 <- infer m th
359+ t3 <- infer m el
360+ t2 ~~ t3
361+ return t2
362+infer' m (TypedValue val ty) = do
363+ kind <- lift $ kindOf ty
364+ guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
365+ ty' <- lift $ replaceAllTypeSynonyms ty
366+ check m val ty'
367+ return ty'
368+
369+inferUnary :: UnaryOperator -> Type -> Subst Check Type
370+inferUnary op val =
371+ case fromMaybe (error "Invalid operator") $ lookup op unaryOps of
372+ (valTy, resTy) -> do
373+ val ~~ valTy
374+ return resTy
375+
376+checkUnary :: M.Map Ident Type -> UnaryOperator -> Value -> Type -> Subst Check ()
377+checkUnary m op val res =
378+ case fromMaybe (error "Invalid operator") $ lookup op unaryOps of
379+ (valTy, resTy) -> do
380+ res ~~ resTy
381+ check m val valTy
382+
383+unaryOps :: [(UnaryOperator, (Type, Type))]
384+unaryOps = [ (Negate, (Number, Number))
385+ , (Not, (Boolean, Boolean))
386+ , (BitwiseNot, (Number, Number))
387+ ]
388+
389+inferBinary :: BinaryOperator -> Type -> Type -> Subst Check Type
390+inferBinary op left right | isEqualityTest op = do
391+ left ~~ right
392+ return Boolean
393+inferBinary op left right =
394+ case fromMaybe (error "Invalid operator") $ lookup op binaryOps of
395+ (valTy, resTy) -> do
396+ left ~~ valTy
397+ right ~~ valTy
398+ return resTy
399+
400+checkBinary :: M.Map Ident Type -> BinaryOperator -> Value -> Value -> Type -> Subst Check ()
401+checkBinary m op left right res | isEqualityTest op = do
402+ res ~~ Boolean
403+ t1 <- infer m left
404+ t2 <- infer m right
405+ t1 ~~ t2
406+checkBinary m op left right res =
407+ case fromMaybe (error "Invalid operator") $ lookup op binaryOps of
408+ (valTy, resTy) -> do
409+ res ~~ resTy
410+ check m left valTy
411+ check m right valTy
412+
413+isEqualityTest :: BinaryOperator -> Bool
414+isEqualityTest EqualTo = True
415+isEqualityTest NotEqualTo = True
416+isEqualityTest _ = False
417+
418+binaryOps :: [(BinaryOperator, (Type, Type))]
419+binaryOps = [ (Add, (Number, Number))
420+ , (Subtract, (Number, Number))
421+ , (Multiply, (Number, Number))
422+ , (Divide, (Number, Number))
423+ , (Modulus, (Number, Number))
424+ , (BitwiseAnd, (Number, Number))
425+ , (BitwiseOr, (Number, Number))
426+ , (BitwiseXor, (Number, Number))
427+ , (ShiftRight, (Number, Number))
428+ , (ZeroFillShiftRight, (Number, Number))
429+ , (And, (Boolean, Boolean))
430+ , (Or, (Boolean, Boolean))
431+ , (Concat, (String, String))
432+ , (Modulus, (Number, Number))
433+ , (LessThan, (Number, Boolean))
434+ , (LessThanOrEqualTo, (Number, Boolean))
435+ , (GreaterThan, (Number, Boolean))
436+ , (GreaterThanOrEqualTo, (Number, Boolean))
437+ ]
438+
439+inferBinder :: Type -> Binder -> Subst Check (M.Map Ident Type)
440+inferBinder _ NullBinder = return M.empty
441+inferBinder val (StringBinder _) = val ~~ String >> return M.empty
442+inferBinder val (NumberBinder _) = val ~~ Number >> return M.empty
443+inferBinder val (BooleanBinder _) = val ~~ Boolean >> return M.empty
444+inferBinder val (VarBinder name) = return $ M.singleton name val
445+inferBinder val (NullaryBinder ctor) = do
446+ env <- lift getEnv
447+ modulePath <- checkModulePath `fmap` lift get
448+ case M.lookup (qualify modulePath ctor) (dataConstructors env) of
449+ Just ty -> do
450+ ty `subsumes` val
451+ return M.empty
452+ _ -> throwError $ "Constructor " ++ show ctor ++ " is not defined"
453+inferBinder val (UnaryBinder ctor binder) = do
454+ env <- lift getEnv
455+ modulePath <- checkModulePath `fmap` lift get
456+ case M.lookup (qualify modulePath ctor) (dataConstructors env) of
457+ Just ty -> do
458+ obj <- fresh
459+ ty `subsumes` (Function [obj] val)
460+ inferBinder obj binder
461+ _ -> throwError $ "Constructor " ++ show ctor ++ " is not defined"
462+inferBinder val (ObjectBinder props) = do
463+ row <- fresh
464+ rest <- fresh
465+ m1 <- inferRowProperties row rest props
466+ val ~~ Object row
467+ return m1
468+ where
469+ inferRowProperties :: Row -> Row -> [(String, Binder)] -> Subst Check (M.Map Ident Type)
470+ inferRowProperties nrow row [] = nrow ~~ row >> return M.empty
471+ inferRowProperties nrow row ((name, binder):binders) = do
472+ propTy <- fresh
473+ m1 <- inferBinder propTy binder
474+ m2 <- inferRowProperties nrow (RCons name propTy row) binders
475+ return $ m1 `M.union` m2
476+inferBinder val (ArrayBinder binders rest) = do
477+ el <- fresh
478+ m1 <- M.unions <$> mapM (inferBinder el) binders
479+ val ~~ Array el
480+ case rest of
481+ Nothing -> return m1
482+ Just binder -> do
483+ m2 <- inferBinder val binder
484+ return $ m1 `M.union` m2
485+inferBinder val (NamedBinder name binder) = do
486+ m <- inferBinder val binder
487+ return $ M.insert name val m
488+
489+inferGuardedBinder :: M.Map Ident Type -> Type -> Binder -> Subst Check (M.Map Ident Type)
490+inferGuardedBinder m val (GuardedBinder cond binder) = do
491+ m1 <- inferBinder val binder
492+ ty <- infer (m `M.union` m1) cond
493+ ty ~~ Boolean
494+ return m1
495+inferGuardedBinder m val b = inferBinder val b
496+
497+checkBinders :: M.Map Ident Type -> Type -> Type -> [(Binder, Value)] -> Subst Check ()
498+checkBinders _ _ _ [] = return ()
499+checkBinders m nval ret ((binder, val):bs) = do
500+ m1 <- inferGuardedBinder m nval binder
501+ check (m `M.union` m1) val ret
502+ checkBinders m nval ret bs
503+
504+assignVariable :: Ident -> M.Map Ident Type -> Subst Check ()
505+assignVariable name m =
506+ case M.lookup name m of
507+ Nothing -> return ()
508+ Just _ -> throwError $ "Variable with name " ++ show name ++ " already exists."
509+
510+checkStatement :: M.Map Ident Type -> M.Map Ident Type -> Type -> Statement -> Subst Check (Bool, M.Map Ident Type)
511+checkStatement m mass ret (VariableIntroduction name val) = do
512+ assignVariable name (m `M.union` mass)
513+ t <- infer m val
514+ return (False, M.insert name t mass)
515+checkStatement m mass ret (Assignment ident val) = do
516+ t <- infer m val
517+ case M.lookup ident mass of
518+ Nothing -> throwError $ "No local variable with name " ++ show ident
519+ Just ty -> do t ~~ ty
520+ return (False, mass)
521+checkStatement m mass ret (While val inner) = do
522+ check m val Boolean
523+ (allCodePathsReturn, _) <- checkBlock m mass ret inner
524+ return (allCodePathsReturn, mass)
525+checkStatement m mass ret (If ifst) = do
526+ allCodePathsReturn <- checkIfStatement m mass ret ifst
527+ return (allCodePathsReturn, mass)
528+checkStatement m mass ret (For ident start end inner) = do
529+ assignVariable ident (m `M.union` mass)
530+ check (m `M.union` mass) start Number
531+ check (m `M.union` mass) end Number
532+ let mass1 = M.insert ident Number mass
533+ (allCodePathsReturn, _) <- checkBlock (m `M.union` mass1) mass1 ret inner
534+ return (allCodePathsReturn, mass)
535+checkStatement m mass ret (ForEach ident vals inner) = do
536+ assignVariable ident (m `M.union` mass)
537+ val <- fresh
538+ check (m `M.union` mass) vals (Array val)
539+ let mass1 = M.insert ident val mass
540+ (allCodePathsReturn, _) <- checkBlock (m `M.union` mass1) mass1 ret inner
541+ guardWith "Cannot return from within a foreach block" $ not allCodePathsReturn
542+ return (False, mass)
543+checkStatement m mass ret (Return val) = do
544+ check (m `M.union` mass) val ret
545+ return (True, mass)
546+
547+checkIfStatement :: M.Map Ident Type -> M.Map Ident Type -> Type -> IfStatement -> Subst Check Bool
548+checkIfStatement m mass ret (IfStatement val thens Nothing) = do
549+ check m val Boolean
550+ _ <- checkBlock m mass ret thens
551+ return False
552+checkIfStatement m mass ret (IfStatement val thens (Just elses)) = do
553+ check m val Boolean
554+ (allCodePathsReturn1, _) <- checkBlock m mass ret thens
555+ allCodePathsReturn2 <- checkElseStatement m mass ret elses
556+ return $ allCodePathsReturn1 && allCodePathsReturn2
557+
558+checkElseStatement :: M.Map Ident Type -> M.Map Ident Type -> Type -> ElseStatement -> Subst Check Bool
559+checkElseStatement m mass ret (Else elses) = fst <$> checkBlock m mass ret elses
560+checkElseStatement m mass ret (ElseIf ifst) = checkIfStatement m mass ret ifst
561+
562+checkBlock :: M.Map Ident Type -> M.Map Ident Type -> Type -> [Statement] -> Subst Check (Bool, M.Map Ident Type)
563+checkBlock _ mass _ [] = return (False, mass)
564+checkBlock m mass ret (s:ss) = do
565+ (b1, mass1) <- checkStatement (m `M.union` mass) mass ret s
566+ case (b1, ss) of
567+ (True, []) -> return (True, mass1)
568+ (True, _) -> throwError "Unreachable code"
569+ (False, ss) -> do
570+ (b2, mass2) <- checkBlock m mass1 ret ss
571+ return (b2, mass2)
572+
573+skolemize :: String -> Type -> Subst Check Type
574+skolemize ident ty = do
575+ tsk <- Skolem <$> fresh'
576+ rsk <- RSkolem <$> fresh'
577+ return $ replaceRowVars (M.singleton ident rsk) $ replaceTypeVars (M.singleton ident tsk) ty
578+
579+check :: M.Map Ident Type -> Value -> Type -> Subst Check ()
580+check m val ty = rethrow errorMessage $ check' m val ty
581+ where
582+ errorMessage msg =
583+ "Error checking type of term " ++
584+ prettyPrintValue val ++
585+ " against type " ++
586+ prettyPrintType ty ++
587+ ":\n" ++
588+ msg
589+
590+check' :: M.Map Ident Type -> Value -> Type -> Subst Check ()
591+check' m val (ForAll idents ty) = do
592+ sk <- skolemize idents ty
593+ check m val sk
594+check' m val (SaturatedTypeSynonym name args) = do
595+ env <- lift getEnv
596+ modulePath <- checkModulePath `fmap` lift get
597+ case M.lookup (qualify modulePath name) (typeSynonyms env) of
598+ Just (synArgs, body) -> do
599+ let replaced = replaceTypeVars (M.fromList (zip synArgs args)) body
600+ check m val replaced
601+ Nothing -> error "Type synonym was not defined"
602+check' m val u@(TUnknown _) = do
603+ ty <- infer m val
604+ ty ~~ u
605+check' m (NumericLiteral _) Number = return ()
606+check' m (StringLiteral _) String = return ()
607+check' m (BooleanLiteral _) Boolean = return ()
608+check' m (Unary op val) ty = checkUnary m op val ty
609+check' m (Binary op left right) ty = checkBinary m op left right ty
610+check' m (ArrayLiteral vals) (Array ty) = forM_ vals (\val -> check m val ty)
611+check' m (Indexer index vals) ty = check m index Number >> check m vals (Array ty)
612+check' m (Abs args ret) (Function argTys retTy) = do
613+ guardWith "Incorrect number of function arguments" (length args == length argTys)
614+ let bindings = M.fromList (zip args argTys)
615+ check (bindings `M.union` m) ret retTy
616+check' m (App f xs) ret = do
617+ ft <- infer m f
618+ checkFunctionApplication m ft xs ret
619+check' m v@(Var var@(Qualified mp name)) ty = do
620+ case mp of
621+ ModulePath [] ->
622+ case M.lookup name m of
623+ Just ty1 -> do
624+ repl <- lift $ replaceAllTypeSynonyms ty1
625+ repl `subsumes` ty
626+ Nothing -> lookupGlobal
627+ _ -> lookupGlobal
628+ where
629+ lookupGlobal = do
630+ env <- lift getEnv
631+ modulePath <- checkModulePath `fmap` lift get
632+ case M.lookup (qualify modulePath var) (names env) of
633+ Nothing -> throwError $ show var ++ " is undefined"
634+ Just (ty1, _) -> do
635+ repl <- lift $ replaceAllTypeSynonyms ty1
636+ repl `subsumes` ty
637+check' m (TypedValue val ty1) ty2 = do
638+ kind <- lift $ kindOf ty1
639+ guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
640+ ty1 `subsumes` ty2
641+ check m val ty1
642+check' m (Case val binders) ret = do
643+ t1 <- infer m val
644+ checkBinders m t1 ret binders
645+check' m (IfThenElse cond th el) ty = do
646+ check m cond Boolean
647+ check m th ty
648+ check m el ty
649+check' m (ObjectLiteral ps) (Object row) = do
650+ lift $ ensureNoDuplicateProperties ps
651+ checkProperties m ps row False
652+check' m (ObjectUpdate obj ps) objTy@(Object row) = do
653+ lift $ ensureNoDuplicateProperties ps
654+ check m obj objTy
655+ checkProperties m ps row True
656+check' m (Accessor prop val) ty = do
657+ rest <- fresh
658+ check m val (Object (RCons prop ty rest))
659+check' m (Block ss) ret = do
660+ (allCodePathsReturn, _) <- checkBlock m M.empty ret ss
661+ guardWith "Block is missing a return statement" allCodePathsReturn
662+check' m (Constructor c) ty = do
663+ env <- lift getEnv
664+ modulePath <- checkModulePath `fmap` lift get
665+ case M.lookup (qualify modulePath c) (dataConstructors env) of
666+ Nothing -> throwError $ "Constructor " ++ show c ++ " is undefined"
667+ Just ty1 -> do
668+ repl <- lift $ replaceAllTypeSynonyms ty1
669+ repl `subsumes` ty
670+check' _ val ty = throwError $ prettyPrintValue val ++ " does not have type " ++ prettyPrintType ty
671+
672+checkProperties :: M.Map Ident Type -> [(String, Value)] -> Row -> Bool -> Subst Check ()
673+checkProperties m ps row lax = let (ts, r') = rowToList row in go ps ts r' where
674+ go [] [] REmpty = return ()
675+ go [] [] u@(RUnknown _) = u ~~ REmpty
676+ go [] [] (RSkolem _) | lax = return ()
677+ go [] ((p, _): _) _ | lax = return ()
678+ | otherwise = throwError $ prettyPrintValue (ObjectLiteral ps) ++ " does not have property " ++ p
679+ go ((p,_):_) [] REmpty = throwError $ "Property " ++ p ++ " is not present in closed object type " ++ prettyPrintRow row
680+ go ((p,v):ps) [] u@(RUnknown _) = do
681+ ty <- infer m v
682+ rest <- fresh
683+ u ~~ RCons p ty rest
684+ go ps [] rest
685+ go ((p,v):ps) ts r =
686+ case lookup p ts of
687+ Nothing -> do
688+ ty <- infer m v
689+ rest <- fresh
690+ r ~~ RCons p ty rest
691+ go ps ts rest
692+ Just ty -> do
693+ check m v ty
694+ go ps (delete (p, ty) ts) r
695+ go _ _ _ = throwError $ prettyPrintValue (ObjectLiteral ps) ++ " does not have type " ++ prettyPrintType (Object row)
696+
697+checkFunctionApplication :: M.Map Ident Type -> Type -> [Value] -> Type -> Subst Check ()
698+checkFunctionApplication m fnTy args ret = rethrow errorMessage $ checkFunctionApplication' m fnTy args ret
699+ where
700+ errorMessage msg = "Error applying function of type "
701+ ++ prettyPrintType fnTy
702+ ++ " to arguments " ++ intercalate ", " (map prettyPrintValue args)
703+ ++ ", expecting value of type "
704+ ++ prettyPrintType ret ++ ":\n" ++ msg
705+
706+checkFunctionApplication' :: M.Map Ident Type -> Type -> [Value] -> Type -> Subst Check ()
707+checkFunctionApplication' m (Function argTys retTy) args ret = do
708+ guardWith "Incorrect number of function arguments" (length args == length argTys)
709+ zipWithM (check m) args argTys
710+ retTy `subsumes` ret
711+checkFunctionApplication' m (ForAll ident ty) args ret = do
712+ replaced <- replaceVarsWithUnknowns [ident] ty
713+ checkFunctionApplication m replaced args ret
714+checkFunctionApplication' m u@(TUnknown _) args ret = do
715+ tyArgs <- mapM (infer m) args
716+ u `subsumes` Function tyArgs ret
717+checkFunctionApplication' _ fnTy args ret = throwError $ "Cannot apply function of type "
718+ ++ prettyPrintType fnTy
719+ ++ " to arguments " ++ intercalate ", " (map prettyPrintValue args)
720+ ++ ". Expecting value of type " ++ prettyPrintType ret ++ "."
721+
722+subsumes :: Type -> Type -> Subst Check ()
723+subsumes (ForAll ident ty1) ty2 = do
724+ replaced <- replaceVarsWithUnknowns [ident] ty1
725+ replaced `subsumes` ty2
726+subsumes (Function args1 ret1) (Function args2 ret2) = do
727+ zipWithM subsumes args2 args1
728+ ret1 `subsumes` ret2
729+subsumes ty1 ty2 = ty1 ~~ ty2
730+
src/Language/PureScript/Types.hsnew file+74
@@ -0,0 +1,74 @@
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+typesToRow :: [(String, Type)] -> Row
48+typesToRow [] = REmpty
49+typesToRow ((name, ty):tys) = RCons name ty (typesToRow tys)
50+
51+rowToList :: Row -> ([(String, Type)], Row)
52+rowToList (RCons name ty row) = let (tys, rest) = rowToList row
53+ in ((name, ty):tys, rest)
54+rowToList r = ([], r)
55+
56+rowFromList :: ([(String, Type)], Row) -> Row
57+rowFromList ([], r) = r
58+rowFromList ((name, t):ts, r) = RCons name t (rowFromList (ts, r))
59+
60+isMonoType :: Type -> Bool
61+isMonoType (ForAll _ _) = False
62+isMonoType ty = isPolyType ty
63+
64+isPolyType :: Type -> Bool
65+isPolyType (Array ty) = isMonoType ty
66+isPolyType (Object ps) = all isMonoType (map snd . fst $ rowToList ps)
67+isPolyType (Function args ret) = all isPolyType args && isMonoType ret
68+isPolyType (TypeApp t1 t2) = isMonoType t1 && isMonoType t2
69+isPolyType (SaturatedTypeSynonym _ args) = all isMonoType args
70+isPolyType (ForAll idents ty) = isPolyType ty
71+isPolyType _ = True
72+
73+mkForAll :: [String] -> Type -> Type
74+mkForAll = flip . foldl . flip $ ForAll
src/Language/PureScript/Unknown.hsnew file+25
@@ -0,0 +1,25 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Unknown
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+{-# LANGUAGE DeriveDataTypeable #-}
16+
17+module Language.PureScript.Unknown where
18+
19+import Data.Data
20+import Data.Typeable
21+
22+newtype Unknown t = Unknown { runUnknown :: Int } deriving (Show, Eq, Ord, Data, Typeable)
23+
24+
25+
src/Language/PureScript/Values.hsnew file+99
@@ -0,0 +1,99 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Values
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+{-# LANGUAGE DeriveDataTypeable #-}
16+
17+module Language.PureScript.Values where
18+
19+import Language.PureScript.Types
20+import Language.PureScript.Names
21+
22+import Data.Data
23+
24+data UnaryOperator
25+ = Negate
26+ | Not
27+ | BitwiseNot deriving (Show, Eq, Data, Typeable)
28+
29+data BinaryOperator
30+ = Add
31+ | Subtract
32+ | Multiply
33+ | Divide
34+ | Modulus
35+ | EqualTo
36+ | NotEqualTo
37+ | LessThan
38+ | LessThanOrEqualTo
39+ | GreaterThan
40+ | GreaterThanOrEqualTo
41+ | And
42+ | Or
43+ | BitwiseAnd
44+ | BitwiseOr
45+ | BitwiseXor
46+ | ShiftLeft
47+ | ShiftRight
48+ | ZeroFillShiftRight
49+ | Concat deriving (Show, Eq, Data, Typeable)
50+
51+data Value
52+ = NumericLiteral (Either Integer Double)
53+ | StringLiteral String
54+ | BooleanLiteral Bool
55+ | Unary UnaryOperator Value
56+ | Binary BinaryOperator Value Value
57+ | BinaryNoParens (Qualified Ident) Value Value
58+ | Parens Value
59+ | ArrayLiteral [Value]
60+ | Indexer Value Value
61+ | ObjectLiteral [(String, Value)]
62+ | Accessor String Value
63+ | ObjectUpdate Value [(String, Value)]
64+ | Abs [Ident] Value
65+ | App Value [Value]
66+ | Var (Qualified Ident)
67+ | IfThenElse Value Value Value
68+ | Block [Statement]
69+ | Constructor (Qualified ProperName)
70+ | Case Value [(Binder, Value)]
71+ | TypedValue Value PolyType deriving (Show, Data, Typeable)
72+
73+data Statement
74+ = VariableIntroduction Ident Value
75+ | Assignment Ident Value
76+ | While Value [Statement]
77+ | For Ident Value Value [Statement]
78+ | ForEach Ident Value [Statement]
79+ | If IfStatement
80+ | Return Value deriving (Show, Data, Typeable)
81+
82+data IfStatement = IfStatement Value [Statement] (Maybe ElseStatement) deriving (Show, Data, Typeable)
83+
84+data ElseStatement
85+ = Else [Statement]
86+ | ElseIf IfStatement deriving (Show, Data, Typeable)
87+
88+data Binder
89+ = NullBinder
90+ | BooleanBinder Bool
91+ | StringBinder String
92+ | NumberBinder (Either Integer Double)
93+ | VarBinder Ident
94+ | NullaryBinder (Qualified ProperName)
95+ | UnaryBinder (Qualified ProperName) Binder
96+ | ObjectBinder [(String, Binder)]
97+ | ArrayBinder [Binder] (Maybe Binder)
98+ | NamedBinder Ident Binder
99+ | GuardedBinder Value Binder deriving (Show, Data, Typeable)
src/Main.hsnew file+73
@@ -0,0 +1,73 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Main
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+module Main where
16+
17+import qualified Language.PureScript as P
18+import Data.Maybe (mapMaybe)
19+import Data.List (intercalate)
20+import System.Console.CmdTheLine
21+import Control.Applicative
22+import Control.Monad (forM)
23+import System.Exit (exitSuccess, exitFailure)
24+import qualified Text.Parsec as P
25+import qualified System.IO.UTF8 as U
26+import qualified Data.Map as M
27+
28+compile :: [FilePath] -> Maybe FilePath -> Maybe FilePath -> IO ()
29+compile inputFiles outputFile externsFile = do
30+ asts <- fmap (fmap concat . sequence) $ forM inputFiles $ \inputFile -> do
31+ text <- U.readFile inputFile
32+ return $ P.runIndentParser P.parseDeclarations text
33+ case asts of
34+ Left err -> do
35+ U.print err
36+ exitFailure
37+ Right decls ->
38+ case P.compile decls of
39+ Left error -> do
40+ U.putStrLn error
41+ exitFailure
42+ Right (js, exts, _) -> do
43+ case outputFile of
44+ Just path -> U.writeFile path js
45+ Nothing -> U.putStrLn js
46+ case externsFile of
47+ Nothing -> return ()
48+ Just filePath -> U.writeFile filePath exts
49+ exitSuccess
50+
51+inputFiles :: Term [FilePath]
52+inputFiles = nonEmpty $ posAny [] $ posInfo
53+ { posDoc = "The input .ps files" }
54+
55+outputFile :: Term (Maybe FilePath)
56+outputFile = value $ opt Nothing $ (optInfo [ "o", "output" ])
57+ { optDoc = "The output .js file" }
58+
59+externsFile :: Term (Maybe FilePath)
60+externsFile = value $ opt Nothing $ (optInfo [ "e", "externs" ])
61+ { optDoc = "The output .e.ps file" }
62+
63+term :: Term (IO ())
64+term = compile <$> inputFiles <*> outputFile <*> externsFile
65+
66+termInfo :: TermInfo
67+termInfo = defTI
68+ { termName = "psc"
69+ , version = "1.0"
70+ , termDoc = "Compiles PureScript to Javascript"
71+ }
72+
73+main = run (term, termInfo)
src/Tests.hsdeleted−141
@@ -1,141 +0,0 @@
1−module Tests (runTests) where
2−
3−import Prelude.Compat
4−import Data.List
5−import Control.Applicative
6−import Control.Monad
7−
8−import System.Process
9−import System.FilePath
10−import System.IO
11−import System.Directory
12−
13−-------------------------------------------------------------------------------
14−testsDir :: IO (FilePath, FilePath)
15−-------------------------------------------------------------------------------
16−testsDir = do
17− baseDir <- getCurrentDirectory
18− return (baseDir </> "purescript-tests", baseDir)
19−
20−-------------------------------------------------------------------------------
21−runTests :: IO ()
22−-------------------------------------------------------------------------------
23−runTests = do
24−
25− (outputDir, baseDir) <- testsDir
26−
27− outputDirExists <- doesDirectoryExist outputDir
28− when outputDirExists $ removeDirectoryRecursive outputDir
29− createDirectory outputDir
30−
31− let srcDir = outputDir </> "src"
32− createDirectory srcDir
33−
34− callProcess "git" ["clone", "--branch", "v0.13.8", "--depth", "1", "https://github.com/purescript/purescript.git"]
35− let passingDir = baseDir </> "purescript" </> "tests" </> "purs" </> "passing"
36− passingTestCases <- sort . filter (".purs" `isSuffixOf`) <$> getDirectoryContents passingDir
37−
38− setCurrentDirectory outputDir
39−
40− fetchPackages
41−
42− let tests = filter (`notElem` skipped) passingTestCases
43−
44− tmp <- getTemporaryDirectory
45− createDirectoryIfMissing False (tmp </> logpath)
46− outputFile <- openFile (tmp </> logpath </> logfile) WriteMode
47− hClose outputFile
48−
49− -- Run the tests
50− --
51− forM_ tests $ \inputFile -> do
52− --
53− -- Compile/build
54− --
55− putStrLn $ "Compiling test " ++ inputFile ++ " ..."
56− setCurrentDirectory outputDir
57− copyFile (passingDir </> inputFile) (srcDir </> inputFile)
58−
59− let testCaseDir = passingDir </> (takeWhile (/='.') inputFile)
60− testCaseDirExists <- doesDirectoryExist testCaseDir
61− when testCaseDirExists $ callProcess "cp" ["-R", testCaseDir, srcDir]
62−
63− callProcess "rm" ["-rf", "output"]
64− callProcess "rm" ["-rf", "Main"]
65− callProcess "spago" ["build"]
66− --
67− -- Run executable file
68− --
69− outputFile <- openFile (tmp </> logpath </> logfile) AppendMode
70− hPutStrLn outputFile ("\n" ++ inputFile ++ ":")
71− proc <- runProcess ("./" </> "Main") [] Nothing Nothing Nothing (Just outputFile) Nothing
72−
73− removeFile (srcDir </> inputFile)
74− when testCaseDirExists $ callProcess "rm" ["-rf", srcDir </> (takeWhile (/='.') inputFile)]
75−
76− -- TODO: support failing test cases
77− --
78− -- let failing = baseDir </> "examples" </> "failing"
79− -- failingTestCases <- sort . filter (".purs" `isSuffixOf`) <$> getDirectoryContents failing
80− --
81−
82− setCurrentDirectory baseDir
83− putStrLn "PureScript tests finished"
84− putStrLn $ "Total tests available: " ++ show (length passingTestCases)
85− putStrLn $ "Tests run: " ++ show (length tests)
86− putStrLn $ "Tests skipped: " ++ show (length skipped)
87−
88−-------------------------------------------------------------------------------
89−packages :: [String]
90−-------------------------------------------------------------------------------
91−packages =
92− [ "arrays"
93− , "assert"
94− , "console"
95− , "control"
96− , "effect"
97− , "foldable-traversable"
98− , "functions"
99− , "generics-rep"
100− , "invariant"
101− , "newtype"
102− , "partial"
103− , "prelude"
104− , "proxy"
105− , "refs"
106− , "st"
107− , "type-equality"
108− , "typelevel-prelude"
109− ]
110−
111−-------------------------------------------------------------------------------
112−fetchPackages :: IO ()
113−-------------------------------------------------------------------------------
114−fetchPackages = do
115− callProcess "spago" ["init"]
116− callCommand "sed '$s/\\(}\\)/, backend = \"psgo\"\\1/' < spago.dhall | dhall format > spago.tmp"
117− callCommand "mv spago.tmp spago.dhall"
118−
119− mapM (callProcess "spago" . (\p -> ["install", p])) packages
120− return ()
121−
122−-------------------------------------------------------------------------------
123−skipped :: [String]
124−-------------------------------------------------------------------------------
125−skipped =
126− [ "2172.purs" -- foreign in Main needed (test manually)
127− , "EffFn.purs" -- foreign in Main needed (test manually)
128− , "FunWithFunDeps.purs" -- foreign in Main needed (test manually)
129− , "NumberLiterals.purs" -- unreliable float string comparison (test manually)
130− , "PolyLabels.purs" -- foreign in Main needed (test manually)
131− , "RowUnion.purs" -- foreign in Main needed (test manually)
132− , "ShadowedModuleName.purs" -- ?
133− , "StringEdgeCases.purs" -- javascript char encoding specific
134− , "StringEscapes.purs" -- Partially javascript-char-encoding-specific (test manually)
135− ]
136−
137−logpath :: FilePath
138−logpath = "purescript-output"
139−
140−logfile :: FilePath
141−logfile = "purescript-tests.out"
stack.nixdeleted−23
@@ -1,23 +0,0 @@
1−#
2−# You may need to manually run `unset STACK_IN_NIX_SHELL`
3−# (doesn't work from a `shellHook`; see: https://github.com/commercialhaskell/stack/issues/5000
4−#
5−#
6−# You may need to set LC_ALL when building, e.g.
7−# LC_ALL=en_US.iso88591 stack --nix build; see e.g. https://github.com/koalaman/shellcheck/issues/324
8−#
9−#
10−{ pkgs ?
11− import (builtins.fetchTarball {
12− name = "nixos-release-19.03";
13− url = https://github.com/nixos/nixpkgs/archive/34c7eb7545d155cc5b6f499b23a7cb1c96ab4d59.tar.gz;
14− sha256 = "11z6ajj108fy2q5g8y4higlcaqncrbjm3dnv17pvif6avagw4mcb";
15− }) {}
16−}:
17−
18−pkgs.haskell.lib.buildStackProject {
19− name = "default-stack-shell";
20− ghc = pkgs.haskell.compiler.ghc865;
21− buildInputs = with pkgs; [git git-lfs gmp ncurses zlib];
22− LANG = "en_US.UTF-8";
23−}
stack.yamldeleted−24
@@ -1,24 +0,0 @@
1−resolver: lts-13.26
2−
3−packages:
4−- .
5−
6−extra-deps:
7−- git: https://github.com/purescript/purescript
8− commit: 9cad73ed8ea7df3011032ddbd2f3de5a0c08629c
9−- happy-1.19.9
10−- language-javascript-0.7.0.0
11−- network-3.0.1.1
12−- these-1.0.1
13−- semialign-1
14−
15−nix:
16− enable: false
17− shell-file: stack.nix
18−
19−flags:
20− aeson-pretty:
21− lib-only: true
22− these:
23− assoc: false
24− quickcheck: false
support/ffi-loader.godeleted−30
@@ -1,30 +0,0 @@
1−package ffi_loader
2−
3−// Load PureScript standard library FFI packages. Comment out the ones you don't need for
4−// faster/smaller builds.
5−
6−import (
7− _ "github.com/purescript-native/go-ffi/purescript-arrays"
8− _ "github.com/purescript-native/go-ffi/purescript-assert"
9− _ "github.com/purescript-native/go-ffi/purescript-console"
10− _ "github.com/purescript-native/go-ffi/purescript-effect"
11− _ "github.com/purescript-native/go-ffi/purescript-enums"
12− _ "github.com/purescript-native/go-ffi/purescript-exceptions"
13− _ "github.com/purescript-native/go-ffi/purescript-foldable-traversable"
14− _ "github.com/purescript-native/go-ffi/purescript-functions"
15− _ "github.com/purescript-native/go-ffi/purescript-globals"
16− _ "github.com/purescript-native/go-ffi/purescript-integers"
17− _ "github.com/purescript-native/go-ffi/purescript-lazy"
18− _ "github.com/purescript-native/go-ffi/purescript-math"
19− _ "github.com/purescript-native/go-ffi/purescript-partial"
20− _ "github.com/purescript-native/go-ffi/purescript-prelude"
21− _ "github.com/purescript-native/go-ffi/purescript-random"
22− _ "github.com/purescript-native/go-ffi/purescript-refs"
23− _ "github.com/purescript-native/go-ffi/purescript-st"
24− _ "github.com/purescript-native/go-ffi/purescript-strings"
25− _ "github.com/purescript-native/go-ffi/purescript-unfoldable"
26−)
27−
28−// Add your own FFI packages here.
29−
30−import ()
support/go.mod.ffi-loaderdeleted−2
@@ -1,2 +0,0 @@
1−module $PROJECT/purescript-native/ffi-loader
2−
support/go.mod.outputdeleted−2
@@ -1,2 +0,0 @@
1−module $PROJECT/purescript-native/output
2−
support/go.mod.workingdeleted−1
@@ -1 +0,0 @@
1−module $PROJECT/example
test/Spec.hsdeleted−2
@@ -1,2 +0,0 @@
1−main :: IO ()
2−main = putStrLn "Test suite not yet implemented"
tests/Main.hsnew file+70
@@ -0,0 +1,70 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Main
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+module Main (main) where
16+
17+import qualified Language.PureScript as P
18+
19+import Data.List (isSuffixOf)
20+import Control.Applicative
21+import Control.Monad
22+import System.Exit (exitSuccess, exitFailure)
23+import System.FilePath (pathSeparator)
24+import System.Directory (getCurrentDirectory, getDirectoryContents)
25+import qualified System.IO.UTF8 as U
26+import qualified Data.Map as M
27+
28+compile :: FilePath -> IO (Either String P.Environment)
29+compile inputFile = do
30+ ast <- P.runIndentParser P.parseDeclarations <$> U.readFile inputFile
31+ case ast of
32+ Left parseError -> do
33+ return (Left $ show parseError)
34+ Right decls -> do
35+ case P.compile decls of
36+ Left typeError -> do
37+ return (Left typeError)
38+ Right (_, _, env) -> do
39+ return (Right env)
40+
41+assert :: FilePath -> (Either String P.Environment -> Maybe String) -> IO ()
42+assert inputFile f = do
43+ e <- compile inputFile
44+ case f e of
45+ Just err -> exitFailure
46+ Nothing -> return ()
47+
48+assertCompiles :: FilePath -> IO ()
49+assertCompiles inputFile = do
50+ putStrLn $ "assert " ++ inputFile ++ " compiles successfully"
51+ assert inputFile $ either Just (const Nothing)
52+
53+assertDoesNotCompile :: FilePath -> IO ()
54+assertDoesNotCompile inputFile = do
55+ putStrLn $ "assert " ++ inputFile ++ " does not compile"
56+ assert inputFile $ either (const Nothing) (const $ Just "Should not have compiled")
57+
58+main :: IO ()
59+main = do
60+ cd <- getCurrentDirectory
61+ let examples = cd ++ pathSeparator : "examples"
62+ let passing = examples ++ pathSeparator : "passing"
63+ passingTestCases <- getDirectoryContents passing
64+ forM_ passingTestCases $ \inputFile -> when (".ps" `isSuffixOf` inputFile) $
65+ assertCompiles (passing ++ pathSeparator : inputFile)
66+ let failing = examples ++ pathSeparator : "failing"
67+ failingTestCases <- getDirectoryContents failing
68+ forM_ failingTestCases $ \inputFile -> when (".ps" `isSuffixOf` inputFile) $
69+ assertDoesNotCompile (failing ++ pathSeparator : inputFile)
70+ exitSuccess