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