git.iko.soy/rowtype-yoga/purescript-native
on 7de366c help sign in
355eb9b
swap
0 ahead, 3523 behind
.gitignore−13
since splitsnapshots
unifiedsplit
@@ -8,16 +8,3 @@ cabal.sandbox.config
8*.chs.h
8*.chs.h
9*.lksh*
9*.lksh*
10.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.ymlnew file+6
@@ -0,0 +1,6 @@
1+language: haskell
2+notifications:
3+ email: true
4+after_success:
5+ - cabal install
6+ - ./execTests.sh
CONTRIBUTING.mdnew file+16
@@ -0,0 +1,16 @@
1+Pull requests are encouraged.
2+
3+Please follow the following guidelines:
4+
5+- Add at least a test to `examples/passing/` and possibly to `examples/failing`.
6+- Build the binaries and libs with `cabal build`
7+- Install the binaries and libs with `cabal install`.
8+- Run `cabal test` to build the test suite.
9+- Run `./execTests.sh` to execute the test suite.
10+- Please run `hlint`.
11+
12+If you would like to contribute, please consider the issues in the current milestone first.
13+
14+Send me (`paf31`) a message if you have any implementation questions, I'm more than happy to talk about the design, and I'm more than willing to redesign parts if necessary.
15+
16+Finally, if you have made code changes and would like to be included in the copyright notice in the cabal file, please include that change in your pull request.
ChangeLog.mddeleted−3
@@ -1,3 +0,0 @@
1−# Changelog for pscpp
2−
3−## Unreleased changes
LICENSE+16−26
@@ -1,30 +1,20 @@
1−Copyright Andy Arvanitis (c) 2018
1+The MIT License (MIT)
2
2
3−All rights reserved.
3+Copyright (c) 2013 Phil Freeman
4
4
5−Redistribution and use in source and binary forms, with or without
5+Permission is hereby granted, free of charge, to any person obtaining a copy of
6+this software and associated documentation files (the "Software"), to deal in
7+the Software without restriction, including without limitation the rights to
8+use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
9+the Software, and to permit persons to whom the Software is furnished to do so,
6−modification, are permitted provided that the following conditions are met:
10+subject to the following conditions:
7
11
8− * Redistributions of source code must retain the above copyright
12+The above copyright notice and this permission notice shall be included in all
9− notice, this list of conditions and the following disclaimer.
13+copies or substantial portions of the Software.
10
14
11− * Redistributions in binary form must reproduce the above
15+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
12− copyright notice, this list of conditions and the following
13− disclaimer in the documentation and/or other materials provided
14− with the distribution.
15−
16− * Neither the name of Author name here nor the names of other
17− contributors may be used to endorse or promote products derived
18− from this software without specific prior written permission.
19−
20−THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21−"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22−LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
16+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
23−A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
17+FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
24−OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
18+COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
25−SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26−LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27−DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28−THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29−(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
19+IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
30−OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
20+CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
README-go.mddeleted−48
@@ -1,48 +0,0 @@
1−
2−### psgo
3−
4−#### Performance
5−
6−* No runtime system beyond some support types and functions
7−* Uses PureScript's normal tail call optimization techniques for generated Go code
8−
9−#### Differences from PureScript:
10−
11−* Foreign imports/exports are Go instead of JavaScript – see [standard library foreign implementations](https://github.com/andyarvanitis/purescript-native-go-ffi)
12−* No Go-specific REPL
13−
14−#### Other notes:
15−
16−* The provided `Any` type is just an alias for `interface{}`
17−* PureScript types are represented in Go with:
18−
19− | PureScript | Go |
20− |------------|----|
21− |`Array` | `[]Any`|
22− |`String` | `string`|
23− |`Number` | `float64`|
24− |`Int` | `int`|
25− |`Char` | `string` (single UTF-8 entity)|
26− |`Boolean` | `bool`|
27− |Records | `map[string]Any`|
28−
29−#### Future ideas:
30−
31−* Nice facilities (modules) for concurrency/parallelism, using goroutines
32−
33−
34−#### Getting Started
35−This assumes you are running macOS (OS X) or a Unix-like system (Linux, *BSD, etc.).
36−
37−1. Choose a working directory wherever you like. Then create a `src` subdirectory under it, which will be where you will place your own PureScript source files.
38−
39−1. Initialize your project with `spago init`, and install any dependencies with `spago install` (please see their instructions if you haven't used it before).
40−
41−1. Add the `backend = "psgo"` option to your `spago.dhall` file. That way `spago` will use the psgo backend when compiling.
42−
43−1. You should now be ready to build a PureScript program:
44− * As stated above, place your source file(s) in the working directory's `src` subdirectory and execute `spago build`.
45−
46− * This will generate the Go source tree for your program and then build an executable binary. The resulting executable will be in your working directory and will be named `Main`. The generated source files will be under `output/`.
47−
48−---
README.md+10−38
@@ -1,41 +1,13 @@
1−[![PureScript](https://raw.githubusercontent.com/purescript/purescript/master/logo.png)](http://purescript.org)
1+[![Build Status](https://secure.travis-ci.org/purescript/purescript.png?branch=master)](http://travis-ci.org/purescript/purescript)
2+[![Hackage](https://budueba.com/hackage/purescript)](http://hackage.haskell.org/package/purescript)
2
3
3−This is a platform-native compiler backend for [PureScript](https://github.com/purescript/purescript). It attempts to generate "sane", debuggable, and portable [C++11](https://isocpp.org/wiki/faq/cpp11) (or later) or [Go](https://golang.org/) code as an intermediate language, which is then compiled to a native executable binary. This also enables easy interoperability with existing C/C++ or Go frameworks and libraries on a number of platforms.
4+PureScript is a small strongly, statically typed programming language with expressive types, written in and inspired by Haskell, and compiling to Javascript.
4
5
5−There are two utilities in the purescript-native "suite": `pscpp` and `psgo`. The source code in this branch is for `psgo`, the purescript-to-Go transpiler. For the source code of the `pscpp` purescript-to-C++ transpiler, please see the [cpp branch](https://github.com/andyarvanitis/purescript-native/tree/cpp).
6+## Resources
6
7
7−#### Platforms
8+- [Documentation](http://purescript.readthedocs.org/)
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+- [#purescript IRC @ FreeNode](irc://irc.freenode.net/#purescript)
9− * macOS Mojave 10.14.5 – full test suite
10+- [Twitter](http://twitter.com/purescript)
10− * For C++, Xcode 10.2.1's `clang` was used
11+- [Try PureScript!](http://tryps.functorial.com/)
11− * For Go, `go` version 1.12.7 was used
12− * Windows 10 x64 – full test suite
13− * C++: Visual Studio 2017 and `clang`
14− * Go: `go` version 1.12.7
15− * Linux Debian 9.5 amd64 – full test suite (C++)
16− * Default versions of `clang` and `gcc`
17− * Linux Debian 10 amd64 – full test suite (Go)
18− * Default version of `go`
19− * Raspberry Pi 3 B+ Raspbian official build (ARM), default versions of `clang` and `gcc`
20−
21−
22−#### Requirements for building `pscpp` and `psgo`
23−
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/))
25−
26−#### Requirements for using PureScript + purescript-native
27−
28−* A recent version (0.13+) of [purescript](https://github.com/purescript/purescript/releases).
12+- [Release Notes](https://github.com/purescript/purescript/blob/master/RELEASE.md)
29−
13+- [Contributing to PureScript](https://github.com/purescript/purescript/blob/master/CONTRIBUTING.md)
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.
34−
35−
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)
39−
40−
41−---
RELEASE-0.2.mdnew file+85
@@ -0,0 +1,85 @@
1+## 0.2.0 Changes
2+
3+Many thanks to the [contributors](https://github.com/purescript/purescript/graphs/contributors) who helped with this release.
4+
5+- Full language guide can be found [here](http://functorial.com/purescript).
6+- Try out the latest features [here](http://tryps.functorial.com).
7+
8+### New Features
9+
10+- RankNTypes
11+
12+ This experimental feature allows polymorphic types (introduced with `forall`) to appear on the left of a function arrow, or as the type of a record field, etc. For example:
13+
14+ rank2 :: (forall a. a -> a) -> Number
15+ rank2 = \f -> if f true then f 1 else f 2
16+
17+- Modules
18+- Polymorphic Object Update
19+
20+ Records now support member update in which the type of the field changes during the update. For example:
21+
22+ data Wrap a = Wrap a
23+
24+ update = \o -> o { prop = Wrap o.prop }
25+
26+### Enhancements
27+
28+- Naked expressions as statements
29+
30+ Naked expressions of type `{}` can now be used as statements.
31+
32+- Split code generation into `AST -> JS` and `JS -> String`
33+
34+ JavaScript generation is now split into the generation of a JavaScript AST, and the pretty-printing of that AST. This enables some optimizations, and a better JavaScript pretty-printer.
35+
36+- Syntactic sugar for introducing curried functions
37+
38+ Single-argument functions and multiple-argument functions can now be introduced in the same way:
39+
40+ test = \a (b, c) d -> a + b + c + d
41+
42+- JavaScript optimizations
43+
44+ Some basic dead-variable elimination, inlining and eta-conversion are now performed on the generated JavaScript.
45+
46+- Generate formatted Javascript
47+
48+ The generated JavaScript is now formatted to be more readable. In particular, newlines get generated, and the correct indentation is used.
49+
50+- More valid infix operators
51+
52+ The colon and period characters are now valid in infix operator names.
53+
54+### Syntax Changes
55+
56+- Avoid 'do' keyword for blocks
57+
58+ `do` will be used later for Haskell-like monad comprehensions, so its previous use in introducing blocks of statements is now invalid. The `do` keyword is still reserved.
59+
60+- Member foreign import syntax
61+
62+ A small syntactic addition to the FFI, to support a common use case.
63+
64+- Make FFI syntax match Haskell
65+
66+ Use `foreign import` instead of `extern`.
67+
68+- Make record declaration syntax match Haskell
69+- Simplify array binders
70+
71+ There are now two types of array binders: cons binders `x : xs -> ...` and array binders `[x, y, z] -> ...` instead of the previously confusing `[x:xs]`.
72+
73+- Array indexing syntax is ambiguous
74+
75+ Array elements are now accessed using the `!!` operator: `arr !! 0` etc.
76+
77+### Bug Fixes
78+
79+- Allow guards access to current scope
80+
81+### Libraries
82+
83+- Prelude
84+
85+ There is now a basic prelude in the `libraries/prelude` folder.
RELEASE-0.3.mdnew file+85
@@ -0,0 +1,85 @@
1+## 0.3.0 Changes
2+
3+Many thanks to the [contributors](https://github.com/purescript/purescript/graphs/contributors) who helped with this release.
4+
5+- Full language guide can be found [here](http://functorial.com/purescript).
6+- Try out the latest features [here](http://tryps.functorial.com).
7+
8+## New Features / Enhancements
9+
10+- Mutually recursive functions and types are now allowed within a module.
11+- Syntactic sugar for patterns in top-level declarations has been added. For example:
12+
13+ sum [] = 0
14+ sum (x:xs) = x + sum xs
15+
16+- Basic support for type classes has been added. Polymorphic types of the form `forall a. (C a) => ...` will not be inferred but can be checked. Type inference still works if all type class instances can be determined. There is not yet support for functionality like GHC's `FlexibleInstances`, `FlexibleContexts` or `MultiParamTypesClasses`. For example:
17+
18+ class Truthy a where
19+ isTrue :: a -> Boolean
20+
21+ instance Truthy Boolean where
22+ isTrue b = b
23+
24+ instance Truthy String where
25+ isTrue "" = false
26+ isTrue _ = true
27+
28+ ifThenElse :: forall a b. (Truthy a) => a -> b -> b -> b
29+ ifThenElse a tr fa = if isTrue a then tr else fa
30+
31+- There is now support for `do` notation, using the `Monad` type class from the `Prelude` module. For example:
32+
33+ data Maybe = Nothing | Just a
34+
35+ instance Prelude.Monad Maybe where
36+ ret = Just
37+ (>>=) Nothing _ = Nothing
38+ (>>=) (Just a) f = f a
39+
40+ test = do
41+ x <- Just 1
42+ y <- Just 2
43+ ret $ x + y
44+
45+- There is now a better story for side-effects. The `Eff` module in the `Prelude` defines a monad `Eff e` where e is a row of effect types. The kind system now defines a new kind `!` of effects. Row polymorphism allows different native effects to be interleaved. For example:
46+
47+ test = do
48+ trace "Testing"
49+ throwError "Error!"
50+
51+ has inferred type `forall eff. Eff (trace :: Trace | error :: Error String | eff)`.
52+ See the `/examples/passing/Eff.purs` file for a more in-depth set of examples.
53+ Supported native effects currently include `ST`, `Trace`, `Error` and `DOM` (via the `libraries/jquery` module).
54+- There is a new flag `--run-main` which will check the type of the `Main.main` function and emit the call to `main();` after all other generated Javascript.
55+- The `Prelude` module is now automatically included, unless the `--no-prelude` flag is specified.
56+- The class of accepted operator names has been expanded. Specifically, `$` is now a valid operator, and is defined in the `Prelude` module.
57+- Tail calls can be eliminated using the `--tco` flag.
58+- There is basic support for checking the types of values at runtime, using the `--runtime-type-checks` flag. Right now, this only works for primitive types, and so is a work-in-progress.
59+- GHCJS/Fay-style foreign imports are now supported. An example is
60+
61+ foreign import "function(n) { \
62+ \ return function(p) {\
63+ \ return Math.pow(n, p);\
64+ \ }\
65+ \ }" pow :: Number -> Number -> Number
66+- Data constructors now get imported along with their type definitions.
67+- The `-s` flag will now cause the compiler to use `stdin` for input.
68+- There is a new executable `psci` which provides simple REPL-like functionality - it parses expressions, passes the generated Javascript to Node for execution, and prints the result. This is a work-in-progress.
69+- The JQuery example (`libraries/jquery/test`) has been improved to use the new `Eff` monad and `do` notation.
70+
71+## Regressions
72+
73+- `foreach` is no longer supported. The `Prelude` module defines `map` which should provide the same functionality.
74+- Support for naked expressions as statements has been removed.
75+
76+## Bug Fixes
77+
78+- Operator precedence rules now work across modules.
79+- A bug in which expressions involving non-qualified names did not typecheck was fixed.
80+- Trailing spaces have been removed in the generated Javascript, thanks to @utkarshkukreti.
81+- Type synonyms now work properly across modules.
82+- Module imports are not transitive, which was previously leading to some unexpected error messages.
83+- A bug which caused the optimizer to break generated Javascript for mutually recursive values was fixed.
84+- Some `Prelude` functions which called methods in the standard Javascript library have been fixed.
85+
RELEASE-0.4.mdnew file+60
@@ -0,0 +1,60 @@
1+## 0.4.0 Changes
2+
3+This release focussed mainly on bug fixes and minor enhancements, in order to provide a stable release of the compiler.
4+
5+This release saw major contributions from [a number of new contributors](https://github.com/purescript/purescript/graphs/contributors). Thank you very much to everyone who submitted pull requests, issues and suggestions, and also to the users of the #purescript FreeNode channel for their valuable feedback. As always, new contributors are always welcome!
6+
7+- The full language guide can be found [here](http://purescript.readthedocs.org).
8+- Try out the latest features [here](http://tryps.functorial.com).
9+
10+## Breaking Changes
11+
12+- Multiple argument functions are no longer available.
13+- When used in the browser, PureScript modules are now accessed through `window.PS.<ModuleName>`. The `PS` object name can be changed via the `--browser-namespace` compiler argument.
14+- The `--run-main` argument has been replaced with `--main` which can now accept a module name in which to find the `main` function.
15+
16+### New Features
17+
18+- Dead code elimination. The new compiler argument `--module=` can be used to specify one or more modules that should be kept in the generated code along with their dependencies. If no modules are specified, all code is exported.
19+
20+### Enhancements
21+
22+- The `->` and `[]` types are now usable in type class instances.
23+- The file path is included in syntax error messages.
24+- Most reserved Javascript names (`return`, `const`, etc) are now usable.
25+- Generated code for operators is more user friendly (for example, `Prelude[">>="]`). Where this transformation cannot be applied, human-readable variable names (e.g. `$greater$greater$eq`) are generated.
26+- The typechecker's function application judgement was greatly simplified, and as a result, more valid things now typecheck.
27+- Data constructors with multiple arguments can now be defined.
28+- It is no longer necessary to sort modules in order of dependencies manually.
29+- Case statements matching data constructors no longer generate unnecessary constructor checks at runtime if there is only a single data constructor.
30+- New optimizer rules were added to inline JavaScript's built-in operators.
31+
32+### Bug Fixes
33+
34+- Floats parse correctly.
35+- Using data constructors in pattern matches now works properly across modules.
36+- PureScript modules no longer overwrite global objects with the same name.
37+- Show problems with shadowing of names were fixed.
38+- Problems with recursive non-function values were fixed.
39+- Type synonyms can now expand to types containing more type synonyms.
40+- A bug in capture-avoiding type variable substitution which was affecting the `Functor (Either e)` instance was fixed.
41+- Type synonym instances are now disallowed.
42+- Precedence rules for some basic operators were corrected.
43+- A bug which allowed skolem variables to escape their scope was add (thanks to Brian McKenna).
44+- Modules containing mutually recursive type synonyms and data declarations now compile correctly.
45+- A number of bugs in the optimizer were addressed.
46+
47+### Libraries
48+
49+- The `Prelude` has been greatly expanded. Definitions for built-in JavaScript operators have been moved into the Prelude.
50+- Gary Burgess has released the [grunt-purescript library](https://github.com/purescript/grunt-purescript) to build PureScript code using Grunt.
51+- The [purescript-parsing](https://github.com/purescript/purescript-parsing) library provides Parsec-like parsing combinators.
52+- The [purescript-promises](https://github.com/purescript/purescript-promises) library provides `Monad` and `Applicative` instances for promises.
53+- The [purescript-quickcheck](https://github.com/purescript/purescript-quickcheck) library provides a very basic implementation of a QuickCheck-style testing harness.
54+- The [purescript-json](https://github.com/purescript/purescript-json) library aims to provide a safe way to consume JSON data.
55+
56+### Documentation
57+
58+- Documentation for the `Prelude` modules is now automatically generated and can be found [here](http://purescript.readthedocs.org/en/latest/prelude.html).
59+- There is now Hackage documentation.
60+- Code comments have been improved.
RELEASE-0.5.mdnew file+27
@@ -0,0 +1,27 @@
1+## 0.5.0 Changes
2+
3+## Breaking Changes
4+
5+- Support for blocks has been removed. (paf31)
6+
7+### New Features
8+
9+-
10+
11+### Enhancements
12+
13+- Pretty printing for row types was improved (garyb)
14+- Module names can now contain `.` (garyb)
15+- New optimizer rules have been added for code in the ST monad, to reproduce the functionality of the blocks feature, which has been removed (paf31)
16+
17+### Bug Fixes
18+
19+- The subsumes relation has been fixed for object types (paf31)
20+
21+### Libraries
22+
23+-
24+
25+### Documentation
26+
27+-
Setup.hsdeleted−2
@@ -1,2 +0,0 @@
1−import Distribution.Simple
2−main = defaultMain
Setup.lhsnew file+6
@@ -0,0 +1,6 @@
1+#!/usr/bin/runhaskell
2+> module Main where
3+> import Distribution.Simple
4+> main :: IO ()
5+> main = defaultMain
6+
app/Main.hsdeleted−250
@@ -1,250 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−{-# LANGUAGE RankNTypes #-}
3−{-# LANGUAGE TemplateHaskell #-}
4−
5−module Main where
6−
7−import Control.Monad (when)
8−import qualified Control.Monad.Parallel as Par
9−import Data.Aeson
10−import Data.Aeson.Types
11−import Data.Char
12−import Data.FileEmbed (embedFile)
13−import Data.List (delete, intercalate, isPrefixOf, nub, partition, (\\))
14−import Data.Maybe
15−import Data.Monoid ((<>))
16−import Data.Version
17−import Control.Monad.Supply
18−import Control.Monad.Supply.Class
19−import Text.Printf
20−
21−import System.Environment
22−import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist, getCurrentDirectory, getModificationTime)
23−import System.FilePath ((</>), joinPath, splitDirectories, takeDirectory)
24−import System.FilePath.Find
25−import System.Process
26−
27−import Data.Text (Text)
28−import qualified Data.Text as T
29−import qualified Data.Text.Encoding as T
30−import qualified Data.Text.Lazy as L
31−import qualified Data.Text.Lazy.Encoding as L
32−import qualified Data.ByteString as B
33−
34−import Development.GitRev
35−
36−import Language.PureScript.AST.Literals
37−import Language.PureScript.CoreFn
38−import Language.PureScript.CoreFn.FromJSON
39−
40−import CodeGen.IL
41−import CodeGen.IL.Common
42−import CodeGen.IL.Printer
43−
44−import Tests
45−
46−data Command = Build | Run (Maybe String)
47−
48−parseJson :: Text -> Value
49−parseJson text
50− | Just fileJson <- decode . L.encodeUtf8 $ L.fromStrict text = fileJson
51− | otherwise = error "Bad json"
52−
53−jsonToModule :: Value -> Module Ann
54−jsonToModule value =
55− case parse moduleFromJSON value of
56− Success (_, r) -> r
57− _ -> error "Failed parsing corefn. Psgo currently supports purescript <= 0.13.8"
58−
59−splitArgs :: [String] -> ([String], Maybe String, [String])
60−splitArgs args =
61− let (opts, files) = partition (isPrefixOf "--") args
62− opts' = (map . map) toLower opts
63− (moduleName, files') =
64− if null files
65− then (Nothing, files)
66− else
67− if "--run" `elem` opts' && length (files) >= 1
68− then do
69− let file0 = head files
70− files' = tail files
71− case file0 of
72− "Main.main" -> (Just "Main", files')
73− "Test.Main.main" -> (Just "Test.Main", files')
74− _ -> (Nothing, files)
75− else (Nothing, files)
76− in (opts, moduleName, files')
77−
78−main :: IO ()
79−main = do
80− args <- getArgs
81− -- let (opts, files) = partition (isPrefixOf "--") args
82− let (opts, moduleName, files) = splitArgs args
83− opts' = (map . map) toLower opts
84− if "--tests" `elem` opts'
85− then runTests
86− else do
87− if "--help" `elem` opts' || "--version" `elem` opts'
88− then do
89− when ("--help" `elem` opts') $ do
90− putStrLn help
91− when ("--version" `elem` opts') $ do
92− let branch = $(gitBranch)
93− details | branch == "golang" = "master, commit " ++ $(gitHash)
94− | otherwise = branch
95− putStrLn $ details ++ if $(gitDirty) then " (DIRTY)" else ""
96− else do
97− if null files
98− then do
99− currentDir <- getCurrentDirectory
100− processFiles opts' [currentDir]
101− else
102− processFiles opts' files
103− if "--run" `elem` opts
104− then runBuildTool $ Run moduleName
105− else when ("--no-build" `notElem` opts) $
106− runBuildTool Build
107− return ()
108− where
109− processFiles :: [String] -> [FilePath] -> IO ()
110− processFiles opts [file] = do
111− isDir <- doesDirectoryExist file
112− if isDir then do
113− files <- find always (fileName ==? corefn) file
114− if null files
115− then errorNoCorefnFiles
116− else generateFiles opts files
117− else generateFiles opts [file]
118− processFiles opts files = do
119− generateFiles opts files
120− basePath :: [FilePath] -> FilePath
121− basePath files =
122− let filepath = takeDirectory (head files) in
123− joinPath $ (init $ splitDirectories filepath)
124− generateFiles :: [String] -> [FilePath] -> IO ()
125− generateFiles opts files = do
126− let baseOutpath = basePath files
127− writeSupportFiles baseOutpath
128− Par.mapM (generateCode opts baseOutpath) files
129− return ()
130− runBuildTool :: Command -> IO ()
131− runBuildTool cmd = do
132− project <- projectEnv
133− case cmd of
134− Build -> do
135− callProcess "go" ["build", T.unpack project </> modPrefix' </> "Main"]
136− Run moduleName -> do
137− callProcess "go" ["run", T.unpack project </> modPrefix' </> fromMaybe "Main" moduleName]
138− return ()
139−
140−generateCode :: [String] -> FilePath -> FilePath -> IO ()
141−generateCode opts baseOutpath jsonFile = do
142− jsonModTime <- getModificationTime jsonFile
143− let filepath = takeDirectory jsonFile
144− dirparts = splitDirectories $ filepath
145− mname = last dirparts
146− basedir = joinPath $ init dirparts
147− mname' = T.pack mname
148− possibleFileName = basedir </> (T.unpack mname') </> implFileName mname'
149− exists <- doesFileExist possibleFileName
150− if exists
151− then do
152− modTime <- getModificationTime possibleFileName
153− when (modTime < jsonModTime) $
154− transpile opts baseOutpath jsonFile
155− else transpile opts baseOutpath jsonFile
156−
157−transpile :: [String] -> FilePath -> FilePath -> IO ()
158−transpile opts baseOutpath jsonFile = do
159− jsonText <- T.decodeUtf8 <$> B.readFile jsonFile
160− project <- projectEnv
161− let module' = jsonToModule $ parseJson jsonText
162− ((_, foreigns, asts, implHeader, implFooter), _) <- runSupplyT 5 (moduleToIL module' project)
163− let mn = moduleNameToIL' $ moduleName module'
164− implementation = prettyPrintIL asts
165− outpath = joinPath [baseOutpath, T.unpack mn]
166− implPath = outpath </> implFileName mn
167− createDirectoryIfMissing True outpath
168− putStrLn implPath
169− B.writeFile implPath $ T.encodeUtf8 (implHeader <> implementation <> implFooter)
170−
171−writeSupportFiles :: FilePath -> IO ()
172−writeSupportFiles baseOutpath = do
173− currentDir <- getCurrentDirectory
174− let outputdir = T.pack $ baseOutpath \\ currentDir
175− ffiOutpath = currentDir </> subdir
176− createDirectoryIfMissing True baseOutpath
177− createDirectoryIfMissing True ffiOutpath
178− writeModuleFile outputdir currentDir $(embedFile "support/go.mod.working")
179− writeModuleFile outputdir baseOutpath $(embedFile "support/go.mod.output")
180− writeModuleFile outputdir ffiOutpath $(embedFile "support/go.mod.ffi-loader")
181− writeLoaderFile ffiOutpath $(embedFile "support/ffi-loader.go")
182− where
183− writeModuleFile :: Text -> FilePath -> B.ByteString -> IO ()
184− writeModuleFile outputdir path modText = do
185− let goModSource = path </> "go.mod"
186− goModSourceExists <- doesFileExist goModSource
187− when (not goModSourceExists) $ do
188− project <- projectEnv
189− let project' = T.unpack project
190− outputdir' = tail $ T.unpack outputdir
191− modText' = T.replace "$PROJECT" project $ T.decodeUtf8 modText
192− replaceLoader = project' </> ffiLoader' <> "=." </> subdir
193− replaceOutput = project' </> modPrefix' <> "=." </> outputdir'
194− B.writeFile goModSource $ T.encodeUtf8 modText'
195− callProcess "go" ["mod", "edit", "-replace", replaceLoader]
196− callProcess "go" ["mod", "edit", "-replace", replaceOutput]
197− callProcess "go" ["clean", "-modcache"]
198− writeLoaderFile :: FilePath -> B.ByteString -> IO ()
199− writeLoaderFile ffiOutpath loaderText = do
200− let loaderSource = ffiOutpath </> "ffi_loader.go"
201− loaderSourceExists <- doesFileExist loaderSource
202− when (not loaderSourceExists) $ do
203− B.writeFile loaderSource loaderText
204−
205−implFileName :: Text -> FilePath
206−implFileName mn = ((\c -> if c == '.' then '_' else c) <$> T.unpack mn) <> ".go"
207−
208−projectEnv :: IO Text
209−projectEnv = do
210− T.pack . fromMaybe defaultProject <$> lookupEnv goproject
211−
212−help :: String
213−help = "Usage: psgo OPTIONS COREFN-FILES\n\
214− \ PureScript to native (via go) compiler\n\n\
215− \Available options:\n\
216− \ --help Show this help text\n\n\
217− \ --version Show the version number\n\n\
218− \ --run Run the generated go code directly, without building an\n\
219− \ executable\n\
220− \ --no-build Generate go source files, but do not build an executable\n\
221− \ --tests Run test cases (under construction)\n\n\
222− \See also:\n\
223− \ purs compile --help\n"
224−
225−corefn :: String
226−corefn = "corefn.json"
227−
228−goSrc :: String
229−goSrc = ".go"
230−
231−goproject :: String
232−goproject = "GOPROJECT"
233−
234−defaultProject :: String
235−defaultProject = "project.localhost"
236−
237−modPrefix' :: String
238−modPrefix' = T.unpack modPrefix
239−
240−ffiLoader' :: String
241−ffiLoader' = T.unpack ffiLoader
242−
243−subdir :: String
244−subdir = T.unpack modLabel
245−
246−errorNoCorefnFiles :: IO ()
247−errorNoCorefnFiles = do
248− ioError . userError $ "no compiled purescript '" <> corefn <> "' files found –\n" <>
249− " make sure to use the '--codegen corefn' option with your purs\n" <>
250− " project build tool"
default.nixdeleted−23
@@ -1,23 +0,0 @@
1−let
2− haskellNix = import (builtins.fetchTarball https://github.com/input-output-hk/haskell.nix/archive/master.tar.gz) {};
3− nixpkgsSrc = haskellNix.sources.nixpkgs-1903; # has hsc2hs-0.68.4
4−
5− hsc2hsOverlay = self: super: {
6− buildPackages = super.buildPackages // {
7− hsc2hs = super.haskellPackages.hsc2hs;
8− };
9− };
10−
11− nixpkgsArgs = haskellNix.nixpkgsArgs // {
12− overlays = haskellNix.nixpkgsArgs.overlays ++ [ hsc2hsOverlay ];
13− };
14−in
15−{ pkgs ? import nixpkgsSrc nixpkgsArgs
16−}:
17−
18−pkgs.haskell-nix.stackProject {
19− src = pkgs.haskell-nix.haskellLib.cleanGit {
20− name = "purescript-native";
21− src = ./.;
22− };
23−}
docgen/Main.hsnew file+155
@@ -0,0 +1,155 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Main
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+module Main where
16+
17+import qualified Language.PureScript as P
18+import System.Console.CmdTheLine
19+import Control.Applicative
20+import Control.Monad
21+import Control.Monad.Writer
22+import System.Exit (exitSuccess, exitFailure)
23+import qualified System.IO.UTF8 as U
24+import qualified Paths_purescript as Paths
25+import Data.Version (showVersion)
26+import Data.List
27+import Data.Function (on)
28+
29+docgen :: FilePath -> IO ()
30+docgen input = do
31+ text <- U.readFile input
32+ case P.runIndentParser input P.parseModules text of
33+ Left err -> do
34+ U.print err
35+ exitFailure
36+ Right ms -> do
37+ U.putStrLn . runDocs $ renderModules ms
38+ exitSuccess
39+
40+type Docs = Writer [String] ()
41+
42+runDocs :: Docs -> String
43+runDocs = unlines . execWriter
44+
45+spacer :: Docs
46+spacer = tell [""]
47+
48+headerLevel :: Int -> String -> Docs
49+headerLevel level hdr = tell [replicate level '#' ++ ' ' : hdr]
50+
51+atIndent :: Int -> String -> Docs
52+atIndent indent text =
53+ let ls = lines text in
54+ forM_ ls $ \l -> tell [replicate indent ' ' ++ l]
55+
56+renderModules :: [P.Module] -> Docs
57+renderModules ms = do
58+ headerLevel 1 "Module Documentation"
59+ mapM_ renderModule ms
60+
61+renderModule :: P.Module -> Docs
62+renderModule (P.Module moduleName ds) = do
63+ headerLevel 2 $ "Module " ++ (P.runModuleName moduleName)
64+ spacer
65+ headerLevel 3 "Types"
66+ spacer
67+ renderTopLevel (filter isTypeDeclaration ds)
68+ spacer
69+ headerLevel 3 "Type Classes"
70+ spacer
71+ renderTopLevel (filter isTypeClassDeclaration ds)
72+ spacer
73+ headerLevel 3 "Type Class Instances"
74+ spacer
75+ renderTopLevel (filter isTypeInstanceDeclaration ds)
76+ spacer
77+ headerLevel 3 "Values"
78+ spacer
79+ renderTopLevel (filter isValueDeclaration ds)
80+ spacer
81+
82+renderTopLevel :: [P.Declaration] -> Docs
83+renderTopLevel decls = forM_ (sortBy (compare `on` getName) decls) $ \decl -> do
84+ renderDeclaration 4 decl
85+ spacer
86+
87+renderDeclaration :: Int -> P.Declaration -> Docs
88+renderDeclaration n (P.TypeDeclaration ident ty) =
89+ atIndent n $ show ident ++ " :: " ++ P.prettyPrintType ty
90+renderDeclaration n (P.ExternDeclaration _ ident _ ty) =
91+ atIndent n $ show ident ++ " :: " ++ P.prettyPrintType ty
92+renderDeclaration n (P.DataDeclaration name args ctors) = do
93+ let typeName = P.runProperName name ++ " " ++ intercalate " " args
94+ atIndent n $ "data " ++ typeName ++ " where"
95+ forM_ ctors $ \(ctor, tys) -> do
96+ atIndent (n + 2) $ P.runProperName ctor ++ " :: " ++ concat (map (\ty -> P.prettyPrintType ty ++ " -> ") tys) ++ typeName
97+renderDeclaration n (P.ExternDataDeclaration name kind) =
98+ atIndent n $ "data " ++ P.runProperName name ++ " :: " ++ P.prettyPrintKind kind
99+renderDeclaration n (P.TypeSynonymDeclaration name args ty) = do
100+ let typeName = P.runProperName name ++ " " ++ intercalate " " args
101+ atIndent n $ "type " ++ typeName ++ " = " ++ P.prettyPrintType ty
102+renderDeclaration n (P.TypeClassDeclaration name arg ds) = do
103+ atIndent n $ "class " ++ P.runProperName name ++ " " ++ arg ++ " where"
104+ mapM_ (renderDeclaration (n + 2)) ds
105+renderDeclaration n (P.TypeInstanceDeclaration constraints name ty _) = do
106+ let constraintsText = case constraints of
107+ [] -> ""
108+ cs -> "(" ++ intercalate "," (map (\(pn, ty') -> show pn ++ " (" ++ P.prettyPrintType ty' ++ ")") cs) ++ ") => "
109+ atIndent n $ constraintsText ++ "instance " ++ show name ++ " " ++ P.prettyPrintType ty
110+renderDeclaration _ _ = return ()
111+
112+getName :: P.Declaration -> String
113+getName (P.TypeDeclaration ident _) = show ident
114+getName (P.ExternDeclaration _ ident _ _) = show ident
115+getName (P.DataDeclaration name _ _) = P.runProperName name
116+getName (P.ExternDataDeclaration name _) = P.runProperName name
117+getName (P.TypeSynonymDeclaration name _ _) = P.runProperName name
118+getName (P.TypeClassDeclaration name _ _) = P.runProperName name
119+getName (P.TypeInstanceDeclaration _ name _ _) = show name
120+getName _ = error "Invalid argument to getName"
121+
122+isValueDeclaration :: P.Declaration -> Bool
123+isValueDeclaration (P.TypeDeclaration _ _) = True
124+isValueDeclaration (P.ExternDeclaration _ _ _ _) = True
125+isValueDeclaration _ = False
126+
127+isTypeDeclaration :: P.Declaration -> Bool
128+isTypeDeclaration (P.DataDeclaration _ _ _) = True
129+isTypeDeclaration (P.ExternDataDeclaration _ _) = True
130+isTypeDeclaration (P.TypeSynonymDeclaration _ _ _) = True
131+isTypeDeclaration _ = False
132+
133+isTypeClassDeclaration :: P.Declaration -> Bool
134+isTypeClassDeclaration (P.TypeClassDeclaration _ _ _) = True
135+isTypeClassDeclaration _ = False
136+
137+isTypeInstanceDeclaration :: P.Declaration -> Bool
138+isTypeInstanceDeclaration (P.TypeInstanceDeclaration _ _ _ _) = True
139+isTypeInstanceDeclaration _ = False
140+
141+inputFile :: Term FilePath
142+inputFile = value $ pos 0 "input.ps" $ posInfo { posDoc = "The input .ps file" }
143+
144+term :: Term (IO ())
145+term = docgen <$> inputFile
146+
147+termInfo :: TermInfo
148+termInfo = defTI
149+ { termName = "docgen"
150+ , version = showVersion $ Paths.version
151+ , termDoc = "Generate Markdown documentation from PureScript extern files"
152+ }
153+
154+main :: IO ()
155+main = run (term, termInfo)
docs/.gitignorenew file+1
@@ -0,0 +1 @@
1+build
docs/Makefilenew file+177
@@ -0,0 +1,177 @@
1+# Makefile for Sphinx documentation
2+#
3+
4+# You can set these variables from the command line.
5+SPHINXOPTS =
6+SPHINXBUILD = sphinx-build
7+PAPER =
8+BUILDDIR = build
9+
10+# User-friendly check for sphinx-build
11+ifeq ($(shell which $(SPHINXBUILD) >/dev/null 2>&1; echo $$?), 1)
12+$(error The '$(SPHINXBUILD)' command was not found. Make sure you have Sphinx installed, then set the SPHINXBUILD environment variable to point to the full path of the '$(SPHINXBUILD)' executable. Alternatively you can add the directory with the executable to your PATH. If you don't have Sphinx installed, grab it from http://sphinx-doc.org/)
13+endif
14+
15+# Internal variables.
16+PAPEROPT_a4 = -D latex_paper_size=a4
17+PAPEROPT_letter = -D latex_paper_size=letter
18+ALLSPHINXOPTS = -d $(BUILDDIR)/doctrees $(PAPEROPT_$(PAPER)) $(SPHINXOPTS) source
19+# the i18n builder cannot share the environment and doctrees with the others
20+I18NSPHINXOPTS = $(PAPEROPT_$(PAPER)) $(SPHINXOPTS) source
21+
22+.PHONY: help clean html dirhtml singlehtml pickle json htmlhelp qthelp devhelp epub latex latexpdf text man changes linkcheck doctest gettext
23+
24+help:
25+ @echo "Please use \`make <target>' where <target> is one of"
26+ @echo " html to make standalone HTML files"
27+ @echo " dirhtml to make HTML files named index.html in directories"
28+ @echo " singlehtml to make a single large HTML file"
29+ @echo " pickle to make pickle files"
30+ @echo " json to make JSON files"
31+ @echo " htmlhelp to make HTML files and a HTML help project"
32+ @echo " qthelp to make HTML files and a qthelp project"
33+ @echo " devhelp to make HTML files and a Devhelp project"
34+ @echo " epub to make an epub"
35+ @echo " latex to make LaTeX files, you can set PAPER=a4 or PAPER=letter"
36+ @echo " latexpdf to make LaTeX files and run them through pdflatex"
37+ @echo " latexpdfja to make LaTeX files and run them through platex/dvipdfmx"
38+ @echo " text to make text files"
39+ @echo " man to make manual pages"
40+ @echo " texinfo to make Texinfo files"
41+ @echo " info to make Texinfo files and run them through makeinfo"
42+ @echo " gettext to make PO message catalogs"
43+ @echo " changes to make an overview of all changed/added/deprecated items"
44+ @echo " xml to make Docutils-native XML files"
45+ @echo " pseudoxml to make pseudoxml-XML files for display purposes"
46+ @echo " linkcheck to check all external links for integrity"
47+ @echo " doctest to run all doctests embedded in the documentation (if enabled)"
48+
49+clean:
50+ rm -rf $(BUILDDIR)/*
51+
52+html:
53+ $(SPHINXBUILD) -b html $(ALLSPHINXOPTS) $(BUILDDIR)/html
54+ @echo
55+ @echo "Build finished. The HTML pages are in $(BUILDDIR)/html."
56+
57+dirhtml:
58+ $(SPHINXBUILD) -b dirhtml $(ALLSPHINXOPTS) $(BUILDDIR)/dirhtml
59+ @echo
60+ @echo "Build finished. The HTML pages are in $(BUILDDIR)/dirhtml."
61+
62+singlehtml:
63+ $(SPHINXBUILD) -b singlehtml $(ALLSPHINXOPTS) $(BUILDDIR)/singlehtml
64+ @echo
65+ @echo "Build finished. The HTML page is in $(BUILDDIR)/singlehtml."
66+
67+pickle:
68+ $(SPHINXBUILD) -b pickle $(ALLSPHINXOPTS) $(BUILDDIR)/pickle
69+ @echo
70+ @echo "Build finished; now you can process the pickle files."
71+
72+json:
73+ $(SPHINXBUILD) -b json $(ALLSPHINXOPTS) $(BUILDDIR)/json
74+ @echo
75+ @echo "Build finished; now you can process the JSON files."
76+
77+htmlhelp:
78+ $(SPHINXBUILD) -b htmlhelp $(ALLSPHINXOPTS) $(BUILDDIR)/htmlhelp
79+ @echo
80+ @echo "Build finished; now you can run HTML Help Workshop with the" \
81+ ".hhp project file in $(BUILDDIR)/htmlhelp."
82+
83+qthelp:
84+ $(SPHINXBUILD) -b qthelp $(ALLSPHINXOPTS) $(BUILDDIR)/qthelp
85+ @echo
86+ @echo "Build finished; now you can run "qcollectiongenerator" with the" \
87+ ".qhcp project file in $(BUILDDIR)/qthelp, like this:"
88+ @echo "# qcollectiongenerator $(BUILDDIR)/qthelp/PureScript.qhcp"
89+ @echo "To view the help file:"
90+ @echo "# assistant -collectionFile $(BUILDDIR)/qthelp/PureScript.qhc"
91+
92+devhelp:
93+ $(SPHINXBUILD) -b devhelp $(ALLSPHINXOPTS) $(BUILDDIR)/devhelp
94+ @echo
95+ @echo "Build finished."
96+ @echo "To view the help file:"
97+ @echo "# mkdir -p $$HOME/.local/share/devhelp/PureScript"
98+ @echo "# ln -s $(BUILDDIR)/devhelp $$HOME/.local/share/devhelp/PureScript"
99+ @echo "# devhelp"
100+
101+epub:
102+ $(SPHINXBUILD) -b epub $(ALLSPHINXOPTS) $(BUILDDIR)/epub
103+ @echo
104+ @echo "Build finished. The epub file is in $(BUILDDIR)/epub."
105+
106+latex:
107+ $(SPHINXBUILD) -b latex $(ALLSPHINXOPTS) $(BUILDDIR)/latex
108+ @echo
109+ @echo "Build finished; the LaTeX files are in $(BUILDDIR)/latex."
110+ @echo "Run \`make' in that directory to run these through (pdf)latex" \
111+ "(use \`make latexpdf' here to do that automatically)."
112+
113+latexpdf:
114+ $(SPHINXBUILD) -b latex $(ALLSPHINXOPTS) $(BUILDDIR)/latex
115+ @echo "Running LaTeX files through pdflatex..."
116+ $(MAKE) -C $(BUILDDIR)/latex all-pdf
117+ @echo "pdflatex finished; the PDF files are in $(BUILDDIR)/latex."
118+
119+latexpdfja:
120+ $(SPHINXBUILD) -b latex $(ALLSPHINXOPTS) $(BUILDDIR)/latex
121+ @echo "Running LaTeX files through platex and dvipdfmx..."
122+ $(MAKE) -C $(BUILDDIR)/latex all-pdf-ja
123+ @echo "pdflatex finished; the PDF files are in $(BUILDDIR)/latex."
124+
125+text:
126+ $(SPHINXBUILD) -b text $(ALLSPHINXOPTS) $(BUILDDIR)/text
127+ @echo
128+ @echo "Build finished. The text files are in $(BUILDDIR)/text."
129+
130+man:
131+ $(SPHINXBUILD) -b man $(ALLSPHINXOPTS) $(BUILDDIR)/man
132+ @echo
133+ @echo "Build finished. The manual pages are in $(BUILDDIR)/man."
134+
135+texinfo:
136+ $(SPHINXBUILD) -b texinfo $(ALLSPHINXOPTS) $(BUILDDIR)/texinfo
137+ @echo
138+ @echo "Build finished. The Texinfo files are in $(BUILDDIR)/texinfo."
139+ @echo "Run \`make' in that directory to run these through makeinfo" \
140+ "(use \`make info' here to do that automatically)."
141+
142+info:
143+ $(SPHINXBUILD) -b texinfo $(ALLSPHINXOPTS) $(BUILDDIR)/texinfo
144+ @echo "Running Texinfo files through makeinfo..."
145+ make -C $(BUILDDIR)/texinfo info
146+ @echo "makeinfo finished; the Info files are in $(BUILDDIR)/texinfo."
147+
148+gettext:
149+ $(SPHINXBUILD) -b gettext $(I18NSPHINXOPTS) $(BUILDDIR)/locale
150+ @echo
151+ @echo "Build finished. The message catalogs are in $(BUILDDIR)/locale."
152+
153+changes:
154+ $(SPHINXBUILD) -b changes $(ALLSPHINXOPTS) $(BUILDDIR)/changes
155+ @echo
156+ @echo "The overview file is in $(BUILDDIR)/changes."
157+
158+linkcheck:
159+ $(SPHINXBUILD) -b linkcheck $(ALLSPHINXOPTS) $(BUILDDIR)/linkcheck
160+ @echo
161+ @echo "Link check complete; look for any errors in the above output " \
162+ "or in $(BUILDDIR)/linkcheck/output.txt."
163+
164+doctest:
165+ $(SPHINXBUILD) -b doctest $(ALLSPHINXOPTS) $(BUILDDIR)/doctest
166+ @echo "Testing of doctests in the sources finished, look at the " \
167+ "results in $(BUILDDIR)/doctest/output.txt."
168+
169+xml:
170+ $(SPHINXBUILD) -b xml $(ALLSPHINXOPTS) $(BUILDDIR)/xml
171+ @echo
172+ @echo "Build finished. The XML files are in $(BUILDDIR)/xml."
173+
174+pseudoxml:
175+ $(SPHINXBUILD) -b pseudoxml $(ALLSPHINXOPTS) $(BUILDDIR)/pseudoxml
176+ @echo
177+ @echo "Build finished. The pseudo-XML files are in $(BUILDDIR)/pseudoxml."
docs/source/conf.pynew file+258
@@ -0,0 +1,258 @@
1+# -*- coding: utf-8 -*-
2+#
3+# PureScript documentation build configuration file, created by
4+# sphinx-quickstart on Wed Jan 22 22:04:23 2014.
5+#
6+# This file is execfile()d with the current directory set to its
7+# containing dir.
8+#
9+# Note that not all possible configuration values are present in this
10+# autogenerated file.
11+#
12+# All configuration values have a default; values that are commented out
13+# serve to show the default.
14+
15+import sys
16+import os
17+
18+# If extensions (or modules to document with autodoc) are in another directory,
19+# add these directories to sys.path here. If the directory is relative to the
20+# documentation root, use os.path.abspath to make it absolute, like shown here.
21+#sys.path.insert(0, os.path.abspath('.'))
22+
23+# -- General configuration ------------------------------------------------
24+
25+# If your documentation needs a minimal Sphinx version, state it here.
26+#needs_sphinx = '1.0'
27+
28+# Add any Sphinx extension module names here, as strings. They can be
29+# extensions coming with Sphinx (named 'sphinx.ext.*') or your custom
30+# ones.
31+extensions = []
32+
33+# Add any paths that contain templates here, relative to this directory.
34+templates_path = ['_templates']
35+
36+# The suffix of source filenames.
37+source_suffix = '.rst'
38+
39+# The encoding of source files.
40+#source_encoding = 'utf-8-sig'
41+
42+# The master toctree document.
43+master_doc = 'index'
44+
45+# General information about the project.
46+project = u'PureScript'
47+copyright = u'2014, Phil Freeman'
48+
49+# The version info for the project you're documenting, acts as replacement for
50+# |version| and |release|, also used in various other places throughout the
51+# built documents.
52+#
53+# The short X.Y version.
54+version = '0.4.0'
55+# The full version, including alpha/beta/rc tags.
56+release = '0.4.0'
57+
58+# The language for content autogenerated by Sphinx. Refer to documentation
59+# for a list of supported languages.
60+#language = None
61+
62+# There are two options for replacing |today|: either, you set today to some
63+# non-false value, then it is used:
64+#today = ''
65+# Else, today_fmt is used as the format for a strftime call.
66+#today_fmt = '%B %d, %Y'
67+
68+# List of patterns, relative to source directory, that match files and
69+# directories to ignore when looking for source files.
70+exclude_patterns = []
71+
72+# The reST default role (used for this markup: `text`) to use for all
73+# documents.
74+#default_role = None
75+
76+# If true, '()' will be appended to :func: etc. cross-reference text.
77+#add_function_parentheses = True
78+
79+# If true, the current module name will be prepended to all description
80+# unit titles (such as .. function::).
81+#add_module_names = True
82+
83+# If true, sectionauthor and moduleauthor directives will be shown in the
84+# output. They are ignored by default.
85+#show_authors = False
86+
87+# The name of the Pygments (syntax highlighting) style to use.
88+pygments_style = 'sphinx'
89+
90+# A list of ignored prefixes for module index sorting.
91+#modindex_common_prefix = []
92+
93+# If true, keep warnings as "system message" paragraphs in the built documents.
94+#keep_warnings = False
95+
96+
97+# -- Options for HTML output ----------------------------------------------
98+
99+# The theme to use for HTML and HTML Help pages. See the documentation for
100+# a list of builtin themes.
101+html_theme = 'default'
102+
103+# Theme options are theme-specific and customize the look and feel of a theme
104+# further. For a list of options available for each theme, see the
105+# documentation.
106+#html_theme_options = {}
107+
108+# Add any paths that contain custom themes here, relative to this directory.
109+#html_theme_path = []
110+
111+# The name for this set of Sphinx documents. If None, it defaults to
112+# "<project> v<release> documentation".
113+#html_title = None
114+
115+# A shorter title for the navigation bar. Default is the same as html_title.
116+#html_short_title = None
117+
118+# The name of an image file (relative to this directory) to place at the top
119+# of the sidebar.
120+#html_logo = None
121+
122+# The name of an image file (within the static path) to use as favicon of the
123+# docs. This file should be a Windows icon file (.ico) being 16x16 or 32x32
124+# pixels large.
125+#html_favicon = None
126+
127+# Add any paths that contain custom static files (such as style sheets) here,
128+# relative to this directory. They are copied after the builtin static files,
129+# so a file named "default.css" will overwrite the builtin "default.css".
130+html_static_path = ['_static']
131+
132+# Add any extra paths that contain custom files (such as robots.txt or
133+# .htaccess) here, relative to this directory. These files are copied
134+# directly to the root of the documentation.
135+#html_extra_path = []
136+
137+# If not '', a 'Last updated on:' timestamp is inserted at every page bottom,
138+# using the given strftime format.
139+#html_last_updated_fmt = '%b %d, %Y'
140+
141+# If true, SmartyPants will be used to convert quotes and dashes to
142+# typographically correct entities.
143+#html_use_smartypants = True
144+
145+# Custom sidebar templates, maps document names to template names.
146+#html_sidebars = {}
147+
148+# Additional templates that should be rendered to pages, maps page names to
149+# template names.
150+#html_additional_pages = {}
151+
152+# If false, no module index is generated.
153+#html_domain_indices = True
154+
155+# If false, no index is generated.
156+#html_use_index = True
157+
158+# If true, the index is split into individual pages for each letter.
159+#html_split_index = False
160+
161+# If true, links to the reST sources are added to the pages.
162+#html_show_sourcelink = True
163+
164+# If true, "Created using Sphinx" is shown in the HTML footer. Default is True.
165+#html_show_sphinx = True
166+
167+# If true, "(C) Copyright ..." is shown in the HTML footer. Default is True.
168+#html_show_copyright = True
169+
170+# If true, an OpenSearch description file will be output, and all pages will
171+# contain a <link> tag referring to it. The value of this option must be the
172+# base URL from which the finished HTML is served.
173+#html_use_opensearch = ''
174+
175+# This is the file name suffix for HTML files (e.g. ".xhtml").
176+#html_file_suffix = None
177+
178+# Output file base name for HTML help builder.
179+htmlhelp_basename = 'PureScriptdoc'
180+
181+
182+# -- Options for LaTeX output ---------------------------------------------
183+
184+latex_elements = {
185+# The paper size ('letterpaper' or 'a4paper').
186+#'papersize': 'letterpaper',
187+
188+# The font size ('10pt', '11pt' or '12pt').
189+#'pointsize': '10pt',
190+
191+# Additional stuff for the LaTeX preamble.
192+#'preamble': '',
193+}
194+
195+# Grouping the document tree into LaTeX files. List of tuples
196+# (source start file, target name, title,
197+# author, documentclass [howto, manual, or own class]).
198+latex_documents = [
199+ ('index', 'PureScript.tex', u'PureScript Documentation',
200+ u'Phil Freeman', 'manual'),
201+]
202+
203+# The name of an image file (relative to this directory) to place at the top of
204+# the title page.
205+#latex_logo = None
206+
207+# For "manual" documents, if this is true, then toplevel headings are parts,
208+# not chapters.
209+#latex_use_parts = False
210+
211+# If true, show page references after internal links.
212+#latex_show_pagerefs = False
213+
214+# If true, show URL addresses after external links.
215+#latex_show_urls = False
216+
217+# Documents to append as an appendix to all manuals.
218+#latex_appendices = []
219+
220+# If false, no module index is generated.
221+#latex_domain_indices = True
222+
223+
224+# -- Options for manual page output ---------------------------------------
225+
226+# One entry per manual page. List of tuples
227+# (source start file, name, description, authors, manual section).
228+man_pages = [
229+ ('index', 'purescript', u'PureScript Documentation',
230+ [u'Phil Freeman'], 1)
231+]
232+
233+# If true, show URL addresses after external links.
234+#man_show_urls = False
235+
236+
237+# -- Options for Texinfo output -------------------------------------------
238+
239+# Grouping the document tree into Texinfo files. List of tuples
240+# (source start file, target name, title, author,
241+# dir menu entry, description, category)
242+texinfo_documents = [
243+ ('index', 'PureScript', u'PureScript Documentation',
244+ u'Phil Freeman', 'PureScript', 'One line description of project.',
245+ 'Miscellaneous'),
246+]
247+
248+# Documents to append as an appendix to all manuals.
249+#texinfo_appendices = []
250+
251+# If false, no module index is generated.
252+#texinfo_domain_indices = True
253+
254+# How to display URL addresses: 'footnote', 'no', or 'inline'.
255+#texinfo_show_urls = 'footnote'
256+
257+# If true, do not generate a @detailmenu in the "Top" node's menu.
258+#texinfo_no_detailmenu = False
docs/source/ffi.rstnew file+31
@@ -0,0 +1,31 @@
1+Foreign Function Interface
2+==========================
3+
4+Importing Values
5+----------------
6+
7+The `foreign import` keyword declares a value which is defined in Javascript, and its type::
8+
9+ foreign import pow :: Number -> Number -> Number
10+
11+Inline Javascript
12+-----------------
13+
14+A foreign import declaration may optionally contain its definition in Javascript as a string literal. If this is provided, the string will be inserted directly into the generated Javascript before the current module definition::
15+
16+ foreign import pow "function pow(n) {\
17+ \ return function(p) {\
18+ \ return Math.pow(n, p);\
19+ \ };\
20+ \}" :: Number -> Number -> Number
21+
22+Importing Types
23+---------------
24+
25+To declare a new type with no constructors, use `foreign import data` and provide the kind::
26+
27+ foreign import data DOM :: *
28+
29+ foreign import document :: {
30+ createElement :: String -> DOM
31+ }
docs/source/index.rstnew file+30
@@ -0,0 +1,30 @@
1+.. PureScript documentation master file, created by
2+ sphinx-quickstart on Wed Jan 22 22:04:23 2014.
3+ You can adapt this file completely to your liking, but it should at least
4+ contain the root `toctree` directive.
5+
6+Welcome to PureScript's documentation!
7+======================================
8+
9+Contents:
10+
11+.. toctree::
12+ :maxdepth: 2
13+
14+ intro
15+ types
16+ kinds
17+ syntax
18+ typeclasses
19+ patterns
20+ modules
21+ ffi
22+ prelude
23+
24+Indices and tables
25+==================
26+
27+* :ref:`genindex`
28+* :ref:`modindex`
29+* :ref:`search`
30+
docs/source/intro.rstnew file+134
@@ -0,0 +1,134 @@
1+Introduction
2+============
3+
4+PureScript is a small strongly, statically typed compile-to-JS language with a number of interesting features, such as:
5+
6+- Type Inference
7+- Higher Kinded Polymorphism
8+- Support for basic Javascript types
9+- Extensible records
10+- Extensible effects
11+- Optimizer rules for generation of efficient Javascript
12+- Pattern matching
13+- Simple FFI
14+- Modules
15+- Rank N Types
16+- Do Notation
17+- Optional tail-call elimination
18+- Type Classes
19+
20+Installation
21+------------
22+
23+If you have the Haskell Plaform installed, then you can install the latest released version from Hackage::
24+
25+ cabal update
26+ cabal install purescript
27+
28+If you would like to build the latest version of the code, clone this repository and build::
29+
30+ git clone git://github.com:paf31/purescript.git
31+ cabal configure --enable-tests
32+ cabal build
33+ cabal test
34+ cabal install
35+
36+Usage
37+-----
38+
39+The `psc` executable takes a list of PureScript source files as arguments and by default writes out its errors or output to the console.
40+
41+The following options are supported:
42+
43+--stdin Read input from standard input instead of from files
44+--output Write the generated Javascript to the specified file
45+--externs Write a list of foreign imports declarations to the specified file in addition to generating Javascript output
46+--runtime-type-checks Generate simple runtime type checks for function arguments with simple types.
47+--tco Perform tail-call elimination on the generated Javascript.
48+--no-prelude Do not include the Prelude in the generated Javascript.
49+--magic-do Overload the `do` keyword to inline calls to `bind` for the `Eff` monad, to generate more efficient code.
50+--main Generate a call to `main` in the specified module after all other generated Javascript. Defaults to `Main` if the option is used but no value is provided.
51+--module If specified, any code which is not referenced transitively from this module will be removed. This argument can be used multiple times.
52+--browser-namespace Specify the namespace that PureScript modules will be exported to when running in the browser.
53+
54+Motivation
55+----------
56+
57+I was looking for a simple functional language which would compile to JavaScript and have the following characteristics:
58+
59+- Generate simple readable Javascript
60+- Provide the ability to compile to tight loops if necessary
61+- Reasonable type system
62+- Ideally, written in a programming language I would enjoy working in
63+- Provides a simple interface to existing Javascript code
64+
65+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.
66+
67+PureScript was originally designed to implement purely functional core logic. However, recent additions to the compiler and libraries now also make it a good option for general-purpose programming.
68+
69+PureScript can also be seen as a trade-off between a theoretically ideal language and one which generates reasonably high performance code.
70+
71+Hello, PureScript!
72+------------------
73+
74+As an introductory example, here is the usual "Hello World" written in PureScript::
75+
76+ module Main where
77+
78+ import Trace
79+
80+ main = trace "Hello, World!"
81+
82+which compiles to the following Javascript, ignoring the Prelude::
83+
84+ var Main;
85+ (function (Main) {
86+ var main = trace("Hello, World!");
87+ Main.main = main;
88+ })(Main = Main || {});
89+
90+The following command will compile and execute the PureScript code above::
91+
92+ psc input.purs --run-main | nodejs
93+
94+Another Example
95+---------------
96+
97+The following code defines a `Person` data type and a function to generate a string representation for a `Person`::
98+
99+ data Person = Person { name :: String, age :: Number }
100+
101+ foreign import numberToString :: Number -> String
102+
103+ showPerson :: Person -> String
104+ showPerson (Person o) = o.name ++ ", aged " ++ numberToString(o.age)
105+
106+Line by line, this reads as follows:
107+
108+- `Person` is a data type with one constructor, also called `Person`
109+- The `Person` constructor takes an object with two properties, `name` which is a `String`, and `age` which is a `Number`
110+- The `numberToString` function is written in Javascript, and converts a `Number` to its `String` representation
111+- The `showPerson` function takes a `Person` and returns a `String`
112+- `showPerson` works by case analysis on its argument, first matching the constructor `Person` and then using string concatenation and object accessors to return its result.
113+
114+The generated Javascript looks like this::
115+
116+ var Person = function (value) {
117+ return { ctor: 'Person', values: [value] };
118+ };
119+
120+ function showPerson(_1) {
121+ return _1.values[0].name + ", aged " + numberToString(_1.values[0].age);
122+ };
123+
124+Related Projects
125+----------------
126+
127+PureScript might be compared to other AltJS projects such as Roy, Haste, Fay, Elm and GHCJS. Certainly, there is a lot of overlap in terms of syntax, but the goals of PureScript listed above separate it in one or more ways from each of these languages.
128+
129+Roy is probably the most similar language on the list, and was a large influence on the development of PureScript. There are however, key differences in the foreign function interface, the type system and the choice of development language (Haskell vs. Javascript)
130+
131+Projects such as Haste, Fay and GHCJS aim to use some combination of the GHC compiler itself and/or its intermediate representation, Core, to perform some of the tasks involved in compilation such as parsing and type checking. This usually gives the advantage that tools and libraries can be shared with Haskell, but often at the cost of the size of the generated Javascript. This is the main practical difference between PureScript and these projects.
132+
133+Elm also shares a lot in terms of functionality with PureScript. Elm is designed for functional reactive programming, and focusses on tools and language features suitable for that domain, while PureScript focusses on the development of purely functional core application logic. Another difference between PureScript and Elm is PureScript's lack of a runtime system.
134+
docs/source/kinds.rstnew file+21
@@ -0,0 +1,21 @@
1+Kind System
2+===========
3+
4+The kind system defines the following kinds:
5+
6+- ``*``, the kind of types.
7+- ``!``, the kind of effects.
8+- Arrow kinds ``k1 -> k2``
9+- Row kinds ``# k``
10+
11+Row Kinds
12+---------
13+
14+The kind ``# k`` of rows is used to classify labelled, unordered collections of types of kind ``k``.
15+
16+For example ``# *`` is the kind of rows of types, as used to define records, and ``# !`` is the kind of rows of effects, used to define the monad ``Eff`` of extensible effects.
17+
18+Quantification
19+--------------
20+
21+A type variable can refer to not only a type or a row, but a type constructor, or row constructor etc., and type variables with those kinds can be bound inside a ``forall`` quantifier.
docs/source/modules.rstnew file+29
@@ -0,0 +1,29 @@
1+Modules
2+=======
3+
4+All code in PureScript is contained in a module. Modules are introduced using the ``module`` keyword::
5+
6+ module A where
7+
8+ id x = x
9+
10+When referencing values or data types in another module, names may be qualified by using a dot::
11+
12+ module B where
13+
14+ foo = A.id
15+
16+Importing Modules
17+-----------------
18+
19+A module can be imported using the ``import`` keyword. This will create aliases for all of the values and types in the imported module::
20+
21+ module B where
22+
23+ import A
24+
25+Alternatively, a list of names to import can be provided in parentheses::
26+
27+ module B where
28+
29+ import A (id)
docs/source/patterns.rstnew file+139
@@ -0,0 +1,139 @@
1+Pattern Matching
2+================
3+
4+Pattern matching deconstructs a value to bring zero or more expressions into scope. Pattern matches are introduced with the `case` keyword.
5+
6+Pattern matches have the following general form::
7+
8+ case value of
9+ pattern -> result
10+ ...
11+ pattern -> result
12+
13+Pattern matching can also be used in the declaration of functions, as we have already seen::
14+
15+ fn pattern_1 ... pattern_n = result
16+
17+Patterns can also be used when introducing functions. For example::
18+
19+ example x y z = x * y + z
20+
21+The following pattern types are supported:
22+
23+- Wildcard pattern
24+- Literal patterns
25+- Variable pattern
26+- Array patterns
27+- Cons patterns
28+- Constructor patterns
29+- Record patterns
30+- Named patterns
31+- Guards
32+
33+Patterns need not be exhaustive. A pattern match failed exception will be thrown at runtime if no pattern matches the input.
34+
35+Wildcard Patterns
36+-----------------
37+
38+The wilcard `_` matches any input and brings nothing into scope::
39+
40+ f _ = 0
41+
42+Literal Patterns
43+----------------
44+
45+Literal patterns are provided to match on primitives::
46+
47+ f true = 0
48+ f false = 1
49+
50+ g "Foo" = 0
51+ g _ = 1
52+
53+ h 0 = 0
54+ h _ = 1
55+
56+Variable Patterns
57+-----------------
58+
59+A variable pattern matches any input and binds that input to its name::
60+
61+ double x = x * 2
62+
63+Array Patterns
64+--------------
65+
66+Array patterns match an input which is an array, and bring its elements into scope. For example::
67+
68+ f [x] = x
69+ f [x, y] = x * y
70+ f _ = 0
71+
72+Here, the first pattern only matches arrays of length one, and brings the first element of the array into scope.
73+
74+The second pattern matches arrays with two elements, and brings the first and second elements into scope.
75+
76+Cons Patterns
77+-------------
78+
79+The head and tail of a non-empty array can be matched by using a cons pattern::
80+
81+ sum [] = 0
82+ sum (x : xs) = x + sum xs
83+
84+`:` associates to the right::
85+
86+ addPairs (x : y : xs) = x * y + addPairs xs
87+ addPairs _ = 0
88+
89+
90+Constructor patterns
91+--------------------
92+
93+Constructor patterns match a data constructor and its arguments::
94+
95+ data Foo = Foo String | Bar Number Boolean
96+
97+ foo (Foo s) = true
98+ foo (Bar _ b) = b
99+
100+Record Patterns
101+---------------
102+
103+Record patterns match an input which is a record, and bring its properties into scope::
104+
105+ f { foo = "Foo" } = o.bar
106+ f _ = 0
107+
108+Nested Patterns
109+---------------
110+
111+The patterns above can be combined to create larger patterns. For example::
112+
113+ f { arr = x : _, take = "car" } = x
114+ f { arr = _ : x : _, take = "cadr" } = x
115+ f _ = 0
116+
117+Named Patterns
118+--------------
119+
120+Named patterns bring additional names into scope when using nested patterns. Any pattern can be named by using the ``@`` symbol::
121+
122+ f a@(_ : _ : _) = true
123+ f _ = false
124+
125+Here, in the first pattern, any array with two or more elements will be matched and bound to the variable ``a``.
126+
127+Guards
128+------
129+
130+Guards are used to impose additional constraints inside a pattern using boolean-valued expressions, and are introduced with a pipe after the pattern::
131+
132+ evens [] = 0
133+ evens (x : xs) | x % 2 == 0 = 1 + evens xs
134+ evens (_ : xs) = evens xs
135+
136+When using patterns to define a function at the top level, guards appear after all patterns::
137+
138+ greater x y | x > y = true
139+ greater _ _ = false
docs/source/prelude.rstnew file+788
@@ -0,0 +1,788 @@
1+Module Documentation
2+====================
3+
4+Module Prelude
5+--------------
6+
7+Types
8+~~~~~
9+
10+::
11+
12+ data Ref a where
13+ Ref :: a -> Ref a
14+
15+Type Classes
16+~~~~~~~~~~~~
17+
18+::
19+
20+ class Alternative f where
21+ empty :: forall a. f a
22+ (<|>) :: forall a. f a -> f a -> f a
23+
24+ class Applicative f where
25+ pure :: forall a. a -> f a
26+ (<*>) :: forall b. forall a. f (a -> b) -> f a -> f b
27+
28+ class Bits b where
29+ (&) :: b -> b -> b
30+ (|) :: b -> b -> b
31+ (^) :: b -> b -> b
32+ shl :: b -> Prim.Number -> b
33+ shr :: b -> Prim.Number -> b
34+ zshr :: b -> Prim.Number -> b
35+ complement :: b -> b
36+
37+ class BoolLike b where
38+ (&&) :: b -> b -> b
39+ (||) :: b -> b -> b
40+ not :: b -> b
41+
42+ class Category a where
43+ id :: forall t. a t t
44+ (<<<) :: forall d. forall c. forall b. a c d -> a b c -> a b d
45+ (>>>) :: forall d. forall c. forall b. a b c -> a c d -> a b d
46+
47+ class Eq a where
48+ (==) :: a -> a -> Prim.Boolean
49+ (/=) :: a -> a -> Prim.Boolean
50+
51+ class Functor f where
52+ (<$>) :: forall b. forall a. (a -> b) -> f a -> f b
53+
54+ class Monad m where
55+ return :: forall a. a -> m a
56+ (>>=) :: forall b. forall a. m a -> (a -> m b) -> m b
57+
58+ class Num a where
59+ (+) :: a -> a -> a
60+ (-) :: a -> a -> a
61+ (*) :: a -> a -> a
62+ (/) :: a -> a -> a
63+ (%) :: a -> a -> a
64+ negate :: a -> a
65+
66+ class Ord a where
67+ (<) :: a -> a -> Prim.Boolean
68+ (>) :: a -> a -> Prim.Boolean
69+ (<=) :: a -> a -> Prim.Boolean
70+ (>=) :: a -> a -> Prim.Boolean
71+
72+ class Read a where
73+ read :: Prim.String -> a
74+
75+ class Show a where
76+ show :: a -> Prim.String
77+
78+Type Class Instances
79+~~~~~~~~~~~~~~~~~~~~
80+
81+::
82+
83+ (Monad (m)) => instance Applicative m
84+
85+ instance Bits Prim.Number
86+
87+ instance BoolLike Prim.Boolean
88+
89+ instance Category Prim.Function
90+
91+ instance Eq Ref a
92+
93+ instance Eq Prim.String
94+
95+ instance Eq Prim.Number
96+
97+ instance Eq Prim.Boolean
98+
99+ (Eq (a)) => instance Eq [a]
100+
101+ (Applicative (f)) => instance Functor f
102+
103+ instance Num Prim.Number
104+
105+ instance Ord Prim.Number
106+
107+ instance Prelude.Show Prim.Number
108+
109+ instance Read Prim.String
110+
111+ instance Read Prim.Boolean
112+
113+ instance Read Prim.Number
114+
115+ instance Show Prim.String
116+
117+ instance Show Prim.Boolean
118+
119+Values
120+~~~~~~
121+
122+::
123+
124+ (!!) :: forall a. [a] -> Prim.Number -> a
125+
126+ (#) :: forall b. forall a. a -> (a -> b) -> b
127+
128+ ($) :: forall b. forall a. (a -> b) -> a -> b
129+
130+ (++) :: Prim.String -> Prim.String -> Prim.String
131+
132+ boolAnd :: Prim.Boolean -> Prim.Boolean -> Prim.Boolean
133+
134+ boolNot :: Prim.Boolean -> Prim.Boolean
135+
136+ boolOr :: Prim.Boolean -> Prim.Boolean -> Prim.Boolean
137+
138+ const :: forall b. forall a. a -> b -> a
139+
140+ flip :: forall c. forall b. forall a. (a -> b -> c) -> b -> a -> c
141+
142+ numAdd :: Prim.Number -> Prim.Number -> Prim.Number
143+
144+ numAnd :: Prim.Number -> Prim.Number -> Prim.Number
145+
146+ numComplement :: Prim.Number -> Prim.Number
147+
148+ numDiv :: Prim.Number -> Prim.Number -> Prim.Number
149+
150+ numGreater :: Prim.Number -> Prim.Number -> Prim.Boolean
151+
152+ numGreaterEq :: Prim.Number -> Prim.Number -> Prim.Boolean
153+
154+ numLess :: Prim.Number -> Prim.Number -> Prim.Boolean
155+
156+ numLessEq :: Prim.Number -> Prim.Number -> Prim.Boolean
157+
158+ numMod :: Prim.Number -> Prim.Number -> Prim.Number
159+
160+ numMul :: Prim.Number -> Prim.Number -> Prim.Number
161+
162+ numNegate :: Prim.Number -> Prim.Number
163+
164+ numOr :: Prim.Number -> Prim.Number -> Prim.Number
165+
166+ numShl :: Prim.Number -> Prim.Number -> Prim.Number
167+
168+ numShr :: Prim.Number -> Prim.Number -> Prim.Number
169+
170+ numSub :: Prim.Number -> Prim.Number -> Prim.Number
171+
172+ numXor :: Prim.Number -> Prim.Number -> Prim.Number
173+
174+ numZshr :: Prim.Number -> Prim.Number -> Prim.Number
175+
176+ readNumber :: Prim.String -> Prim.Number
177+
178+ refEq :: forall a. Ref a -> Ref a -> Prim.Boolean
179+
180+ refIneq :: forall a. Ref a -> Ref a -> Prim.Boolean
181+
182+ showNumber :: Prim.Number -> Prim.String
183+
184+ unsafeRefEq :: forall a. a -> a -> Prim.Boolean
185+
186+ unsafeRefIneq :: forall a. a -> a -> Prim.Boolean
187+
188+Module Monoid
189+-------------
190+
191+Types
192+~~~~~
193+
194+Type Classes
195+~~~~~~~~~~~~
196+
197+::
198+
199+ class Monoid m where
200+ mempty :: m
201+ (<>) :: m -> m -> m
202+
203+Type Class Instances
204+~~~~~~~~~~~~~~~~~~~~
205+
206+::
207+
208+ instance Monoid Prim.String
209+
210+ instance Monoid [a]
211+
212+Values
213+~~~~~~
214+
215+::
216+
217+ mconcat :: forall m. (Monoid (m)) => [m] -> m
218+
219+Module Monad
220+------------
221+
222+Types
223+~~~~~
224+
225+Type Classes
226+~~~~~~~~~~~~
227+
228+Type Class Instances
229+~~~~~~~~~~~~~~~~~~~~
230+
231+Values
232+~~~~~~
233+
234+::
235+
236+ (<=<) :: forall c. forall b. forall a. forall m. (Monad (m)) => (b -> m c) -> (a -> m b) -> a -> m c
237+
238+ (>=>) :: forall c. forall b. forall a. forall m. (Monad (m)) => (a -> m b) -> (b -> m c) -> a -> m c
239+
240+ foldM :: forall b. forall a. forall m. (Monad (m)) => (a -> b -> m a) -> a -> [b] -> m a
241+
242+ join :: forall a. forall m. (Monad (m)) => m (m a) -> m a
243+
244+ mapM :: forall b. forall a. forall m. (Monad (m)) => (a -> m b) -> [a] -> m [b]
245+
246+ replicateM :: forall a. forall m. (Monad (m)) => Prim.Number -> m a -> m [a]
247+
248+ sequence :: forall a. forall m. (Monad (m)) => [m a] -> m [a]
249+
250+ when :: forall m. (Monad (m)) => Prim.Boolean -> m { } -> m { }
251+
252+Module Maybe
253+------------
254+
255+Types
256+~~~~~
257+
258+::
259+
260+ data Maybe a where
261+ Nothing :: Maybe a
262+ Just :: a -> Maybe a
263+
264+Type Classes
265+~~~~~~~~~~~~
266+
267+Type Class Instances
268+~~~~~~~~~~~~~~~~~~~~
269+
270+::
271+
272+ instance Prelude.Applicative Maybe
273+
274+ instance Prelude.Functor Maybe
275+
276+ instance Prelude.Monad Maybe
277+
278+ (Show (a)) => instance Prelude.Show Maybe a
279+
280+Values
281+~~~~~~
282+
283+::
284+
285+ fromMaybe :: forall a. a -> Maybe a -> a
286+
287+ maybe :: forall b. forall a. b -> (a -> b) -> Maybe a -> b
288+
289+Module Either
290+-------------
291+
292+Types
293+~~~~~
294+
295+::
296+
297+ data Either a b where
298+ Left :: a -> Either a b
299+ Right :: b -> Either a b
300+
301+Type Classes
302+~~~~~~~~~~~~
303+
304+Type Class Instances
305+~~~~~~~~~~~~~~~~~~~~
306+
307+::
308+
309+ instance Prelude.Applicative Either e
310+
311+ instance Prelude.Functor Either a
312+
313+ instance Prelude.Monad Either e
314+
315+ (Show (a),Show (b)) => instance Prelude.Show Either a b
316+
317+Values
318+~~~~~~
319+
320+::
321+
322+ either :: forall c. forall b. forall a. (a -> c) -> (b -> c) -> Either a b -> c
323+
324+Module Arrays
325+-------------
326+
327+Types
328+~~~~~
329+
330+Type Classes
331+~~~~~~~~~~~~
332+
333+Type Class Instances
334+~~~~~~~~~~~~~~~~~~~~
335+
336+::
337+
338+ instance Prelude.Alternative Prim.Array
339+
340+ instance Prelude.Functor Prim.Array
341+
342+ instance Prelude.Monad Prim.Array
343+
344+ (Prelude.Show (a)) => instance Prelude.Show [a]
345+
346+Values
347+~~~~~~
348+
349+::
350+
351+ (:) :: forall a. a -> [a] -> [a]
352+
353+ all :: forall a. (a -> Prim.Boolean) -> [a] -> Prim.Boolean
354+
355+ any :: forall a. (a -> Prim.Boolean) -> [a] -> Prim.Boolean
356+
357+ concat :: forall a. [a] -> [a] -> [a]
358+
359+ concatMap :: forall b. forall a. [a] -> (a -> [b]) -> [b]
360+
361+ filter :: forall a. (a -> Prim.Boolean) -> [a] -> [a]
362+
363+ foldl :: forall b. forall a. (a -> b -> b) -> b -> [a] -> b
364+
365+ foldr :: forall b. forall a. (a -> b -> a) -> a -> [b] -> a
366+
367+ head :: forall a. [a] -> a
368+
369+ headSafe :: forall a. [a] -> Maybe a
370+
371+ indexOf :: forall a. [a] -> a -> Prim.Number
372+
373+ isEmpty :: forall a. [a] -> Prim.Boolean
374+
375+ joinS :: [Prim.String] -> Prim.String
376+
377+ joinWith :: [Prim.String] -> Prim.String -> Prim.String
378+
379+ lastIndexOf :: forall a. [a] -> a -> Prim.Number
380+
381+ length :: forall a. [a] -> Prim.Number
382+
383+ map :: forall b. forall a. (a -> b) -> [a] -> [b]
384+
385+ push :: forall a. [a] -> a -> [a]
386+
387+ range :: Prim.Number -> Prim.Number -> [Prim.Number]
388+
389+ reverse :: forall a. [a] -> [a]
390+
391+ shift :: forall a. [a] -> [a]
392+
393+ singleton :: forall a. a -> [a]
394+
395+ slice :: forall a. Prim.Number -> Prim.Number -> [a] -> [a]
396+
397+ sort :: forall a. [a] -> [a]
398+
399+ splice :: forall a. Prim.Number -> Prim.Number -> [a] -> [a] -> [a]
400+
401+ tail :: forall a. [a] -> [a]
402+
403+ tailSafe :: forall a. [a] -> Maybe [a]
404+
405+ zipWith :: forall c. forall b. forall a. (a -> b -> c) -> [a] -> [b] -> [c]
406+
407+Module Tuples
408+-------------
409+
410+Types
411+~~~~~
412+
413+::
414+
415+ data Tuple a b where
416+ Tuple :: a -> b -> Tuple a b
417+
418+Type Classes
419+~~~~~~~~~~~~
420+
421+Type Class Instances
422+~~~~~~~~~~~~~~~~~~~~
423+
424+::
425+
426+ (Prelude.Show (a),Prelude.Show (b)) => instance Prelude.Show Tuple a b
427+
428+Values
429+~~~~~~
430+
431+::
432+
433+ curry :: forall c. forall b. forall a. (Tuple a b -> c) -> a -> b -> c
434+
435+ uncurry :: forall c. forall b. forall a. (a -> b -> c) -> Tuple a b -> c
436+
437+ unzip :: forall b. forall a. [Tuple a b] -> Tuple [a] [b]
438+
439+ zip :: forall b. forall a. [a] -> [b] -> [Tuple a b]
440+
441+Module String
442+-------------
443+
444+Types
445+~~~~~
446+
447+Type Classes
448+~~~~~~~~~~~~
449+
450+Type Class Instances
451+~~~~~~~~~~~~~~~~~~~~
452+
453+Values
454+~~~~~~
455+
456+::
457+
458+ charAt :: Prim.Number -> Prim.String -> Prim.String
459+
460+ indexOfS :: Prim.String -> Prim.String -> Prim.Number
461+
462+ lastIndexOfS :: Prim.String -> Prim.String -> Prim.Number
463+
464+ lengthS :: Prim.String -> Prim.Number
465+
466+ localeCompare :: Prim.String -> Prim.String -> Prim.Number
467+
468+ replace :: Prim.String -> Prim.String -> Prim.String -> Prim.String
469+
470+ sliceS :: Prim.Number -> Prim.Number -> Prim.String -> Prim.String
471+
472+ split :: Prim.String -> Prim.String -> [Prim.String]
473+
474+ substr :: Prim.Number -> Prim.Number -> Prim.String -> Prim.String
475+
476+ substring :: Prim.Number -> Prim.Number -> Prim.String -> Prim.String
477+
478+ toLower :: Prim.String -> Prim.String
479+
480+ toUpper :: Prim.String -> Prim.String
481+
482+ trim :: Prim.String -> Prim.String
483+
484+Module Regex
485+------------
486+
487+Types
488+~~~~~
489+
490+::
491+
492+ data Regex :: *
493+
494+Type Classes
495+~~~~~~~~~~~~
496+
497+Type Class Instances
498+~~~~~~~~~~~~~~~~~~~~
499+
500+Values
501+~~~~~~
502+
503+::
504+
505+ match :: Regex -> Prim.String -> [Prim.String]
506+
507+ regex :: Prim.String -> Prim.String -> Regex
508+
509+ replaceR :: Regex -> Prim.String -> Prim.String -> Prim.String
510+
511+ search :: Regex -> Prim.String -> Prim.Number
512+
513+ test :: Regex -> Prim.String -> Prim.Boolean
514+
515+Module Global
516+-------------
517+
518+Types
519+~~~~~
520+
521+Type Classes
522+~~~~~~~~~~~~
523+
524+Type Class Instances
525+~~~~~~~~~~~~~~~~~~~~
526+
527+Values
528+~~~~~~
529+
530+::
531+
532+ decodeURI :: Prim.String -> Prim.String
533+
534+ decodeURIComponent :: Prim.String -> Prim.String
535+
536+ encodeURI :: Prim.String -> Prim.String
537+
538+ encodeURIComponent :: Prim.String -> Prim.String
539+
540+ infinity :: Prim.Number
541+
542+ isFinite :: Prim.Number -> Prim.Boolean
543+
544+ isNaN :: Prim.Number -> Prim.Boolean
545+
546+ nan :: Prim.Number
547+
548+ parseFloat :: Prim.String -> Prim.Number
549+
550+ parseInt :: Prim.String -> Prim.Number
551+
552+ toExponential :: Prim.Number -> Prim.String
553+
554+ toFixed :: Prim.Number -> Prim.Number -> Prim.String
555+
556+ toPrecision :: Prim.Number -> Prim.Number -> Prim.String
557+
558+Module Math
559+-----------
560+
561+Types
562+~~~~~
563+
564+Type Classes
565+~~~~~~~~~~~~
566+
567+Type Class Instances
568+~~~~~~~~~~~~~~~~~~~~
569+
570+Values
571+~~~~~~
572+
573+::
574+
575+ abs :: Prim.Number -> Prim.Number
576+
577+ aceil :: Prim.Number -> Prim.Number
578+
579+ acos :: Prim.Number -> Prim.Number
580+
581+ asin :: Prim.Number -> Prim.Number
582+
583+ atan :: Prim.Number -> Prim.Number
584+
585+ atan2 :: Prim.Number -> Prim.Number -> Prim.Number
586+
587+ cos :: Prim.Number -> Prim.Number
588+
589+ exp :: Prim.Number -> Prim.Number
590+
591+ floor :: Prim.Number -> Prim.Number
592+
593+ log :: Prim.Number -> Prim.Number
594+
595+ max :: Prim.Number -> Prim.Number
596+
597+ min :: Prim.Number -> Prim.Number
598+
599+ pow :: Prim.Number -> Prim.Number
600+
601+ round :: Prim.Number -> Prim.Number
602+
603+ sin :: Prim.Number -> Prim.Number
604+
605+ sqrt :: Prim.Number -> Prim.Number
606+
607+ tan :: Prim.Number -> Prim.Number
608+
609+Module Eff
610+----------
611+
612+Types
613+~~~~~
614+
615+::
616+
617+ data Eff :: # ! -> * -> *
618+
619+ type Pure a = forall e. Eff e a
620+
621+Type Classes
622+~~~~~~~~~~~~
623+
624+Type Class Instances
625+~~~~~~~~~~~~~~~~~~~~
626+
627+::
628+
629+ instance Prelude.Monad Eff e
630+
631+Values
632+~~~~~~
633+
634+::
635+
636+ bindEff :: forall b. forall a. forall e. Eff e a -> (a -> Eff e b) -> Eff e b
637+
638+ forE :: forall e. Prim.Number -> Prim.Number -> (Prim.Number -> Eff e { }) -> Eff e { }
639+
640+ foreachE :: forall a. forall e. [a] -> (a -> Eff e { }) -> Eff e { }
641+
642+ retEff :: forall a. forall e. a -> Eff e a
643+
644+ runPure :: forall a. Pure a -> a
645+
646+ untilE :: forall e. Eff e Prim.Boolean -> Eff e { }
647+
648+ whileE :: forall e. Eff e Prim.Boolean -> Eff e { } -> Eff e { }
649+
650+Module Random
651+-------------
652+
653+Types
654+~~~~~
655+
656+::
657+
658+ data Random :: !
659+
660+Type Classes
661+~~~~~~~~~~~~
662+
663+Type Class Instances
664+~~~~~~~~~~~~~~~~~~~~
665+
666+Values
667+~~~~~~
668+
669+::
670+
671+ random :: forall e. Eff random :: Random | e Prim.Number
672+
673+Module Errors
674+-------------
675+
676+Types
677+~~~~~
678+
679+::
680+
681+ data Error :: * -> !
682+
683+Type Classes
684+~~~~~~~~~~~~
685+
686+Type Class Instances
687+~~~~~~~~~~~~~~~~~~~~
688+
689+Values
690+~~~~~~
691+
692+::
693+
694+ catchError :: forall a. forall r. forall e. (e -> Eff r a) -> Eff err :: Error e | r a -> Eff r a
695+
696+ throwError :: forall r. forall e. forall a. e -> Eff err :: Error e | r a
697+
698+Module IORef
699+------------
700+
701+Types
702+~~~~~
703+
704+::
705+
706+ data IORef :: * -> *
707+
708+ data Ref :: !
709+
710+Type Classes
711+~~~~~~~~~~~~
712+
713+Type Class Instances
714+~~~~~~~~~~~~~~~~~~~~
715+
716+Values
717+~~~~~~
718+
719+::
720+
721+ modifyIORef :: forall r. forall s. IORef s -> (s -> s) -> Eff ref :: Ref | r { }
722+
723+ newIORef :: forall r. forall s. s -> Eff ref :: Ref | r (IORef s)
724+
725+ readIORef :: forall r. forall s. IORef s -> Eff ref :: Ref | r s
726+
727+ unsafeRunIORef :: forall a. forall eff. Eff ref :: Ref | eff a -> Eff eff a
728+
729+ writeIORef :: forall r. forall s. IORef s -> s -> Eff ref :: Ref | r { }
730+
731+Module Trace
732+------------
733+
734+Types
735+~~~~~
736+
737+::
738+
739+ data Trace :: !
740+
741+Type Classes
742+~~~~~~~~~~~~
743+
744+Type Class Instances
745+~~~~~~~~~~~~~~~~~~~~
746+
747+Values
748+~~~~~~
749+
750+::
751+
752+ print :: forall r. forall a. (Prelude.Show (a)) => a -> Eff trace :: Trace | r { }
753+
754+ trace :: forall r. Prim.String -> Eff trace :: Trace | r { }
755+
756+Module ST
757+---------
758+
759+Types
760+~~~~~
761+
762+::
763+
764+ data ST :: * -> !
765+
766+ data STRef :: * -> * -> *
767+
768+Type Classes
769+~~~~~~~~~~~~
770+
771+Type Class Instances
772+~~~~~~~~~~~~~~~~~~~~
773+
774+Values
775+~~~~~~
776+
777+::
778+
779+ modifySTRef :: forall r. forall h. forall a. STRef h a -> (a -> a) -> Eff st :: ST h | r { }
780+
781+ newSTRef :: forall r. forall h. forall a. a -> Eff st :: ST h | r (STRef h a)
782+
783+ readSTRef :: forall r. forall h. forall a. STRef h a -> Eff st :: ST h | r a
784+
785+ runST :: forall r. forall a. forall h. Eff st :: ST h | r a -> Eff r a
786+
787+ writeSTRef :: forall r. forall h. forall a. STRef h a -> a -> Eff st :: ST h | r { }
788+
docs/source/syntax.rstnew file+222
@@ -0,0 +1,222 @@
1+Syntax
2+======
3+
4+Whitespace Rules
5+----------------
6+
7+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.
8+
9+That is, the following is valid::
10+
11+ foo = bar(x) +
12+ baz(x)
13+
14+But this is not::
15+
16+ foo = bar(x) +
17+ baz(x)
18+
19+Operators
20+---------
21+
22+PureScript supports the following unary operators (in precedence order):
23+
24+== =======================
25+ Meaning
26+== =======================
27+\- Numeric negation
28+! Boolean negation
29+~ Binary negation
30+\+ Unary plus (numeric)
31+== =======================
32+
33+and the following binary operators (in precedence order):
34+
35+==== =====================
36+ Meaning
37+==== =====================
38+\+ Numeric addition
39+\- Numeric subtraction
40+\* Numeric multiplication
41+/ Numeric division
42+% Numeric modulus
43+== Equality check
44+!= Inequality check
45+< Less than
46+<= Less than or equal
47+> Greater than
48+>= Greater than or equal
49+&& Boolean AND
50+|| Boolean OR
51+& Binary AND
52+\| Binary OR
53+^ Binary XOR
54+<< Shift Left
55+>> Shift Right
56+\>>> Zero-Fill Shift Right
57+++ String concatenation
58+==== =====================
59+
60+Literal Values
61+--------------
62+
63+Numeric literals can be integers or floating point numbers. Numbers in hexadecimal notation should be preceded by the characters ``0x``::
64+
65+ 16
66+ 16.0
67+ 0xF0
68+
69+String literals are enclosed in double-quotes and may extend over multiple lines. Line breaks should be surrounded by slashes as follows::
70+
71+ "Hello World"
72+
73+ "Hello \
74+ \World"
75+
76+The two boolean literals are ``true`` and ``false``.
77+
78+Array Literals
79+--------------
80+
81+Array literals are surrounded by square brackets, as in Javascript::
82+
83+ []
84+ [1, 2, 3]
85+
86+Record Literals
87+---------------
88+
89+Record literals are surrounded by braces, as in Javascript::
90+
91+ {}
92+ { foo: "Foo", bar: 1 }
93+
94+Array Indexing
95+--------------
96+
97+To retrieve the element of an array at an index, use the ``!!`` operator::
98+
99+ arr !! 0
100+
101+This example corresponds to the Javascript ``arr[0]``.
102+
103+Property Accessors
104+------------------
105+
106+To access a property of a record, use a dot, followed by the property name, as in Javascript::
107+
108+ rec.propertyName
109+
110+Functions
111+---------
112+
113+Functions are introduced by using a backslash followed by a list of argument names::
114+
115+ example1 = \a b -> a + b
116+
117+which would correspond to the following Javascript::
118+
119+ function example1(a) {
120+ return function (b) {
121+ return a + b;
122+ }
123+ }
124+
125+Function application is indicated by just the juxtaposition of a function with its arugments::
126+
127+ example1 10 20
128+
129+Functions can also be defined at the top level by providing a list of patterns and an optional guard on the left hand side of the equals sign::
130+
131+ f [] [] = []
132+ f (x:xs) (y:ys) = x + y : f xs ys
133+
134+If-Then-Else Expressions
135+------------------------
136+
137+The ``if``, ``then`` and ``else`` keywords can be used to create conditional expressions. In this case, the ``else`` block is always required.
138+
139+For example::
140+
141+ conditional = if 2 > 1 then "ok" else "oops"
142+
143+Do Notation
144+-----------
145+
146+The `do` keyword introduces simple syntactic sugar for monadic expressions.
147+
148+Here is an example, using the maybe monad::
149+
150+ data Maybe a = Nothing | Just a
151+
152+ instance Monad Maybe where
153+ ret = Just
154+ (>>=) Nothing _ = Nothing
155+ (>>=) (Just a) f = f a
156+
157+ isEven n | n % 2 == 0 = Just {}
158+ isEven _ = Nothing
159+
160+ evenSum a b = do
161+ n <- a
162+ m <- b
163+ let sum = n + m
164+ isEven sum
165+ ret sum
166+
167+``isEven`` adds two values of type ``Maybe Number`` and returns their sum, if the sum is even. If the sum is odd, ``evenSum`` returns ``Nothing``.
168+
169+When using `do` notation, the corresponding type constructor must be an instance of the `Prelude.Monad` type class, which defines the ``ret`` and ``>>=`` functions.
170+
171+Statements can have the following form:
172+
173+- ``a <- x`` which desugars to ``m.bind x (\a -> ...)` `
174+- ``let a = x`` which desugars to ``(\a -> ...)(x)``
175+- ``x`` which desugars to ``m.bind x (\_ -> ...)`` or just ``x`` if this is the last statement.
176+
177+Binders can be used on the left hand side of ``<-`` or ``=``. For example::
178+
179+ test arr = do
180+ (x:y:_) <- arr
181+ ret (x + y)
182+
183+A pattern match failure will generate a runtime exception, just as in the case of a regular ``case`` statement.
184+
185+Operators
186+---------
187+
188+In addition to the standard operators, user-defined infix operators can be created by enclosing names in parentheses.
189+
190+E.g. to create a synonym for string concatenation::
191+
192+ (<>) = \s1 s2 -> s1 ++ s2
193+
194+ greeting = "Hello" <> "World!"
195+
196+Regular functions can be used as operators by enclosing their names in backticks::
197+
198+ foo = \x y -> x * y + y
199+
200+ test = 10 `foo` 20
201+
202+Fixity declarations can associate a precedence level, which is a natural number, to a user-defined operator, and specify which way it associates::
203+
204+ infixl 5 <>
205+ infixr 7 %%
206+
207+Record Updates
208+--------------
209+
210+Properties on records can be updated using the following syntax::
211+
212+ o { key = value, ..., key = value }
213+
214+For example, the following function increments the ``foo`` property on its argument::
215+
216+ incr o = o { foo = o.foo + 1 }
217+
218+The generated Javascript assumes the existence of a method called ``Object.extend`` such that ``Object.extend(o, p)`` takes an object ``o`` and generates a shallow copy of ``o`` including the properties of ``p``. A simple JQuery implementation of this specification is::
219+
220+ Object.prototype.extend = function(o, p) {
221+ return $.extend({}, o, p);
222+ };
docs/source/typeclasses.rstnew file+26
@@ -0,0 +1,26 @@
1+Type Classes
2+============
3+
4+PureScript has basic support for type classes via the `class` and `instance` keywords.
5+
6+Type class instances must be of the form `String`, `Number`, `Boolean`, `[t]` or `C t1 ... tn`, and only a single type class parameter is supported.
7+
8+Type class instances are resolved based on the order in which they appeared in the source files. In particular, overlapping instances are permitted.
9+
10+Here is an example of the `Show` typeclass, with instances for Strings, Booleans and arrays::
11+
12+ class Show a where
13+ show :: a -> String
14+
15+ instance Show String where
16+ show s = s
17+
18+ instance Show Boolean where
19+ show true = "true"
20+ show false = "false"
21+
22+ instance (Show a) => Show [a] where
23+ show [] = "[]"
24+ show (x:xs) = show x ++ " : " ++ showArray xs
25+
26+ example = show [true, false]
docs/source/types.rstnew file+159
@@ -0,0 +1,159 @@
1+Types
2+=====
3+
4+The type system defines the following types:
5+
6+- Primitive Types: Number, String, Boolean
7+- Arrays
8+- Records
9+- Tagged Unions
10+- Functions
11+- Polymorphic Types
12+- Constrained Types
13+- Type Synonyms
14+- Rows
15+
16+Primitive Types
17+---------------
18+
19+The three primitive types ``String``, ``Number`` and ``Boolean`` correspond to their Javascript equivalents at runtime.
20+
21+Arrays
22+------
23+
24+PureScript arrays correspond to Javascript arrays at runtime, but all elements in an array must have the same type.
25+
26+Records
27+-------
28+
29+PureScript records correspond to Javascript objects. They may have zero or more named fields, each with their own types.
30+
31+Tagged Unions
32+-------------
33+
34+Tagged unions consist of one or more constructors, each of which takes zero or more arguments.
35+
36+Tagged unions can only be created using their constructors, and deconstructed through pattern matching (see later).
37+
38+For example::
39+
40+ data Foo a = Foo | Bar String
41+
42+ runFoo Foo = "It's a Foo"
43+ runFoo (Bar s) = "It's a Bar. The string is " ++ s
44+
45+ test = runFoo Foo ++ runFoo (Bar "Test")
46+
47+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.
48+
49+``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.
50+
51+Functions
52+---------
53+
54+Functions in PureScript are like their Javascript counterparts, but always have exactly one argument.
55+
56+Polymorphic Types
57+-----------------
58+
59+Expressions defined at the top level may have polymorphic types.
60+
61+Here is an example::
62+
63+ identity x = x
64+
65+`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.
66+
67+A type annotation can also be provided::
68+
69+ identity :: forall a. a -> a
70+ identity x = x
71+
72+Row Polymorphism
73+----------------
74+
75+Polymorphism is not limited to abstracting over types. Values may also be polymorphic in types with other kinds, such as rows or effects (see "Kind System").
76+
77+For example, the following function accesses two properties on a record::
78+
79+ addProps o = o.foo + o.bar
80+
81+The inferred type of `addProps` is
82+
83+::
84+ forall r. { foo :: Number, bar :: Number | r } -> Number
85+
86+Here, the type variable ``r`` has kind ``# *`` - it represents a `row` of `types`. It can be instantiated with any row of named types.
87+
88+In other words, ``addProps`` accepts any record which has properties ``Foo`` and ``Bar``, and *any other record properties*.
89+
90+Therefore, the following application compiles::
91+
92+ addProps { foo: 1, bar: 2, baz: 3 }
93+
94+even though the type of ``addProps`` does not mention the property ``baz``. However, the following does not compile::
95+
96+ addProps { foo: 1 }
97+
98+since the `bar` property is missing.
99+
100+Rank N Types
101+------------
102+
103+It is also possible for the ``forall`` quantifier to appear on the left of a function arrow, inside types record fields and data constructors, and in type synonyms.
104+
105+In most cases, a type annotation is necessary when using this feature.
106+
107+As an example, we can pass a polymorphic function as an argument to another function::
108+
109+ poly :: (forall a. a -> a) -> Boolean
110+ poly f = (f 0 < 1) == f true
111+
112+Notice that the polymorphic function's type argument is instantiated to both `Number` and `Boolean`.
113+
114+An argument to ``poly`` must indeed be polymorphic. For example, the following fails::
115+
116+ test = poly (\n -> n + 1)
117+
118+since the skolemized type variable ``a`` does not unify with ``Number``.
119+
120+Rows
121+----
122+
123+A row of types represents an unordered collection of named types without duplicates.
124+
125+Rows have kind ``# k`` for some kind ``k``, and so values do not have types which are rows. Rather, rows can be used in type signatures to define record types or other type where labelled, unordered types are useful.
126+
127+To denote a closed row, separate the fields with commas, with each label separated from its type with a double colon::
128+
129+ (name :: String, age :: Number)
130+
131+It may be necessary, depending on the context, to surround a row in parentheses.
132+
133+To denote an open row (i.e. one which may unify with another row to add new fields), separate the specified terms from a row variable by a pipe::
134+
135+ (name :: String, age :: Number | r)
136+
137+Type Synonyms
138+-------------
139+
140+For convenience, it is possible to declare a synonym for a type using the ``type`` keyword. Type synonyms can include type arguments.
141+
142+For example::
143+
144+ type Foo = { foo :: Number, bar Number }
145+
146+ addFoo :: Foo -> Number
147+ addFoo = \o -> o.foo + o.bar
148+
149+Constrained Types
150+-----------------
151+
152+Polymorphic types may be predicated on one or more ``constraints``. See the chapter on type classes for more information.
153+
154+Type Annotations
155+----------------
156+
157+Most types can be inferred (not including Rank N Types and constrained types), but annotations can optionally be provided using a double-colon::
158+
159+ one = 1 :: Number
examples/.gitignorenew file+1
@@ -0,0 +1 @@
1+shelltest/tests
examples/failing/Arrays.pursnew file+5
@@ -0,0 +1,5 @@
1+module Arrays where
2+
3+ import Prelude
4+
5+ test = \arr -> arr !! (0 !! 0)
examples/failing/Do.pursnew file+8
@@ -0,0 +1,8 @@
1+module Do where
2+
3+test1 = do let x = 1
4+
5+test2 y = do x <- y
6+
7+test3 = do return 1
8+ return 2
examples/failing/Import.pursnew file+3
@@ -0,0 +1,3 @@
1+module Module where
2+
3+ import UndefinedModule
examples/failing/KindError.pursnew file+3
@@ -0,0 +1,3 @@
1+module KindError where
2+
3+ data KindError f a = One f | Two (f a)
examples/failing/LocalVars.pursnew file+8
@@ -0,0 +1,8 @@
1+module LocalVars where
2+
3+ import Prelude
4+
5+ bad = \x -> {
6+ x = x + 1;
7+ return x;
8+ }
examples/failing/ModuleDeps.pursnew file+7
@@ -0,0 +1,7 @@
1+module M1 where
2+
3+import M2
4+
5+module M2 where
6+
7+import M1
examples/failing/MutRec.pursnew file+5
@@ -0,0 +1,5 @@
1+module MutRec where
2+
3+x = y
4+
5+y = x
examples/failing/MutRec2.pursnew file+3
@@ -0,0 +1,3 @@
1+module MutRec2 where
2+
3+x = x
examples/failing/NullaryAbs.pursnew file+3
@@ -0,0 +1,3 @@
1+module NullaryAbs where
2+
3+ func = \ -> "no"
examples/failing/Object.pursnew file+5
@@ -0,0 +1,5 @@
1+module Object where
2+
3+test o = o.foo
4+
5+test1 = test {}
examples/failing/PatternScope.pursnew file+12
@@ -0,0 +1,12 @@
1+module PatternScope where
2+
3+ import Prelude
4+
5+ -- Pattern scope doesn't leak
6+ foobar = \x -> {
7+ var y = case x of
8+ z | z % 2 == 0 -> 1
9+ _ -> 2;
10+ return z;
11+ }
12+
examples/failing/Rank2Types.pursnew file+7
@@ -0,0 +1,7 @@
1+module Rank2Types where
2+
3+ import Prelude
4+
5+ foreign import test :: (forall a. a -> a) -> Number
6+
7+ test1 = test (\n -> n + 1)
examples/failing/ReadShow.pursnew file+7
@@ -0,0 +1,7 @@
1+module ReadShow where
2+
3+ foreign import read :: forall a. String -> a
4+
5+ foreign import show :: forall a. a -> String
6+
7+ test = \x -> show (read x)
examples/failing/Reserved.pursnew file+4
@@ -0,0 +1,4 @@
1+module Reserved where
2+
3+(<) :: Number -> Number -> Number
4+(<) a b = !(a >= b)
examples/failing/Shadowed.pursnew file+14
@@ -0,0 +1,14 @@
1+module Shadowed where
2+
3+import Prelude
4+
5+a = [1, 2]
6+
7+foo = {
8+ var x = a !! 0;
9+ var a = 0;
10+
11+ a = a + 1;
12+
13+ return x + a;
14+ }
examples/failing/SkolemEscape.pursnew file+5
@@ -0,0 +1,5 @@
1+module SkolemEscape where
2+
3+ foreign import foo :: (forall a. a -> a) -> Number
4+
5+ test = \x -> foo x
examples/failing/SkolemEscape2.pursnew file+9
@@ -0,0 +1,9 @@
1+module SkolemEscape where
2+
3+import Prelude
4+import Eff
5+import ST
6+
7+test _ = do
8+ r <- runST (newSTRef 0)
9+ return 0
examples/failing/TypeClassInstances.pursnew file+8
@@ -0,0 +1,8 @@
1+module TypeClassInstances where
2+
3+class A a where
4+ a :: a -> String
5+ b :: a -> Number
6+
7+instance A String where
8+ a s = s
examples/failing/TypeClasses.pursnew file+7
@@ -0,0 +1,7 @@
1+module TypeClasses where
2+
3+class Show a where
4+ show :: a -> String
5+
6+instance TypeClasses.Show ([[String]]) where
7+ show _ = "array"
examples/failing/TypeClasses2.pursnew file+15
@@ -0,0 +1,15 @@
1+module TC1 where
2+
3+class Show a where
4+ show :: a -> String
5+
6+module TC2 where
7+
8+instance TC1.Show String where
9+ show s = s
10+
11+module TC3 where
12+
13+import TC1
14+
15+test = show "testing"
examples/failing/TypeError.pursnew file+5
@@ -0,0 +1,5 @@
1+module TypeError where
2+
3+ import Prelude
4+
5+ test = 1 ++ "A"
examples/failing/TypeSynonyms.pursnew file+5
@@ -0,0 +1,5 @@
1+module TypeSynonyms where
2+
3+type T1 = [T2]
4+
5+type T2 = T1
examples/failing/TypeSynonyms2.pursnew file+9
@@ -0,0 +1,9 @@
1+module TypeSynonyms2 where
2+
3+class Foo a where
4+ foo :: a -> String
5+
6+type Bar = String
7+
8+instance Foo Bar where
9+ foo s = s
examples/failing/TypeSynonyms3.pursnew file+13
@@ -0,0 +1,13 @@
1+module TypeSynonyms2 where
2+
3+class Foo a where
4+ foo :: a -> String
5+
6+type Bar = String
7+
8+module M where
9+
10+import TypeSynonyms2
11+
12+instance TypeSynonyms2.Foo Bar where
13+ foo s = s
examples/passing/Applicative.pursnew file+16
@@ -0,0 +1,16 @@
1+module Applicative where
2+
3+class Applicative f where
4+ pure :: forall a. a -> f a
5+ (<*>) :: forall a b. f (a -> b) -> f a -> f b
6+
7+data Maybe a = Nothing | Just a
8+
9+instance Applicative Maybe where
10+ pure = Just
11+ (<*>) (Just f) (Just a) = Just (f a)
12+ (<*>) _ _ = Nothing
13+
14+module Main where
15+
16+main = Trace.trace "Done"
examples/passing/ArrayType.pursnew file+17
@@ -0,0 +1,17 @@
1+module ArrayType where
2+
3+test :: [] Number
4+test = [1, 2, 3]
5+
6+class Functor f where
7+ fmap :: forall a b. (a -> b) -> f a -> f b
8+
9+foreign import (:) :: forall a. a -> [a] -> [a]
10+
11+instance Functor [] where
12+ fmap _ [] = []
13+ fmap f (x:xs) = f x : fmap f xs
14+
15+module Main where
16+
17+main = Trace.trace "Done"
examples/passing/Arrays.pursnew file+34
@@ -0,0 +1,34 @@
1+module ArraysTests where
2+
3+import Prelude
4+
5+test1 arr = arr !! 0 + arr !! 1 + 1
6+
7+test2 = \arr -> case arr of
8+ [x, y] -> x + y
9+ [x] -> x
10+ [] -> 0
11+ (x : y : _) -> x + y
12+
13+data Tree = One Number | Some [Tree]
14+
15+test3 = \tree sum -> case tree of
16+ One n -> n
17+ Some (n1 : n2 : rest) -> test3 n1 sum * 10 + test3 n2 sum * 5 + sum rest
18+
19+test4 = \arr -> case arr of
20+ [] -> 0
21+ [_] -> 0
22+ x : y : xs -> x * y + test4 xs
23+
24+module Main where
25+
26+import Arrays
27+import Prelude
28+
29+main = do
30+ let x = [3,2,1]
31+ let y = sort x
32+ if x == [3,2,1]
33+ then Trace.trace "Done"
34+ else Errors.throwError "Not done"
examples/passing/Auto.pursnew file+15
@@ -0,0 +1,15 @@
1+module Auto where
2+
3+ data Auto s i o = Auto { state :: s, step :: s -> i -> o }
4+
5+ type SomeAuto i o = forall r. (forall s. Auto s i o -> r) -> r
6+
7+ exists :: forall s i o. s -> (s -> i -> o) -> SomeAuto i o
8+ exists = \state step f -> f (Auto { state: state, step: step })
9+
10+ run :: forall i o. SomeAuto i o -> i -> o
11+ run = \s i -> s (\a -> case a of Auto a -> a.step a.state i)
12+
13+module Main where
14+
15+main = Trace.trace "Done"
examples/passing/Church.pursnew file+18
@@ -0,0 +1,18 @@
1+module Church where
2+
3+ type List a = forall r. r -> (a -> r -> r) -> r
4+
5+ empty :: forall a. List a
6+ empty = \r f -> r
7+
8+ cons :: forall a. a -> List a -> List a
9+ cons = \a l r f -> f a (l r f)
10+
11+ append :: forall a. List a -> List a -> List a
12+ append = \l1 l2 r f -> l2 (l1 r f) f
13+
14+ test = append (cons 1 empty) (cons 2 empty)
15+
16+module Main where
17+
18+main = Trace.trace "Done"
examples/passing/Collatz.pursnew file+18
@@ -0,0 +1,18 @@
1+module Main where
2+
3+import Prelude
4+import Eff
5+import ST
6+
7+collatz :: Number -> Number
8+collatz n = runPure (runST (do
9+ r <- newSTRef n
10+ count <- newSTRef 0
11+ untilE $ do
12+ modifySTRef count $ (+) 1
13+ m <- readSTRef r
14+ writeSTRef r $ if m % 2 == 0 then m / 2 else 3 * m + 1
15+ return $ m == 1
16+ readSTRef count))
17+
18+main = Trace.print $ collatz 1
examples/passing/Conditional.pursnew file+9
@@ -0,0 +1,9 @@
1+module Conditional where
2+
3+ fns = \f -> if f true then f else \x -> x
4+
5+ not = \x -> if x then false else true
6+
7+module Main where
8+
9+main = Trace.trace "Done"
examples/passing/Cons.pursnew file+12
@@ -0,0 +1,12 @@
1+module Cons where
2+
3+ import Prelude
4+ import Arrays
5+
6+ test1 = \xs -> 1 : xs
7+
8+ test2 = 1 : 2 : 3 : []
9+
10+module Main where
11+
12+main = Trace.trace "Done"
examples/passing/Console.pursnew file+13
@@ -0,0 +1,13 @@
1+module Main where
2+
3+import Prelude
4+import Eff
5+import Trace
6+
7+replicateM_ :: forall m a. (Monad m) => Number -> m a -> m {}
8+replicateM_ 0 _ = return {}
9+replicateM_ n act = do
10+ act
11+ replicateM_ (n - 1) act
12+
13+main = replicateM_ 10 (trace "Hello World!")
examples/passing/DataAndType.pursnew file+9
@@ -0,0 +1,9 @@
1+module DataAndType where
2+
3+data A = A B
4+
5+type B = A
6+
7+module Main where
8+
9+main = Trace.trace "Done"
examples/passing/DataImport.pursnew file+13
@@ -0,0 +1,13 @@
1+module M1 where
2+
3+data Test = Test String
4+
5+module Main where
6+
7+import M1
8+
9+unTest (Test s) = s
10+
11+main = do
12+ let x = unTest (Test "Done")
13+ Trace.trace x
examples/passing/Do.pursnew file+49
@@ -0,0 +1,49 @@
1+module Do where
2+
3+import Prelude
4+
5+data Maybe a = Nothing | Just a
6+
7+instance Prelude.Monad Maybe where
8+ return = Just
9+ (>>=) Nothing _ = Nothing
10+ (>>=) (Just a) f = f a
11+
12+test1 = \_ -> do
13+ Just "abc"
14+
15+test2 = \_ -> do
16+ (x : _) <- Just [1, 2, 3]
17+ (y : _) <- Just [4, 5, 6]
18+ Just (x + y)
19+
20+test3 = \_ -> do
21+ Just 1
22+ Nothing :: Maybe Number
23+ Just 2
24+
25+test4 mx my = do
26+ x <- mx
27+ y <- my
28+ Just (x + y + 1)
29+
30+test5 mx my mz = do
31+ x <- mx
32+ y <- my
33+ let sum = x + y
34+ z <- mz
35+ Just (z + sum + 1)
36+
37+test6 mx = \_ -> do
38+ let Just x = mx
39+ Just x
40+
41+test8 = \_ -> do
42+ Just (do
43+ Just 1)
44+
45+test9 = \_ -> (+) <$> Just 1 <*> Just 2
46+
47+module Main where
48+
49+main = Trace.trace "Done"
examples/passing/Dollar.pursnew file+16
@@ -0,0 +1,16 @@
1+module Dollar where
2+
3+($) :: forall a b. (a -> b) -> a -> b
4+($) f x = f x
5+
6+infixr 1000 $
7+
8+id x = x
9+
10+test1 x = id $ id $ id $ id $ x
11+
12+test2 x = id id $ id x
13+
14+module Main where
15+
16+main = Trace.trace "Done"
examples/passing/DottedModules.pursnew file+20
@@ -0,0 +1,20 @@
1+module Some.Module.Name where
2+
3+ class Foo a where
4+ foo :: a -> a
5+
6+ data Text = Text String
7+
8+ x = Text "Done"
9+
10+module Main where
11+
12+ import Prelude
13+ import Some.Module.Name
14+
15+ instance Some.Module.Name.Foo String where
16+ foo s = s
17+
18+ unwrap (Text x) = x
19+
20+ main = Trace.print $ foo $ unwrap x
examples/passing/Eff.pursnew file+27
@@ -0,0 +1,27 @@
1+module TestEff where
2+
3+import Prelude
4+import Eff
5+import ST
6+import Errors
7+import Trace
8+
9+test1 = catchError (\s -> return 0) $ do
10+ trace "Testing"
11+ throwError "Error!"
12+
13+test2 = runPure (runST (do
14+ ref <- newSTRef 0
15+ modifySTRef ref $ \n -> n + 1
16+ readSTRef ref))
17+
18+module Main where
19+
20+import Prelude
21+import Eff
22+import TestEff
23+
24+main = do
25+ n <- test1
26+ Trace.print n
27+ Trace.print test2
examples/passing/ExternData.pursnew file+19
@@ -0,0 +1,19 @@
1+module ExternData where
2+
3+ foreign import data IO :: * -> *
4+
5+ foreign import fmap :: forall a b. IO a -> (a -> b) -> IO b
6+
7+ foreign import return :: forall a. a -> IO a
8+
9+ foreign import bind :: forall a b. IO a -> (a -> IO b) -> IO b
10+
11+ foreign import showMessage :: String -> IO { }
12+
13+ foreign import prompt :: IO String
14+
15+ main = \_ -> prompt `bind` \s -> showMessage s
16+
17+module Main where
18+
19+main = Trace.trace "Done"
examples/passing/ExternRaw.pursnew file+15
@@ -0,0 +1,15 @@
1+module ExternRaw where
2+
3+foreign import first "function first(xs) { return xs[0]; }" :: forall a. [a] -> a
4+
5+foreign import loop "function loop() { while (true) {} }" :: forall a. a
6+
7+foreign import concat "function concat(xs) { \
8+ \ return function(ys) { \
9+ \ return xs.concat(ys); \
10+ \ };\
11+ \}" :: forall a. [a] -> [a] -> [a]
12+
13+module Main where
14+
15+main = Trace.trace "Done"
examples/passing/FFI.pursnew file+16
@@ -0,0 +1,16 @@
1+module FFI where
2+
3+foreign import foo :: String -> String
4+
5+bar :: String -> String
6+bar _ = foo "test"
7+
8+module FFIModuleTest where
9+
10+import FFI
11+
12+baz _ = foo "test"
13+
14+module Main where
15+
16+main = Trace.trace "Done"
examples/passing/FunctionScope.pursnew file+17
@@ -0,0 +1,17 @@
1+module FunctionScope where
2+
3+ import Prelude
4+
5+ mkValue :: Number -> Number
6+ mkValue id = id
7+
8+module Main where
9+
10+ import Prelude
11+ import FunctionScope
12+
13+ main = do
14+ let value = mkValue 1
15+ if value == 1
16+ then Trace.trace "Done"
17+ else Errors.throwError "Not done"
examples/passing/Functions.pursnew file+17
@@ -0,0 +1,17 @@
1+module Functions where
2+
3+ import Prelude
4+
5+ test1 = \_ -> 0
6+
7+ test2 = \a b -> a + b + 1
8+
9+ test3 = \a -> a
10+
11+ test4 = \(%%) -> 1 %% 2
12+
13+ test5 = \(+++) (***) -> 1 +++ 2 *** 3
14+
15+module Main where
16+
17+main = Trace.trace "Done"
examples/passing/Functions2.pursnew file+17
@@ -0,0 +1,17 @@
1+module Functions2 where
2+
3+ import Prelude
4+
5+ test :: forall a b. a -> b -> a
6+ test = \const _ -> const
7+
8+module Main where
9+
10+ import Prelude
11+ import Functions2
12+
13+ main = do
14+ let value = test "Done" {}
15+ if value == "Done"
16+ then Trace.trace "Done"
17+ else Errors.throwError "Not done"
examples/passing/Guards.pursnew file+16
@@ -0,0 +1,16 @@
1+module Guards where
2+
3+ import Prelude
4+
5+ collatz = \x -> case x of
6+ y | y % 2 == 0 -> y / 2
7+ y -> y * 3 + 1
8+
9+ -- Guards have access to current scope
10+ collatz2 = \x y -> case x of
11+ z | y > 0 -> z / 2
12+ z -> z * 3 + 1
13+
14+module Main where
15+
16+main = Trace.trace "Done"
examples/passing/Import.pursnew file+16
@@ -0,0 +1,16 @@
1+module M1 where
2+
3+ id :: forall a. a -> a
4+ id = \x -> x
5+
6+ foo = id
7+
8+module M2 where
9+
10+ import M1
11+
12+ main = \_ -> foo 42
13+
14+module Main where
15+
16+main = Trace.trace "Done"
examples/passing/InferRecFunWithConstrainedArgument.pursnew file+8
@@ -0,0 +1,8 @@
1+module Main where
2+
3+import Prelude
4+
5+test 100 = 100
6+test n = test(1 + n)
7+
8+main = Trace.print $ test 0
examples/passing/JSReserved.pursnew file+21
@@ -0,0 +1,21 @@
1+module JSReserved where
2+
3+ import Prelude
4+
5+ yield = 0
6+ member = 1
7+
8+ public = \return -> return
9+
10+ this catch = catch
11+
12+module Main where
13+
14+ import Prelude
15+ import Arrays
16+ import JSReserved
17+
18+ main = Trace.print [ yield
19+ , member
20+ , this 1
21+ , public 1 ]
examples/passing/Let.pursnew file+18
@@ -0,0 +1,18 @@
1+module Main where
2+
3+import Prelude
4+import Eff
5+
6+test1 x = let y = x + 1 in y
7+
8+test2 x y =
9+ let x' = x + 1 in
10+ let y' = y + 1 in
11+ x' + y'
12+
13+test3 x = let 1 = x in 2
14+
15+main = do
16+ Trace.print (test1 1)
17+ Trace.print (test2 1 2)
18+ Trace.print (test3 1)
examples/passing/List.pursnew file+10
@@ -0,0 +1,10 @@
1+module Main where
2+
3+import Prelude
4+import Eff
5+import Arrays
6+import Global
7+
8+main = do
9+ let test1 = concat [1, 2, 3] [4, 5, 6]
10+ Trace.print test1
examples/passing/Match.pursnew file+9
@@ -0,0 +1,9 @@
1+module Match where
2+
3+ data Foo a = Foo
4+
5+ foo = \f -> case f of Foo -> "foo"
6+
7+module Main where
8+
9+main = Trace.trace "Done"
examples/passing/Math.pursnew file+10
@@ -0,0 +1,10 @@
1+module Main where
2+
3+ import Prelude
4+ import Trace
5+ import Eff
6+
7+ main = do
8+ print $ Math.sin 0
9+ print $ Math.sin $ Math.pi * 0.5
10+ print $ Math.e / Math.ln2
examples/passing/Maybe.pursnew file+12
@@ -0,0 +1,12 @@
1+module Main where
2+
3+import Prelude
4+import Maybe
5+import Global
6+
7+main = do
8+ let test1 = fromMaybe 0 $ do
9+ a <- Just 1
10+ b <- Just 2
11+ return (a + b)
12+ Trace.print test1
examples/passing/Module.pursnew file+28
@@ -0,0 +1,28 @@
1+module M1 where
2+
3+ import Prelude
4+
5+ data Foo = Foo String
6+
7+ foo :: M1.Foo -> String
8+ foo = \f -> case f of Foo s -> s ++ "foo"
9+
10+ bar :: Foo -> String
11+ bar = foo
12+
13+ incr :: Number -> Number
14+ incr x = x + 1
15+
16+module M2 where
17+
18+ import Prelude
19+
20+ baz :: M1.Foo -> String
21+ baz = M1.foo
22+
23+ match :: M1.Foo -> String
24+ match = \f -> case f of M1.Foo s -> s ++ "foo"
25+
26+module Main where
27+
28+main = Trace.trace "Done"
examples/passing/ModuleDeps.pursnew file+17
@@ -0,0 +1,17 @@
1+module M1 where
2+
3+import M2
4+
5+foo = M3.baz
6+
7+module M2 where
8+
9+bar = M3.baz
10+
11+module M3 where
12+
13+baz = 1
14+
15+module Main where
16+
17+main = Trace.trace "Done"
examples/passing/Monad.pursnew file+32
@@ -0,0 +1,32 @@
1+module MonadTest where
2+
3+ type Monad m = { return :: forall a. a -> m a
4+ , bind :: forall a b. m a -> (a -> m b) -> m b }
5+
6+ data Id a = Id a
7+
8+ id :: Monad Id
9+ id = { return : Id
10+ , bind : \ma f -> case ma of Id a -> f a }
11+
12+ data Maybe a = Nothing | Just a
13+
14+ maybe :: Monad Maybe
15+ maybe = { return : Just
16+ , bind : \ma f -> case ma of
17+ Nothing -> Nothing
18+ Just a -> f a
19+ }
20+
21+ test :: forall m. Monad m -> m Number
22+ test = \m -> m.bind (m.return 1) (\n1 ->
23+ m.bind (m.return "Test") (\n2 ->
24+ m.return n1))
25+
26+ test1 = test id
27+
28+ test2 = test maybe
29+
30+module Main where
31+
32+main = Trace.trace "Done"
examples/passing/MultipleConstructorArgs.pursnew file+28
@@ -0,0 +1,28 @@
1+module MultipleConstructorArgs where
2+
3+import Arrays
4+
5+data P a b = P a b
6+
7+runP :: forall a b r. (a -> b -> r) -> P a b -> r
8+runP f (P a b) = f a b
9+
10+idP = runP P
11+
12+testCase = \p -> case p of
13+ P (x:xs) (y:ys) -> x : y : testCase (P xs ys)
14+ P _ _ -> []
15+
16+test1 = testCase (P [1, 2, 3] [4, 5, 6])
17+
18+module Main where
19+
20+import Prelude
21+import MultipleConstructorArgs
22+import Global
23+import Eff
24+import Arrays
25+
26+main = do
27+ Trace.trace (runP (\s n -> s ++ show n) (P "Test" 1))
28+ Trace.print test1
examples/passing/MutRec.pursnew file+21
@@ -0,0 +1,21 @@
1+module MutRec where
2+
3+ import Prelude
4+
5+ f 0 = 0
6+ f x = g x + 1
7+
8+ g x = f (x / 2)
9+
10+ data Even = Zero | Even Odd
11+
12+ data Odd = Odd Even
13+
14+ evenToNumber Zero = 0
15+ evenToNumber (Even n) = oddToNumber n + 1
16+
17+ oddToNumber (Odd n) = evenToNumber n + 1
18+
19+module Main where
20+
21+main = Trace.trace "Done"
examples/passing/NamedPatterns.pursnew file+9
@@ -0,0 +1,9 @@
1+module NamedPatterns where
2+
3+ foo = \x -> case x of
4+ y@{ foo = "Foo" } -> y
5+ y -> y
6+
7+module Main where
8+
9+main = Trace.trace "Done"
examples/passing/Nested.pursnew file+9
@@ -0,0 +1,9 @@
1+module Nested where
2+
3+ data Extend r a = Extend { prev :: r a, next :: a }
4+
5+ data Matrix r a = Square (r (r a)) | Bigger (Matrix (Extend r) a)
6+
7+module Main where
8+
9+main = Trace.trace "Done"
examples/passing/NestedTypeSynonyms.pursnew file+13
@@ -0,0 +1,13 @@
1+module NestedTypeSynonyms where
2+
3+ type X = String
4+ type Y = X -> X
5+
6+ fn :: Y
7+ fn a = a
8+
9+module Main where
10+
11+ import Prelude
12+
13+ main = Trace.print (NestedTypeSynonyms.fn "Done")
examples/passing/ObjectSynonym.pursnew file+15
@@ -0,0 +1,15 @@
1+module ObjectSynonym where
2+
3+type Inner = Number
4+
5+inner :: Inner
6+inner = 0
7+
8+type Outer = { inner :: Inner }
9+
10+outer :: Outer
11+outer = { inner: inner }
12+
13+module Main where
14+
15+main = Trace.trace "Done"
examples/passing/ObjectUpdate.pursnew file+20
@@ -0,0 +1,20 @@
1+module ObjectUpdate where
2+
3+ update1 = \o -> o { foo = "Foo" }
4+
5+ update2 :: forall r. { foo :: String | r } -> { foo :: String | r }
6+ update2 = \o -> o { foo = "Foo" }
7+
8+ replace = \o -> case o of
9+ { foo = "Foo" } -> o { foo = "Bar" }
10+ { foo = "Bar" } -> o { bar = "Baz" }
11+ o -> o
12+
13+ polyUpdate :: forall a r. { foo :: a | r } -> { foo :: String | r }
14+ polyUpdate = \o -> o { foo = "Foo" }
15+
16+ inferPolyUpdate = \o -> o { foo = "Foo" }
17+
18+module Main where
19+
20+main = Trace.trace "Done"
examples/passing/Objects.pursnew file+20
@@ -0,0 +1,20 @@
1+module Objects where
2+
3+ import Prelude
4+
5+ test = \x -> x.foo + x.bar + 1
6+
7+ append = \o -> { foo: o.foo, bar: 1 }
8+
9+ apTest = append({foo : "Foo", baz: "Baz"})
10+
11+ f = (\a -> a.b.c) { b: { c: 1, d: "Hello" }, e: "World" }
12+
13+ g = (\a -> a.f { x: 1, y: "y" }) { f: \o -> o.x + 1 }
14+
15+ typed :: { foo :: Number }
16+ typed = { foo: 0 }
17+
18+module Main where
19+
20+main = Trace.trace "Done"
examples/passing/OneConstructor.pursnew file+9
@@ -0,0 +1,9 @@
1+module OneConstructor where
2+
3+data One a = One a
4+
5+one (One a) = a
6+
7+module Main where
8+
9+main = Trace.trace "Done"
examples/passing/Operators.pursnew file+82
@@ -0,0 +1,82 @@
1+module Operators1 where
2+
3+ import Prelude ((++))
4+
5+ (@@) :: forall a b. (a -> b) -> a -> b
6+ (@@) = \f x -> f x
7+
8+ foo :: String -> String
9+ foo = \s -> s
10+
11+ test8 = foo @@ "Hello World"
12+
13+ bar = \s1 s2 -> s1 ++ s2
14+
15+module Operators2 where
16+
17+ import Prelude
18+ import Operators1 ((@@))
19+
20+ test1 :: forall n. (Num n) => n -> n -> (n -> n -> n) -> n
21+ test1 x y z = x * y + z x y
22+
23+ test2 = (\x -> x.foo false) { foo : \_ -> 1 }
24+
25+ test3 = (\x y -> x)(1 + 2 * (1 + 2)) (true && (false || false))
26+
27+ k = \x -> \y -> x
28+
29+ test4 = 1 `k` 2
30+
31+ infixl 5 %%
32+
33+ (%%) :: Number -> Number -> Number
34+ (%%) x y = x * y + y
35+
36+ test5 = 1 %% 2 %% 3
37+
38+ test6 = ((\x -> x) `k` 2) 3
39+
40+ (<>) = \s1 s2 -> s1 ++ s2
41+
42+ test7 = "Hello" <> "World!"
43+
44+ test9 = Operators1.foo @@ "Hello World"
45+
46+ test10 = "Hello" `Operators1.bar` "World"
47+
48+ (...) :: forall a. [a] -> [a] -> [a]
49+ (...) = \as -> \bs -> as
50+
51+ test11 = [1, 2, 3] ... [4, 5, 6]
52+
53+ test12 (<%>) a b = a <%> b
54+
55+ test13 = \(<%>) a b -> a <%> b
56+
57+module Main where
58+
59+import Operators1
60+import Operators2
61+
62+import Prelude
63+import Eff
64+import Trace
65+import Global
66+import Arrays
67+
68+main =
69+ print [ show $ test1 1 2 $ \x y -> x + y
70+ , show test2
71+ , show test3
72+ , show test4
73+ , show test5
74+ , show test6
75+ , show test7
76+ , show test8
77+ , show test9
78+ , show test10
79+ , show test11
80+ , show (test12 k 1 2)
81+ , show (test13 k 1 2)
82+ ]
examples/passing/OptimizerBug.pursnew file+11
@@ -0,0 +1,11 @@
1+module OptimizerBug where
2+
3+import Prelude
4+
5+x a = 1 + y a
6+
7+y a = x a
8+
9+module Main where
10+
11+main = Trace.trace "Done"
examples/passing/Patterns.pursnew file+30
@@ -0,0 +1,30 @@
1+module Patterns where
2+
3+ import Prelude
4+
5+ test = \x -> case x of
6+ { str = "Foo", bool = true } -> true
7+ { str = "Bar", bool = b } -> b
8+ _ -> false
9+
10+ f = \o -> case o of
11+ { foo = "Foo" } -> o.bar
12+ _ -> 0
13+
14+ g = \o -> case o of
15+ { arr = [x : xs], take = "car" } -> x
16+ { arr = [_, x : xs], take = "cadr" } -> x
17+ _ -> 0
18+
19+
20+ h = \o -> case o of
21+ a@[_,_,_] -> a
22+ _ -> []
23+
24+ isDesc :: [Number] -> Boolean
25+ isDesc [x, y] | x > y = true
26+ isDesc _ = false
27+
28+module Main where
29+
30+main = Trace.trace "Done"
examples/passing/Person.pursnew file+15
@@ -0,0 +1,15 @@
1+module Person where
2+
3+ import Prelude ((++))
4+
5+ data Person = Person { name :: String, age :: Number }
6+
7+ foreign import itoa :: Number -> String
8+
9+ showPerson :: Person -> String
10+ showPerson = \p -> case p of
11+ Person o -> o.name ++ ", aged " ++ itoa(o.age)
12+
13+module Main where
14+
15+main = Trace.trace "Done"
examples/passing/Rank2Data.pursnew file+31
@@ -0,0 +1,31 @@
1+module Rank2Data where
2+
3+ import Prelude
4+
5+ data Id = Id forall a. a -> a
6+
7+ runId = \id a -> case id of
8+ Id f -> f a
9+
10+ data Nat = Nat forall r. r -> (r -> r) -> r
11+
12+ runNat = \nat -> case nat of
13+ Nat f -> f 0 (\n -> n + 1)
14+
15+ zero = Nat (\zero _ -> zero)
16+
17+ succ = \n -> case n of
18+ Nat f -> Nat (\zero succ -> succ (f zero succ))
19+
20+ add = \n m -> case n of
21+ Nat f -> case m of
22+ Nat g -> Nat (\zero succ -> g (f zero succ) succ)
23+
24+ one = succ zero
25+ two = succ zero
26+ four = add two two
27+ fourNumber = runNat four
28+
29+module Main where
30+
31+main = Trace.trace "Done"
examples/passing/Rank2Types.pursnew file+25
@@ -0,0 +1,25 @@
1+module Rank2Types where
2+
3+ import Prelude
4+
5+ test1 :: (forall a. (a -> a)) -> Number
6+ test1 = \f -> f 0
7+
8+ foreign import data ST :: * -> * -> *
9+
10+ foreign import runST :: forall a. (forall s. ST s a) -> a
11+
12+ foreign import exampleST :: forall s. ST s Number
13+
14+ testST = \_ -> runST exampleST
15+
16+ foreign import push :: forall el. el -> [el] -> [el]
17+
18+ replicateM :: forall m a. (forall a. a -> m a) -> (forall a b. m a -> (a -> m b) -> m b) -> Number -> m a -> m [a]
19+ replicateM = \return bind n m -> case n of
20+ 0 -> return []
21+ n -> bind m (\x -> bind (replicateM return bind (n - 1) m) (\xs -> return (push x xs)))
22+
23+module Main where
24+
25+main = Trace.trace "Done"
examples/passing/Recursion.pursnew file+12
@@ -0,0 +1,12 @@
1+module Recursion where
2+
3+ import Prelude
4+
5+ fib = \n -> case n of
6+ 0 -> 1
7+ 1 -> 1
8+ n -> fib (n - 1) + fib (n - 2)
9+
10+module Main where
11+
12+main = Trace.trace "Done"
examples/passing/RedefinedFixity.pursnew file+18
@@ -0,0 +1,18 @@
1+module M1 where
2+
3+($) f a = f a
4+
5+infixr 1000 $
6+
7+module M2 where
8+
9+import M1
10+
11+module M3 where
12+
13+import M1
14+import M2
15+
16+module Main where
17+
18+main = Trace.trace "Done"
examples/passing/RuntimeScopeIssue.pursnew file+25
@@ -0,0 +1,25 @@
1+module RuntimeScopeIssue where
2+
3+import Prelude
4+
5+class A a where
6+ a :: a -> Boolean
7+
8+class B a where
9+ b :: a -> Boolean
10+
11+instance A Number where
12+ a 0 = true
13+ a n = b (n - 1)
14+
15+instance B Number where
16+ b 0 = false
17+ b n = a (n - 1)
18+
19+module Main where
20+
21+import RuntimeScopeIssue
22+
23+import Prelude
24+
25+main = Trace.print $ a 10
examples/passing/STArray.pursnew file+23
@@ -0,0 +1,23 @@
1+module Main where
2+
3+import Prelude
4+import Eff
5+import ST
6+import Arrays
7+
8+test = runSTArray (do
9+ a <- newSTArray 2 0
10+ pokeSTArray a 0 1
11+ pokeSTArray a 1 2
12+ return a)
13+
14+fromTo' lo hi _ arr | lo > hi = return arr
15+fromTo' lo hi i arr = do
16+ pokeSTArray arr i lo
17+ fromTo' (lo + 1) hi (i + 1) arr
18+
19+fromTo lo hi = runSTArray (do
20+ arr <- newSTArray (hi - lo + 1) 0
21+ fromTo' lo hi 0 arr)
22+
23+main = Trace.print $ runPure (fromTo 10 20)
examples/passing/TailCall.pursnew file+20
@@ -0,0 +1,20 @@
1+module TailCall where
2+
3+import Prelude
4+
5+test :: Number -> [Number] -> Number
6+test n [] = n
7+test n (x:xs) = test (n + x) xs
8+
9+loop :: forall a. Number -> a
10+loop x = loop (x + 1)
11+
12+notATailCall = \x ->
13+ (\notATailCall -> notATailCall x) (\x -> x)
14+
15+module Main where
16+
17+import Prelude
18+import TailCall
19+
20+main = Trace.print (test 0 [1, 2, 3])
examples/passing/Tick.pursnew file+7
@@ -0,0 +1,7 @@
1+module Tick where
2+
3+test' x = x
4+
5+module Main where
6+
7+main = Trace.trace "Done"
examples/passing/TopLevelCase.pursnew file+20
@@ -0,0 +1,20 @@
1+module TopLevelCase where
2+
3+ import Prelude
4+
5+ gcd :: Number -> Number -> Number
6+ gcd 0 x = x
7+ gcd x 0 = x
8+ gcd x y | x > y = gcd (x % y) y
9+ gcd x y = gcd (y % x) x
10+
11+ guardsTest (x:xs) | x > 0 = guardsTest xs
12+ guardsTest xs = xs
13+
14+ data A = A
15+
16+ parseTest A 0 = 0
17+
18+module Main where
19+
20+main = Trace.trace "Done"
examples/passing/TypeClasses.pursnew file+69
@@ -0,0 +1,69 @@
1+module TypeClasses where
2+
3+import Prelude
4+
5+test1 = \_ -> show "testing"
6+
7+f :: forall a. (Prelude.Show a) => a -> String
8+f x = show x
9+
10+test2 = \_ -> f "testing"
11+
12+test7 :: forall a. (Prelude.Show a) => a -> String
13+test7 = show
14+
15+test8 = \_ -> show $ "testing"
16+
17+data Data a = Data a
18+
19+instance (Prelude.Show a) => Prelude.Show (Data a) where
20+ show (Data a) = "Data (" ++ show a ++ ")"
21+
22+test3 = \_ -> show (Data "testing")
23+
24+instance Prelude.Monad Data where
25+ return = Data
26+ (>>=) (Data a) f = f a
27+
28+data Maybe a = Nothing | Just a
29+
30+instance Prelude.Monad Maybe where
31+ return = Just
32+ (>>=) Nothing _ = Nothing
33+ (>>=) (Just a) f = f a
34+
35+test4 :: forall a m. (Monad m) => a -> m Number
36+test4 = \_ -> return 1
37+
38+test5 = \_ -> Just 1 >>= \n -> return (n + 1)
39+
40+module TypeClasses2 where
41+
42+import Prelude
43+import TypeClasses
44+
45+instance (Prelude.Show a) => Prelude.Show [a] where
46+ show [] = "[]"
47+ show (x:xs) = show x ++ ", " ++ show xs
48+
49+test6 = \_ -> show ["testing"]
50+
51+instance Prelude.Monad (->) r where
52+ return a r = a
53+ (>>=) f g r = g (f r) r
54+
55+ask r = r
56+
57+runReader r f = f r
58+
59+test9 _ = runReader 0 $ do
60+ n <- ask
61+ return $ n + 1
62+
63+module Main where
64+
65+import Prelude
66+import TypeClasses
67+
68+main = Trace.trace (test7 "Done")
69+
examples/passing/TypeClassesInOrder.pursnew file+11
@@ -0,0 +1,11 @@
1+module Main where
2+
3+import Prelude
4+
5+class Foo a where
6+ foo :: a -> String
7+
8+instance Foo String where
9+ foo s = s
10+
11+main = Trace.trace $ foo "Done"
examples/passing/TypeClassesWithOverlappingTypeVariables.pursnew file+10
@@ -0,0 +1,10 @@
1+module Main where
2+
3+ import Prelude
4+ import Either
5+
6+ instance Prelude.Functor (Either a) where
7+ (<$>) _ (Left x) = Left x
8+ (<$>) f (Right y) = Right (f y)
9+
10+ main = Trace.trace "Done"
examples/passing/TypeDecl.pursnew file+14
@@ -0,0 +1,14 @@
1+module TypeDecl where
2+
3+ import Prelude
4+
5+ k :: String -> Number -> String
6+ k x y = x
7+
8+ iterate :: forall a. Number -> (a -> a) -> a -> a
9+ iterate 0 f a = a
10+ iterate n f a = iterate (n - 1) f (f a)
11+
12+module Main where
13+
14+main = Trace.trace "Done"
examples/passing/TypeSynonyms.pursnew file+39
@@ -0,0 +1,39 @@
1+module TypeSynonyms where
2+
3+ type Lens a b =
4+ { get :: a -> b
5+ , set :: a -> b -> a
6+ }
7+
8+ composeLenses :: forall a b c. Lens a b -> Lens b c -> Lens a c
9+ composeLenses = \l1 -> \l2 ->
10+ { get: \a -> l2.get (l1.get a)
11+ , set: \a c -> l1.set a (l2.set (l1.get a) c)
12+ }
13+
14+ type Pair a b = { fst :: a, snd :: b }
15+
16+ fst :: forall a b. Lens (Pair a b) a
17+ fst =
18+ { get: \p -> p.fst
19+ , set: \p a -> { fst: a, snd: p.snd }
20+ }
21+
22+ test1 :: forall a b c. Lens (Pair (Pair a b) c) a
23+ test1 = composeLenses fst fst
24+
25+ import Arrays
26+
27+ headLens :: forall a. Lens [a] a
28+ headLens =
29+ { get: \l -> head l
30+ , set: \l a -> case l of
31+ _:xs -> a : xs
32+ }
33+
34+ test2 :: forall a b c. Lens (Pair [Pair a b] c) a
35+ test2 = composeLenses fst (composeLenses headLens fst)
36+
37+module Main where
38+
39+main = Trace.trace "Done"
examples/passing/iota.pursnew file+11
@@ -0,0 +1,11 @@
1+module Iota where
2+
3+ s = \x -> \y -> \z -> x z (y z)
4+
5+ k = \x -> \y -> x
6+
7+ iota = \x -> x s k
8+
9+module Main where
10+
11+main = Trace.trace "Done"
examples/passing/s.pursnew file+7
@@ -0,0 +1,7 @@
1+module S where
2+
3+ s = \x y z -> x z (y z)
4+
5+module Main where
6+
7+main = Trace.trace "Done"
execTests.shnew file+1
@@ -0,0 +1 @@
1+dist/build/tests/tests --run-js
package.yamldeleted−86
@@ -1,86 +0,0 @@
1−name: psgo
2−version: 0.1.0.0
3−github: "andyarvanitis/purescript-native"
4−license: BSD3
5−author: "Andy Arvanitis"
6−maintainer: "example@example.com"
7−copyright: "2018 Andy Arvanitis"
8−
9−extra-source-files:
10−- README.md
11−- ChangeLog.md
12−- stack.yaml
13−- support/*
14−
15−# Metadata used when publishing your package
16−# synopsis: Short description of your package
17−# category: Web
18−
19−# To avoid duplicated efforts in documentation and dealing with the
20−# complications of embedding Haddock markup inside cabal files, it is
21−# common to point users to the README.md file.
22−description: Please see the README on Github at <https://github.com/andyarvanitis/purescript-native#readme>
23−
24−dependencies:
25−- base >= 4.7 && < 5
26−- bytestring >= 0.10.8.2 && < 0.11
27−- purescript
28−- base-compat >=0.6.0
29−- protolude >=0.1.6
30−- text
31−- containers
32−- filepath
33−- monad-parallel >= 0.7.2.2 && <0.8
34−- pattern-arrows >=0.0.2 && <0.1
35−- safe >=0.3.9 && <0.4
36−- transformers >=0.3.0 && <0.6
37−- mtl >=2.1.0 && <2.3.0
38−- aeson >=1.0 && <1.5
39−- directory
40−- process
41−- file-embed
42−- filemanip
43−- gitrev
44−
45−library:
46− source-dirs: src
47− default-extensions:
48− - ConstraintKinds
49− - DataKinds
50− - DeriveFunctor
51− - EmptyDataDecls
52− - FlexibleContexts
53− - KindSignatures
54− - LambdaCase
55− - MultiParamTypeClasses
56− - NoImplicitPrelude
57− - PatternGuards
58− - PatternSynonyms
59− - RankNTypes
60− - RecordWildCards
61− - OverloadedStrings
62− - ScopedTypeVariables
63− - TupleSections
64− - ViewPatterns
65−
66−executables:
67− psgo:
68− main: Main.hs
69− source-dirs: app
70− ghc-options:
71− - -threaded
72− - -rtsopts
73− - -with-rtsopts=-N
74− dependencies:
75− - psgo
76−
77−tests:
78− psgo-test:
79− main: Spec.hs
80− source-dirs: test
81− ghc-options:
82− - -threaded
83− - -rtsopts
84− - -with-rtsopts=-N
85− dependencies:
86− - psgo
prelude/README.mdnew file+696
@@ -0,0 +1,696 @@
1+# Module Documentation
2+## Module Prelude
3+
4+### Types
5+
6+ data Ref a where
7+ Ref :: a -> Ref a
8+
9+
10+### Type Classes
11+
12+ class Alternative f where
13+ empty :: forall a. f a
14+ (<|>) :: forall a. f a -> f a -> f a
15+
16+ class Applicative f where
17+ pure :: forall a. a -> f a
18+ (<*>) :: forall b. forall a. f (a -> b) -> f a -> f b
19+
20+ class Bits b where
21+ (&) :: b -> b -> b
22+ (|) :: b -> b -> b
23+ (^) :: b -> b -> b
24+ shl :: b -> Prim.Number -> b
25+ shr :: b -> Prim.Number -> b
26+ zshr :: b -> Prim.Number -> b
27+ complement :: b -> b
28+
29+ class BoolLike b where
30+ (&&) :: b -> b -> b
31+ (||) :: b -> b -> b
32+ not :: b -> b
33+
34+ class Category a where
35+ id :: forall t. a t t
36+ (<<<) :: forall d. forall c. forall b. a c d -> a b c -> a b d
37+ (>>>) :: forall d. forall c. forall b. a b c -> a c d -> a b d
38+
39+ class Eq a where
40+ (==) :: a -> a -> Prim.Boolean
41+ (/=) :: a -> a -> Prim.Boolean
42+
43+ class Functor f where
44+ (<$>) :: forall b. forall a. (a -> b) -> f a -> f b
45+
46+ class Monad m where
47+ return :: forall a. a -> m a
48+ (>>=) :: forall b. forall a. m a -> (a -> m b) -> m b
49+
50+ class Num a where
51+ (+) :: a -> a -> a
52+ (-) :: a -> a -> a
53+ (*) :: a -> a -> a
54+ (/) :: a -> a -> a
55+ (%) :: a -> a -> a
56+ negate :: a -> a
57+
58+ class Ord a where
59+ (<) :: a -> a -> Prim.Boolean
60+ (>) :: a -> a -> Prim.Boolean
61+ (<=) :: a -> a -> Prim.Boolean
62+ (>=) :: a -> a -> Prim.Boolean
63+
64+ class Read a where
65+ read :: Prim.String -> a
66+
67+ class Show a where
68+ show :: a -> Prim.String
69+
70+
71+### Type Class Instances
72+
73+ (Monad (m)) => instance Applicative m
74+
75+ instance Bits Prim.Number
76+
77+ instance BoolLike Prim.Boolean
78+
79+ instance Category Prim.Function
80+
81+ instance Eq Ref a
82+
83+ instance Eq Prim.String
84+
85+ instance Eq Prim.Number
86+
87+ instance Eq Prim.Boolean
88+
89+ (Eq (a)) => instance Eq [a]
90+
91+ (Applicative (f)) => instance Functor f
92+
93+ instance Num Prim.Number
94+
95+ instance Ord Prim.Number
96+
97+ instance Prelude.Show Prim.Number
98+
99+ instance Read Prim.String
100+
101+ instance Read Prim.Boolean
102+
103+ instance Read Prim.Number
104+
105+ instance Show Prim.String
106+
107+ instance Show Prim.Boolean
108+
109+
110+### Values
111+
112+ (!!) :: forall a. [a] -> Prim.Number -> a
113+
114+ (#) :: forall b. forall a. a -> (a -> b) -> b
115+
116+ ($) :: forall b. forall a. (a -> b) -> a -> b
117+
118+ (++) :: Prim.String -> Prim.String -> Prim.String
119+
120+ boolAnd :: Prim.Boolean -> Prim.Boolean -> Prim.Boolean
121+
122+ boolNot :: Prim.Boolean -> Prim.Boolean
123+
124+ boolOr :: Prim.Boolean -> Prim.Boolean -> Prim.Boolean
125+
126+ const :: forall b. forall a. a -> b -> a
127+
128+ flip :: forall c. forall b. forall a. (a -> b -> c) -> b -> a -> c
129+
130+ numAdd :: Prim.Number -> Prim.Number -> Prim.Number
131+
132+ numAnd :: Prim.Number -> Prim.Number -> Prim.Number
133+
134+ numComplement :: Prim.Number -> Prim.Number
135+
136+ numDiv :: Prim.Number -> Prim.Number -> Prim.Number
137+
138+ numGreater :: Prim.Number -> Prim.Number -> Prim.Boolean
139+
140+ numGreaterEq :: Prim.Number -> Prim.Number -> Prim.Boolean
141+
142+ numLess :: Prim.Number -> Prim.Number -> Prim.Boolean
143+
144+ numLessEq :: Prim.Number -> Prim.Number -> Prim.Boolean
145+
146+ numMod :: Prim.Number -> Prim.Number -> Prim.Number
147+
148+ numMul :: Prim.Number -> Prim.Number -> Prim.Number
149+
150+ numNegate :: Prim.Number -> Prim.Number
151+
152+ numOr :: Prim.Number -> Prim.Number -> Prim.Number
153+
154+ numShl :: Prim.Number -> Prim.Number -> Prim.Number
155+
156+ numShr :: Prim.Number -> Prim.Number -> Prim.Number
157+
158+ numSub :: Prim.Number -> Prim.Number -> Prim.Number
159+
160+ numXor :: Prim.Number -> Prim.Number -> Prim.Number
161+
162+ numZshr :: Prim.Number -> Prim.Number -> Prim.Number
163+
164+ readNumber :: Prim.String -> Prim.Number
165+
166+ refEq :: forall a. Ref a -> Ref a -> Prim.Boolean
167+
168+ refIneq :: forall a. Ref a -> Ref a -> Prim.Boolean
169+
170+ showNumber :: Prim.Number -> Prim.String
171+
172+ unsafeRefEq :: forall a. a -> a -> Prim.Boolean
173+
174+ unsafeRefIneq :: forall a. a -> a -> Prim.Boolean
175+
176+
177+## Module Monoid
178+
179+### Types
180+
181+
182+### Type Classes
183+
184+ class Monoid m where
185+ mempty :: m
186+ (<>) :: m -> m -> m
187+
188+
189+### Type Class Instances
190+
191+ instance Monoid Prim.String
192+
193+ instance Monoid [a]
194+
195+
196+### Values
197+
198+ mconcat :: forall m. (Monoid (m)) => [m] -> m
199+
200+
201+## Module Monad
202+
203+### Types
204+
205+
206+### Type Classes
207+
208+
209+### Type Class Instances
210+
211+
212+### Values
213+
214+ (<=<) :: forall c. forall b. forall a. forall m. (Monad (m)) => (b -> m c) -> (a -> m b) -> a -> m c
215+
216+ (>=>) :: forall c. forall b. forall a. forall m. (Monad (m)) => (a -> m b) -> (b -> m c) -> a -> m c
217+
218+ foldM :: forall b. forall a. forall m. (Monad (m)) => (a -> b -> m a) -> a -> [b] -> m a
219+
220+ join :: forall a. forall m. (Monad (m)) => m (m a) -> m a
221+
222+ mapM :: forall b. forall a. forall m. (Monad (m)) => (a -> m b) -> [a] -> m [b]
223+
224+ replicateM :: forall a. forall m. (Monad (m)) => Prim.Number -> m a -> m [a]
225+
226+ sequence :: forall a. forall m. (Monad (m)) => [m a] -> m [a]
227+
228+ when :: forall m. (Monad (m)) => Prim.Boolean -> m { } -> m { }
229+
230+
231+## Module Maybe
232+
233+### Types
234+
235+ data Maybe a where
236+ Nothing :: Maybe a
237+ Just :: a -> Maybe a
238+
239+
240+### Type Classes
241+
242+
243+### Type Class Instances
244+
245+ instance Prelude.Applicative Maybe
246+
247+ instance Prelude.Functor Maybe
248+
249+ instance Prelude.Monad Maybe
250+
251+ (Show (a)) => instance Prelude.Show Maybe a
252+
253+
254+### Values
255+
256+ fromMaybe :: forall a. a -> Maybe a -> a
257+
258+ maybe :: forall b. forall a. b -> (a -> b) -> Maybe a -> b
259+
260+
261+## Module Either
262+
263+### Types
264+
265+ data Either a b where
266+ Left :: a -> Either a b
267+ Right :: b -> Either a b
268+
269+
270+### Type Classes
271+
272+
273+### Type Class Instances
274+
275+ instance Prelude.Applicative Either e
276+
277+ instance Prelude.Functor Either a
278+
279+ instance Prelude.Monad Either e
280+
281+ (Show (a),Show (b)) => instance Prelude.Show Either a b
282+
283+
284+### Values
285+
286+ either :: forall c. forall b. forall a. (a -> c) -> (b -> c) -> Either a b -> c
287+
288+
289+## Module Arrays
290+
291+### Types
292+
293+
294+### Type Classes
295+
296+
297+### Type Class Instances
298+
299+ instance Prelude.Alternative Prim.Array
300+
301+ instance Prelude.Functor Prim.Array
302+
303+ instance Prelude.Monad Prim.Array
304+
305+ (Prelude.Show (a)) => instance Prelude.Show [a]
306+
307+
308+### Values
309+
310+ (:) :: forall a. a -> [a] -> [a]
311+
312+ all :: forall a. (a -> Prim.Boolean) -> [a] -> Prim.Boolean
313+
314+ any :: forall a. (a -> Prim.Boolean) -> [a] -> Prim.Boolean
315+
316+ concat :: forall a. [a] -> [a] -> [a]
317+
318+ concatMap :: forall b. forall a. [a] -> (a -> [b]) -> [b]
319+
320+ filter :: forall a. (a -> Prim.Boolean) -> [a] -> [a]
321+
322+ foldl :: forall b. forall a. (a -> b -> b) -> b -> [a] -> b
323+
324+ foldr :: forall b. forall a. (a -> b -> a) -> a -> [b] -> a
325+
326+ head :: forall a. [a] -> a
327+
328+ headSafe :: forall a. [a] -> Maybe a
329+
330+ indexOf :: forall a. [a] -> a -> Prim.Number
331+
332+ isEmpty :: forall a. [a] -> Prim.Boolean
333+
334+ joinS :: [Prim.String] -> Prim.String
335+
336+ joinWith :: [Prim.String] -> Prim.String -> Prim.String
337+
338+ lastIndexOf :: forall a. [a] -> a -> Prim.Number
339+
340+ length :: forall a. [a] -> Prim.Number
341+
342+ map :: forall b. forall a. (a -> b) -> [a] -> [b]
343+
344+ push :: forall a. [a] -> a -> [a]
345+
346+ range :: Prim.Number -> Prim.Number -> [Prim.Number]
347+
348+ reverse :: forall a. [a] -> [a]
349+
350+ shift :: forall a. [a] -> [a]
351+
352+ singleton :: forall a. a -> [a]
353+
354+ slice :: forall a. Prim.Number -> Prim.Number -> [a] -> [a]
355+
356+ sort :: forall a. [a] -> [a]
357+
358+ splice :: forall a. Prim.Number -> Prim.Number -> [a] -> [a] -> [a]
359+
360+ tail :: forall a. [a] -> [a]
361+
362+ tailSafe :: forall a. [a] -> Maybe [a]
363+
364+ zipWith :: forall c. forall b. forall a. (a -> b -> c) -> [a] -> [b] -> [c]
365+
366+
367+## Module Tuples
368+
369+### Types
370+
371+ data Tuple a b where
372+ Tuple :: a -> b -> Tuple a b
373+
374+
375+### Type Classes
376+
377+
378+### Type Class Instances
379+
380+ (Prelude.Show (a),Prelude.Show (b)) => instance Prelude.Show Tuple a b
381+
382+
383+### Values
384+
385+ curry :: forall c. forall b. forall a. (Tuple a b -> c) -> a -> b -> c
386+
387+ uncurry :: forall c. forall b. forall a. (a -> b -> c) -> Tuple a b -> c
388+
389+ unzip :: forall b. forall a. [Tuple a b] -> Tuple [a] [b]
390+
391+ zip :: forall b. forall a. [a] -> [b] -> [Tuple a b]
392+
393+
394+## Module String
395+
396+### Types
397+
398+
399+### Type Classes
400+
401+
402+### Type Class Instances
403+
404+
405+### Values
406+
407+ charAt :: Prim.Number -> Prim.String -> Prim.String
408+
409+ indexOfS :: Prim.String -> Prim.String -> Prim.Number
410+
411+ lastIndexOfS :: Prim.String -> Prim.String -> Prim.Number
412+
413+ lengthS :: Prim.String -> Prim.Number
414+
415+ localeCompare :: Prim.String -> Prim.String -> Prim.Number
416+
417+ replace :: Prim.String -> Prim.String -> Prim.String -> Prim.String
418+
419+ sliceS :: Prim.Number -> Prim.Number -> Prim.String -> Prim.String
420+
421+ split :: Prim.String -> Prim.String -> [Prim.String]
422+
423+ substr :: Prim.Number -> Prim.Number -> Prim.String -> Prim.String
424+
425+ substring :: Prim.Number -> Prim.Number -> Prim.String -> Prim.String
426+
427+ toLower :: Prim.String -> Prim.String
428+
429+ toUpper :: Prim.String -> Prim.String
430+
431+ trim :: Prim.String -> Prim.String
432+
433+
434+## Module Regex
435+
436+### Types
437+
438+ data Regex :: *
439+
440+
441+### Type Classes
442+
443+
444+### Type Class Instances
445+
446+
447+### Values
448+
449+ match :: Regex -> Prim.String -> [Prim.String]
450+
451+ regex :: Prim.String -> Prim.String -> Regex
452+
453+ replaceR :: Regex -> Prim.String -> Prim.String -> Prim.String
454+
455+ search :: Regex -> Prim.String -> Prim.Number
456+
457+ test :: Regex -> Prim.String -> Prim.Boolean
458+
459+
460+## Module Global
461+
462+### Types
463+
464+
465+### Type Classes
466+
467+
468+### Type Class Instances
469+
470+
471+### Values
472+
473+ decodeURI :: Prim.String -> Prim.String
474+
475+ decodeURIComponent :: Prim.String -> Prim.String
476+
477+ encodeURI :: Prim.String -> Prim.String
478+
479+ encodeURIComponent :: Prim.String -> Prim.String
480+
481+ infinity :: Prim.Number
482+
483+ isFinite :: Prim.Number -> Prim.Boolean
484+
485+ isNaN :: Prim.Number -> Prim.Boolean
486+
487+ nan :: Prim.Number
488+
489+ parseFloat :: Prim.String -> Prim.Number
490+
491+ parseInt :: Prim.String -> Prim.Number
492+
493+ toExponential :: Prim.Number -> Prim.String
494+
495+ toFixed :: Prim.Number -> Prim.Number -> Prim.String
496+
497+ toPrecision :: Prim.Number -> Prim.Number -> Prim.String
498+
499+
500+## Module Math
501+
502+### Types
503+
504+
505+### Type Classes
506+
507+
508+### Type Class Instances
509+
510+
511+### Values
512+
513+ abs :: Prim.Number -> Prim.Number
514+
515+ aceil :: Prim.Number -> Prim.Number
516+
517+ acos :: Prim.Number -> Prim.Number
518+
519+ asin :: Prim.Number -> Prim.Number
520+
521+ atan :: Prim.Number -> Prim.Number
522+
523+ atan2 :: Prim.Number -> Prim.Number -> Prim.Number
524+
525+ cos :: Prim.Number -> Prim.Number
526+
527+ exp :: Prim.Number -> Prim.Number
528+
529+ floor :: Prim.Number -> Prim.Number
530+
531+ log :: Prim.Number -> Prim.Number
532+
533+ max :: Prim.Number -> Prim.Number
534+
535+ min :: Prim.Number -> Prim.Number
536+
537+ pow :: Prim.Number -> Prim.Number
538+
539+ round :: Prim.Number -> Prim.Number
540+
541+ sin :: Prim.Number -> Prim.Number
542+
543+ sqrt :: Prim.Number -> Prim.Number
544+
545+ tan :: Prim.Number -> Prim.Number
546+
547+
548+## Module Eff
549+
550+### Types
551+
552+ data Eff :: # ! -> * -> *
553+
554+ type Pure a = forall e. Eff e a
555+
556+
557+### Type Classes
558+
559+
560+### Type Class Instances
561+
562+ instance Prelude.Monad Eff e
563+
564+
565+### Values
566+
567+ bindEff :: forall b. forall a. forall e. Eff e a -> (a -> Eff e b) -> Eff e b
568+
569+ forE :: forall e. Prim.Number -> Prim.Number -> (Prim.Number -> Eff e { }) -> Eff e { }
570+
571+ foreachE :: forall a. forall e. [a] -> (a -> Eff e { }) -> Eff e { }
572+
573+ retEff :: forall a. forall e. a -> Eff e a
574+
575+ runPure :: forall a. Pure a -> a
576+
577+ untilE :: forall e. Eff e Prim.Boolean -> Eff e { }
578+
579+ whileE :: forall e. Eff e Prim.Boolean -> Eff e { } -> Eff e { }
580+
581+
582+## Module Random
583+
584+### Types
585+
586+ data Random :: !
587+
588+
589+### Type Classes
590+
591+
592+### Type Class Instances
593+
594+
595+### Values
596+
597+ random :: forall e. Eff random :: Random | e Prim.Number
598+
599+
600+## Module Errors
601+
602+### Types
603+
604+ data Error :: * -> !
605+
606+
607+### Type Classes
608+
609+
610+### Type Class Instances
611+
612+
613+### Values
614+
615+ catchError :: forall a. forall r. forall e. (e -> Eff r a) -> Eff err :: Error e | r a -> Eff r a
616+
617+ throwError :: forall r. forall e. forall a. e -> Eff err :: Error e | r a
618+
619+
620+## Module IORef
621+
622+### Types
623+
624+ data IORef :: * -> *
625+
626+ data Ref :: !
627+
628+
629+### Type Classes
630+
631+
632+### Type Class Instances
633+
634+
635+### Values
636+
637+ modifyIORef :: forall r. forall s. IORef s -> (s -> s) -> Eff ref :: Ref | r { }
638+
639+ newIORef :: forall r. forall s. s -> Eff ref :: Ref | r (IORef s)
640+
641+ readIORef :: forall r. forall s. IORef s -> Eff ref :: Ref | r s
642+
643+ unsafeRunIORef :: forall a. forall eff. Eff ref :: Ref | eff a -> Eff eff a
644+
645+ writeIORef :: forall r. forall s. IORef s -> s -> Eff ref :: Ref | r { }
646+
647+
648+## Module Trace
649+
650+### Types
651+
652+ data Trace :: !
653+
654+
655+### Type Classes
656+
657+
658+### Type Class Instances
659+
660+
661+### Values
662+
663+ print :: forall r. forall a. (Prelude.Show (a)) => a -> Eff trace :: Trace | r { }
664+
665+ trace :: forall r. Prim.String -> Eff trace :: Trace | r { }
666+
667+
668+## Module ST
669+
670+### Types
671+
672+ data ST :: * -> !
673+
674+ data STRef :: * -> * -> *
675+
676+
677+### Type Classes
678+
679+
680+### Type Class Instances
681+
682+
683+### Values
684+
685+ modifySTRef :: forall r. forall h. forall a. STRef h a -> (a -> a) -> Eff st :: ST h | r { }
686+
687+ newSTRef :: forall r. forall h. forall a. a -> Eff st :: ST h | r (STRef h a)
688+
689+ readSTRef :: forall r. forall h. forall a. STRef h a -> Eff st :: ST h | r a
690+
691+ runST :: forall r. forall a. forall h. Eff st :: ST h | r a -> Eff r a
692+
693+ writeSTRef :: forall r. forall h. forall a. STRef h a -> a -> Eff st :: ST h | r { }
694+
695+
696+
prelude/prelude.pursnew file+1142
@@ -0,0 +1,1142 @@
1+module Prelude where
2+
3+ flip :: forall a b c. (a -> b -> c) -> b -> a -> c
4+ flip f b a = f a b
5+
6+ const :: forall a b. a -> b -> a
7+ const a _ = a
8+
9+ infixr 9 >>>
10+ infixr 9 <<<
11+
12+ class Category a where
13+ id :: forall t. a t t
14+ (<<<) :: forall b c d. a c d -> a b c -> a b d
15+ (>>>) :: forall b c d. a b c -> a c d -> a b d
16+
17+ instance Category (->) where
18+ id x = x
19+ (<<<) f g x = f (g x)
20+ (>>>) f g x = g (f x)
21+
22+ infixr 0 $
23+ infixl 0 #
24+
25+ ($) :: forall a b. (a -> b) -> a -> b
26+ ($) f x = f x
27+
28+ (#) :: forall a b. a -> (a -> b) -> b
29+ (#) x f = f x
30+
31+ class Show a where
32+ show :: a -> String
33+
34+ instance Show String where
35+ show s = s
36+
37+ instance Show Boolean where
38+ show true = "true"
39+ show false = "false"
40+
41+ foreign import showNumber "function showNumber(n) {\
42+ \ return n.toString();\
43+ \}" :: Number -> String
44+
45+ instance Prelude.Show Number where
46+ show = showNumber
47+
48+ class Read a where
49+ read :: String -> a
50+
51+ instance Read String where
52+ read s = s
53+
54+ instance Read Boolean where
55+ read "true" = true
56+ read _ = false
57+
58+ foreign import readNumber "function readNumber(n) {\
59+ \ return parseFloat(n);\
60+ \}" :: String -> Number
61+
62+ instance Read Number where
63+ read = readNumber
64+
65+ infixl 4 <$>
66+
67+ class Functor f where
68+ (<$>) :: forall a b. (a -> b) -> f a -> f b
69+
70+ infixl 4 <*>
71+
72+ class Applicative f where
73+ pure :: forall a. a -> f a
74+ (<*>) :: forall a b. f (a -> b) -> f a -> f b
75+
76+ instance (Applicative f) => Functor f where
77+ (<$>) f a = pure f <*> a
78+
79+ infixl 3 <|>
80+
81+ class Alternative f where
82+ empty :: forall a. f a
83+ (<|>) :: forall a. f a -> f a -> f a
84+
85+ infixl 1 >>=
86+
87+ class Monad m where
88+ return :: forall a. a -> m a
89+ (>>=) :: forall a b. m a -> (a -> m b) -> m b
90+
91+ instance (Monad m) => Applicative m where
92+ pure = return
93+ (<*>) f a = do
94+ f' <- f
95+ a' <- a
96+ return (f' a')
97+
98+ infixl 7 *
99+ infixl 7 /
100+ infixl 7 %
101+
102+ infixl 6 -
103+ infixl 6 +
104+
105+ class Num a where
106+ (+) :: a -> a -> a
107+ (-) :: a -> a -> a
108+ (*) :: a -> a -> a
109+ (/) :: a -> a -> a
110+ (%) :: a -> a -> a
111+ negate :: a -> a
112+
113+ foreign import numAdd "function numAdd(n1) {\
114+ \ return function(n2) {\
115+ \ return n1 + n2;\
116+ \ };\
117+ \}" :: Number -> Number -> Number
118+
119+ foreign import numSub "function numSub(n1) {\
120+ \ return function(n2) {\
121+ \ return n1 - n2;\
122+ \ };\
123+ \}" :: Number -> Number -> Number
124+
125+ foreign import numMul "function numMul(n1) {\
126+ \ return function(n2) {\
127+ \ return n1 * n2;\
128+ \ };\
129+ \}" :: Number -> Number -> Number
130+
131+ foreign import numDiv "function numDiv(n1) {\
132+ \ return function(n2) {\
133+ \ return n1 / n2;\
134+ \ };\
135+ \}" :: Number -> Number -> Number
136+
137+ foreign import numMod "function numMod(n1) {\
138+ \ return function(n2) {\
139+ \ return n1 % n2;\
140+ \ };\
141+ \}" :: Number -> Number -> Number
142+
143+ foreign import numNegate "function numNegate(n) {\
144+ \ return -n;\
145+ \}" :: Number -> Number
146+
147+ instance Num Number where
148+ (+) = numAdd
149+ (-) = numSub
150+ (*) = numMul
151+ (/) = numDiv
152+ (%) = numMod
153+ negate = numNegate
154+
155+ infixl 4 ==
156+ infixl 4 /=
157+
158+ class Eq a where
159+ (==) :: a -> a -> Boolean
160+ (/=) :: a -> a -> Boolean
161+
162+ -- Referential equality
163+ data Ref a = Ref a
164+
165+ foreign import refEq "function refEq(r1) {\
166+ \ return function(r2) {\
167+ \ return r1.values[0] === r2.values[0];\
168+ \ };\
169+ \}" :: forall a. Ref a -> Ref a -> Boolean
170+
171+ foreign import refIneq "function refIneq(r1) {\
172+ \ return function(r2) {\
173+ \ return r1.values[0] !== r2.values[0];\
174+ \ };\
175+ \}" :: forall a. Ref a -> Ref a -> Boolean
176+
177+ foreign import unsafeRefEq "function unsafeRefEq(r1) {\
178+ \ return function(r2) {\
179+ \ return r1 === r2;\
180+ \ };\
181+ \}" :: forall a. a -> a -> Boolean
182+
183+ foreign import unsafeRefIneq "function unsafeRefIneq(r1) {\
184+ \ return function(r2) {\
185+ \ return r1 !== r2;\
186+ \ };\
187+ \}" :: forall a. a -> a -> Boolean
188+
189+ instance Eq (Ref a) where
190+ (==) = refEq
191+ (/=) = refIneq
192+
193+ instance Eq String where
194+ (==) = unsafeRefEq
195+ (/=) = unsafeRefIneq
196+
197+ instance Eq Number where
198+ (==) = unsafeRefEq
199+ (/=) = unsafeRefIneq
200+
201+ instance Eq Boolean where
202+ (==) = unsafeRefEq
203+ (/=) = unsafeRefIneq
204+
205+ instance (Eq a) => Eq [a] where
206+ (==) [] [] = true
207+ (==) (x:xs) (y:ys) = x == y && xs == ys
208+ (==) _ _ = false
209+ (/=) xs ys = not (xs == ys)
210+
211+ infixl 4 <
212+ infixl 4 >
213+ infixl 4 <=
214+ infixl 4 >=
215+
216+ class Ord a where
217+ (<) :: a -> a -> Boolean
218+ (>) :: a -> a -> Boolean
219+ (<=) :: a -> a -> Boolean
220+ (>=) :: a -> a -> Boolean
221+
222+ foreign import numLess "function numLess(n1) {\
223+ \ return function(n2) {\
224+ \ return n1 < n2;\
225+ \ };\
226+ \}" :: Number -> Number -> Boolean
227+
228+ foreign import numLessEq "function numLessEq(n1) {\
229+ \ return function(n2) {\
230+ \ return n1 <= n2;\
231+ \ };\
232+ \}" :: Number -> Number -> Boolean
233+
234+ foreign import numGreater "function numGreater(n1) {\
235+ \ return function(n2) {\
236+ \ return n1 > n2;\
237+ \ };\
238+ \}" :: Number -> Number -> Boolean
239+
240+ foreign import numGreaterEq "function numGreaterEq(n1) {\
241+ \ return function(n2) {\
242+ \ return n1 >= n2;\
243+ \ };\
244+ \}" :: Number -> Number -> Boolean
245+
246+ instance Ord Number where
247+ (<) = numLess
248+ (>) = numGreater
249+ (<=) = numLessEq
250+ (>=) = numGreaterEq
251+
252+ infixl 10 &
253+ infixl 10 |
254+ infixl 10 ^
255+
256+ class Bits b where
257+ (&) :: b -> b -> b
258+ (|) :: b -> b -> b
259+ (^) :: b -> b -> b
260+ shl :: b -> Number -> b
261+ shr :: b -> Number -> b
262+ zshr :: b -> Number -> b
263+ complement :: b -> b
264+
265+ foreign import numShl "function numShl(n1) {\
266+ \ return function(n2) {\
267+ \ return n1 << n2;\
268+ \ };\
269+ \}" :: Number -> Number -> Number
270+
271+ foreign import numShr "function numShr(n1) {\
272+ \ return function(n2) {\
273+ \ return n1 >> n2;\
274+ \ };\
275+ \}" :: Number -> Number -> Number
276+
277+ foreign import numZshr "function numZshr(n1) {\
278+ \ return function(n2) {\
279+ \ return n1 >>> n2;\
280+ \ };\
281+ \}" :: Number -> Number -> Number
282+
283+ foreign import numAnd "function numAnd(n1) {\
284+ \ return function(n2) {\
285+ \ return n1 & n2;\
286+ \ };\
287+ \}" :: Number -> Number -> Number
288+
289+ foreign import numOr "function numOr(n1) {\
290+ \ return function(n2) {\
291+ \ return n1 | n2;\
292+ \ };\
293+ \}" :: Number -> Number -> Number
294+
295+ foreign import numXor "function numXor(n1) {\
296+ \ return function(n2) {\
297+ \ return n1 ^ n2;\
298+ \ };\
299+ \}" :: Number -> Number -> Number
300+
301+ foreign import numComplement "function numComplement(n) {\
302+ \ return ~n;\
303+ \}" :: Number -> Number
304+
305+ instance Bits Number where
306+ (&) = numAnd
307+ (|) = numOr
308+ (^) = numXor
309+ shl = numShl
310+ shr = numShr
311+ zshr = numZshr
312+ complement = numComplement
313+
314+ infixl 8 !!
315+
316+ foreign import (!!) "function $bang$bang(xs) {\
317+ \ return function(n) {\
318+ \ return xs[n];\
319+ \ };\
320+ \}" :: forall a. [a] -> Number -> a
321+
322+ infixr 2 ||
323+ infixr 3 &&
324+
325+ class BoolLike b where
326+ (&&) :: b -> b -> b
327+ (||) :: b -> b -> b
328+ not :: b -> b
329+
330+ foreign import boolAnd "function boolAnd(b1) {\
331+ \ return function(b2) {\
332+ \ return b1 && b2;\
333+ \ };\
334+ \}" :: Boolean -> Boolean -> Boolean
335+
336+ foreign import boolOr "function boolOr(b1) {\
337+ \ return function(b2) {\
338+ \ return b1 || b2;\
339+ \ };\
340+ \}" :: Boolean -> Boolean -> Boolean
341+
342+ foreign import boolNot "function boolNot(b) {\
343+ \ return !b;\
344+ \}" :: Boolean -> Boolean
345+
346+ instance BoolLike Boolean where
347+ (&&) = boolAnd
348+ (||) = boolOr
349+ not = boolNot
350+
351+ infixr 5 ++
352+
353+ foreign import (++) "function $plus$plus(s1) {\
354+ \ return function(s2) {\
355+ \ return s1 + s2;\
356+ \ };\
357+ \}" :: String -> String -> String
358+
359+module Monoid where
360+
361+ import Prelude
362+
363+ infixr 6 <>
364+
365+ class Monoid m where
366+ mempty :: m
367+ (<>) :: m -> m -> m
368+
369+ instance Monoid String where
370+ mempty = ""
371+ (<>) = (++)
372+
373+ instance Monoid [a] where
374+ mempty = []
375+ (<>) = Arrays.concat
376+
377+ mconcat :: forall m. (Monoid m) => [m] -> m
378+ mconcat [] = mempty
379+ mconcat (m:ms) = m <> mconcat ms
380+
381+module Monad where
382+
383+ import Prelude
384+ import Arrays
385+
386+ replicateM :: forall m a. (Monad m) => Number -> m a -> m [a]
387+ replicateM 0 _ = return []
388+ replicateM n m = do
389+ a <- m
390+ as <- replicateM (n - 1) m
391+ return (a : as)
392+
393+ mapM :: forall m a b. (Monad m) => (a -> m b) -> [a] -> m [b]
394+ mapM _ [] = return []
395+ mapM f (a:as) = do
396+ b <- f a
397+ bs <- mapM f as
398+ return (b : bs)
399+
400+ infixr 1 >=>
401+ infixr 1 <=<
402+
403+ (>=>) :: forall m a b c. (Monad m) => (a -> m b) -> (b -> m c) -> a -> m c
404+ (>=>) f g a = do
405+ b <- f a
406+ g b
407+
408+ (<=<) :: forall m a b c. (Monad m) => (b -> m c) -> (a -> m b) -> a -> m c
409+ (<=<) = flip (>=>)
410+
411+ sequence :: forall m a. (Monad m) => [m a] -> m [a]
412+ sequence [] = return []
413+ sequence (m:ms) = do
414+ a <- m
415+ as <- sequence ms
416+ return (a : as)
417+
418+ join :: forall m a. (Monad m) => m (m a) -> m a
419+ join mm = do
420+ m <- mm
421+ m
422+
423+ foldM :: forall m a b. (Monad m) => (a -> b -> m a) -> a -> [b] -> m a
424+ foldM _ a [] = return a
425+ foldM f a (b:bs) = f a b >>= \a' -> foldM f a' bs
426+
427+ when :: forall m. (Monad m) => Boolean -> m {} -> m {}
428+ when true m = m
429+ when false _ = return {}
430+
431+module Maybe where
432+
433+ import Prelude
434+
435+ data Maybe a = Nothing | Just a
436+
437+ maybe :: forall a b. b -> (a -> b) -> Maybe a -> b
438+ maybe b _ Nothing = b
439+ maybe _ f (Just a) = f a
440+
441+ fromMaybe :: forall a. a -> Maybe a -> a
442+ fromMaybe a = maybe a (Prelude.id :: forall a. a -> a)
443+
444+ instance Prelude.Monad Maybe where
445+ return = Just
446+ (>>=) m f = maybe Nothing f m
447+
448+ instance Prelude.Applicative Maybe where
449+ pure = Just
450+ (<*>) (Just fn) x = fn <$> x
451+ (<*>) Nothing _ = Nothing
452+
453+ instance Prelude.Functor Maybe where
454+ (<$>) fn (Just x) = Just (fn x)
455+ (<$>) _ _ = Nothing
456+
457+ instance (Show a) => Prelude.Show (Maybe a) where
458+ show (Just x) = "Just " ++ (show x)
459+ show Nothing = "Nothing"
460+
461+module Either where
462+
463+ import Prelude
464+
465+ data Either a b = Left a | Right b
466+
467+ either :: forall a b c. (a -> c) -> (b -> c) -> Either a b -> c
468+ either f _ (Left a) = f a
469+ either _ g (Right b) = g b
470+
471+ instance Prelude.Monad (Either e) where
472+ return = Right
473+ (>>=) = either (\e _ -> Left e) (\a f -> f a)
474+
475+ instance Prelude.Applicative (Either e) where
476+ pure = Right
477+ (<*>) (Left e) _ = Left e
478+ (<*>) (Right f) r = f <$> r
479+
480+ instance Prelude.Functor (Either a) where
481+ (<$>) _ (Left x) = Left x
482+ (<$>) f (Right y) = Right (f y)
483+
484+ instance (Show a, Show b) => Prelude.Show (Either a b) where
485+ show (Left x) = "Left " ++ (show x)
486+ show (Right y) = "Right " ++ (show y)
487+
488+module Arrays where
489+
490+ import Prelude
491+ import Maybe
492+
493+ head :: forall a. [a] -> a
494+ head (x : _) = x
495+
496+ headSafe :: forall a. [a] -> Maybe a
497+ headSafe (x : _) = Just x
498+ headSafe _ = Nothing
499+
500+ tail :: forall a. [a] -> [a]
501+ tail (_ : xs) = xs
502+
503+ tailSafe :: forall a. [a] -> Maybe [a]
504+ tailSafe (_ : xs) = Just xs
505+ tailSafe _ = Nothing
506+
507+ map :: forall a b. (a -> b) -> [a] -> [b]
508+ map _ [] = []
509+ map f (x:xs) = f x : map f xs
510+
511+ foldr :: forall a b. (a -> b -> a) -> a -> [b] -> a
512+ foldr f a (b : bs) = f (foldr f a bs) b
513+ foldr _ a [] = a
514+
515+ foldl :: forall a b. (a -> b -> b) -> b -> [a] -> b
516+ foldl _ b [] = b
517+ foldl f b (a:as) = foldl f (f a b) as
518+
519+ foreign import length "function length(xs) {\
520+ \ return xs.length;\
521+ \}" :: forall a. [a] -> Number
522+
523+ foreign import indexOf "function indexOf(l) {\
524+ \ return function (e) {\
525+ \ return l.indexOf(e);\
526+ \ };\
527+ \}" :: forall a. [a] -> a -> Number
528+
529+ foreign import lastIndexOf "function lastIndexOf(l) {\
530+ \ return function (e) {\
531+ \ return l.lastIndexOf(e);\
532+ \ };\
533+ \}" :: forall a. [a] -> a -> Number
534+
535+ foreign import concat "function concat(l1) {\
536+ \ return function (l2) {\
537+ \ return l1.concat(l2);\
538+ \ };\
539+ \}" :: forall a. [a] -> [a] -> [a]
540+
541+ foreign import joinS "function joinS(l) {\
542+ \ return l.join();\
543+ \}" :: [String] -> String
544+
545+ foreign import joinWith "function joinWith(l) {\
546+ \ return function (s) {\
547+ \ return l.join(s);\
548+ \ };\
549+ \}" :: [String] -> String -> String
550+
551+ foreign import push "function push(l) {\
552+ \ return function (e) {\
553+ \ var l1 = l.slice();\
554+ \ l1.push(e); \
555+ \ return l1;\
556+ \ };\
557+ \}" :: forall a. [a] -> a -> [a]
558+
559+ foreign import reverse "function reverse(l) {\
560+ \ var l1 = l.slice();\
561+ \ l1.reverse(); \
562+ \ return l1;\
563+ \}" :: forall a. [a] -> [a]
564+
565+ foreign import shift "function shift(l) {\
566+ \ var l1 = l.slice();\
567+ \ l1.shift();\
568+ \ return l1;\
569+ \}" :: forall a. [a] -> [a]
570+
571+ foreign import slice "function slice(s) {\
572+ \ return function(e) {\
573+ \ return function (l) {\
574+ \ return l.slice(s, e);\
575+ \ };\
576+ \ };\
577+ \}" :: forall a. Number -> Number -> [a] -> [a]
578+
579+ foreign import sort "function sort(l) {\
580+ \ var l1 = l.slice();\
581+ \ l1.sort();\
582+ \ return l1;\
583+ \}" :: forall a. [a] -> [a]
584+
585+ foreign import splice "function splice(s) {\
586+ \ return function(e) {\
587+ \ return function(l1) {\
588+ \ return function(l2) {\
589+ \ return l2.splice(s, e, l1);\
590+ \ }; \
591+ \ }; \
592+ \ };\
593+ \}":: forall a. Number -> Number -> [a] -> [a] -> [a]
594+
595+ infixr 6 :
596+
597+ (:) :: forall a. a -> [a] -> [a]
598+ (:) a = concat [a]
599+
600+ singleton :: forall a. a -> [a]
601+ singleton a = [a]
602+
603+ concatMap :: forall a b. [a] -> (a -> [b]) -> [b]
604+ concatMap [] f = []
605+ concatMap (a:as) f = f a `concat` concatMap as f
606+
607+ filter :: forall a. (a -> Boolean) -> [a] -> [a]
608+ filter _ [] = []
609+ filter p (x:xs) | p x = x : filter p xs
610+ filter p (_:xs) = filter p xs
611+
612+ isEmpty :: forall a. [a] -> Boolean
613+ isEmpty [] = true
614+ isEmpty _ = false
615+
616+ range :: Number -> Number -> [Number]
617+ range lo hi | lo > hi = []
618+ range lo hi = lo : range (lo + 1) hi
619+
620+ zipWith :: forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
621+ zipWith f (a:as) (b:bs) = f a b : zipWith f as bs
622+ zipWith _ _ _ = []
623+
624+ any :: forall a. (a -> Boolean) -> [a] -> Boolean
625+ any _ [] = false
626+ any p (a:as) = p a || any p as
627+
628+ all :: forall a. (a -> Boolean) -> [a] -> Boolean
629+ all _ [] = true
630+ all p (a:as) = p a && all p as
631+
632+ instance (Prelude.Show a) => Prelude.Show [a] where
633+ show xs = "[" ++ joinWith (map show xs) "," ++ "]"
634+
635+ instance Prelude.Functor [] where
636+ (<$>) = map
637+
638+ instance Prelude.Monad [] where
639+ return = singleton
640+ (>>=) = concatMap
641+
642+ instance Prelude.Alternative [] where
643+ empty = []
644+ (<|>) = concat
645+
646+module Tuples where
647+
648+ import Prelude
649+ import Arrays
650+
651+ data Tuple a b = Tuple a b
652+
653+ instance (Prelude.Show a, Prelude.Show b) => Prelude.Show (Tuple a b) where
654+ show (Tuple a b) = "Tuple(" ++ show a ++ ", " ++ show b ++ ")"
655+
656+ curry :: forall a b c. (Tuple a b -> c) -> a -> b -> c
657+ curry f a b = f (Tuple a b)
658+
659+ uncurry :: forall a b c. (a -> b -> c) -> Tuple a b -> c
660+ uncurry f (Tuple a b) = f a b
661+
662+ zip :: forall a b. [a] -> [b] -> [Tuple a b]
663+ zip = zipWith Tuple
664+
665+ unzip :: forall a b. [Tuple a b] -> Tuple [a] [b]
666+ unzip ((Tuple a b):ts) = case unzip ts of
667+ Tuple as bs -> Tuple (a : as) (b : bs)
668+ unzip [] = Tuple [] []
669+
670+module String where
671+
672+ foreign import lengthS "function lengthS(s) {\
673+ \ return s.length;\
674+ \}" :: String -> Number
675+
676+ foreign import charAt "function charAt(i) {\
677+ \ return function(s) {\
678+ \ return s.charAt(i); \
679+ \ };\
680+ \}" :: Number -> String -> String
681+
682+ foreign import indexOfS "function indexOfS(s1) {\
683+ \ return function(s2) {\
684+ \ return s1.indexOf(s2);\
685+ \ }; \
686+ \}" :: String -> String -> Number
687+
688+ foreign import lastIndexOfS "function lastIndexOfS(s1) {\
689+ \ return function(s2) {\
690+ \ return s1.lastIndexOf(s2);\
691+ \ };\
692+ \}" :: String -> String -> Number
693+
694+ foreign import localeCompare "function localeCompare(s1) {\
695+ \ return function(s2) {\
696+ \ return s1.localeCompare(s2);\
697+ \ };\
698+ \}" :: String -> String -> Number
699+
700+ foreign import replace "function replace(s1) {\
701+ \ return function(s2) {\
702+ \ return function(s3) {\
703+ \ return s3.replace(s1, s2);\
704+ \ };\
705+ \ };\
706+ \}" :: String -> String -> String -> String
707+
708+ foreign import sliceS "function sliceS(st) {\
709+ \ return function(e) {\
710+ \ return function(s) {\
711+ \ return s.slice(st, e);\
712+ \ };\
713+ \ };\
714+ \}" :: Number -> Number -> String -> String
715+
716+ foreign import split "function split(sep) {\
717+ \ return function(s) {\
718+ \ return s.split(s);\
719+ \ };\
720+ \}" :: String -> String -> [String]
721+
722+ foreign import substr "function substr(n1) {\
723+ \ return function(n2) {\
724+ \ return function(s) {\
725+ \ return s.substr(n1, n2);\
726+ \ };\
727+ \ };\
728+ \}" :: Number -> Number -> String -> String
729+
730+ foreign import substring "function substring(n1) {\
731+ \ return function(n2) {\
732+ \ return function(s) {\
733+ \ return s.substring(n1, n2);\
734+ \ };\
735+ \ };\
736+ \}" :: Number -> Number -> String -> String
737+
738+ foreign import toLower "function toLower(s) {\
739+ \ return s.toLower();\
740+ \}" :: String -> String
741+
742+ foreign import toUpper "function toUpper(s) {\
743+ \ return s.toUpper();\
744+ \}" :: String -> String
745+
746+ foreign import trim "function trim(s) {\
747+ \ return s.trim();\
748+ \}" :: String -> String
749+
750+module Regex where
751+
752+ foreign import data Regex :: *
753+
754+ foreign import regex "function regex(s1) {\
755+ \ return function(s2) {\
756+ \ return new Regex(s1, s2);\
757+ \ };\
758+ \}" :: String -> String -> Regex
759+
760+ foreign import test "function test(r) {\
761+ \ return function (s) {\
762+ \ return r.test(s);\
763+ \ };\
764+ \}" :: Regex -> String -> Boolean
765+
766+ foreign import match "function match(r) {\
767+ \ return function (s) {\
768+ \ return s.match(r); \
769+ \ };\
770+ \}" :: Regex -> String -> [String]
771+
772+ foreign import replaceR "function replaceR(r) {\
773+ \ return function(s1) {\
774+ \ return function(s2) {\
775+ \ return s2.replace(r, s1);\
776+ \ };\
777+ \ };\
778+ \}" :: Regex -> String -> String -> String
779+
780+ foreign import search "function search(r) {\
781+ \ return function (s) {\
782+ \ return s.search(r);\
783+ \ };\
784+ \}" :: Regex -> String -> Number
785+
786+module Global where
787+
788+ foreign import nan "var nan = NaN;" :: Number
789+
790+ foreign import infinity "var infinity = Infinity;" :: Number
791+
792+ foreign import toExponential "function toExponential(n) {\
793+ \ return n.toExponential();\
794+ \}" :: Number -> String
795+
796+ foreign import toFixed "function toFixed(d) {\
797+ \ return function(n) {\
798+ \ return n.toFixed(d);\
799+ \ };\
800+ \}" :: Number -> Number -> String
801+
802+ foreign import toPrecision "function toPrecision(d) {\
803+ \ return function(n) {\
804+ \ return n.toPrecision(d);\
805+ \ };\
806+ \}" :: Number -> Number -> String
807+
808+ foreign import isFinite :: Number -> Boolean
809+
810+ foreign import parseFloat :: String -> Number
811+
812+ foreign import parseInt :: String -> Number
813+
814+ foreign import encodeURIComponent :: String -> String
815+
816+ foreign import decodeURIComponent :: String -> String
817+
818+ foreign import encodeURI :: String -> String
819+
820+ foreign import decodeURI :: String -> String
821+
822+ foreign import isNaN :: Number -> Boolean
823+
824+module Math where
825+
826+ foreign import abs "function abs(n){\
827+ \ return Math.abs(n);\
828+ \}" :: Number -> Number
829+
830+ foreign import acos "function acos(n){\
831+ \ return Math.acos(n);\
832+ \}" :: Number -> Number
833+
834+ foreign import asin "function asin(n){\
835+ \ return Math.asin(n);\
836+ \}" :: Number -> Number
837+
838+ foreign import atan "function atan(n){\
839+ \ return Math.atan(n);\
840+ \}" :: Number -> Number
841+
842+ foreign import atan2 "function atan2(y){\
843+ \ return function (x) {\
844+ \ return Math.atan2(y, x);\
845+ \ };\
846+ \}" :: Number -> Number -> Number
847+
848+ foreign import aceil "function aceil(n){\
849+ \ return Math.aceil(n);\
850+ \}" :: Number -> Number
851+
852+ foreign import cos "function cos(n){\
853+ \ return Math.cos(n);\
854+ \}" :: Number -> Number
855+
856+ foreign import exp "function exp(n){\
857+ \ return Math.exp(n);\
858+ \}" :: Number -> Number
859+
860+ foreign import floor "function floor(n){\
861+ \ return Math.floor(n);\
862+ \}" :: Number -> Number
863+
864+ foreign import log "function log(n){\
865+ \ return Math.log(n);\
866+ \}" :: Number -> Number
867+
868+ foreign import max "function max(n){\
869+ \ return Math.max(n);\
870+ \}" :: Number -> Number
871+
872+ foreign import min "function min(n){\
873+ \ return Math.min(n);\
874+ \}" :: Number -> Number
875+
876+ foreign import pow "function pow(n){\
877+ \ return Math.pow(n);\
878+ \}" :: Number -> Number
879+
880+ foreign import round "function round(n){\
881+ \ return Math.round(n);\
882+ \}" :: Number -> Number
883+
884+ foreign import sin "function sin(n){\
885+ \ return Math.sin(n);\
886+ \}" :: Number -> Number
887+
888+ foreign import sqrt "function sqrt(n){\
889+ \ return Math.sqrt(n);\
890+ \}" :: Number -> Number
891+
892+ foreign import tan "function tan(n){\
893+ \ return Math.tan(n);\
894+ \}" :: Number -> Number
895+
896+ foreign import e "var e = Math.E;" :: Number
897+ foreign import ln2 "var ln2 = Math.LN2;" :: Number
898+ foreign import ln10 "var ln10 = Math.LN10;" :: Number
899+ foreign import log2e "var log2e = Math.LOG2E;" :: Number
900+ foreign import log10e "var log10e = Math.LOG10E;" :: Number
901+ foreign import pi "var pi = Math.PI;" :: Number
902+ foreign import sqrt1_2 "var sqrt1_2 = Math.SQRT1_2;" :: Number
903+ foreign import sqrt2 "var sqrt2 = Math.SQRT2;" :: Number
904+
905+module Eff where
906+
907+ foreign import data Eff :: # ! -> * -> *
908+
909+ foreign import retEff "function retEff(a) {\
910+ \ return function() {\
911+ \ return a;\
912+ \ };\
913+ \}" :: forall e a. a -> Eff e a
914+
915+ foreign import bindEff "function bindEff(a) {\
916+ \ return function(f) {\
917+ \ return function() {\
918+ \ return f(a())();\
919+ \ };\
920+ \ };\
921+ \}" :: forall e a b. Eff e a -> (a -> Eff e b) -> Eff e b
922+
923+ type Pure a = forall e. Eff e a
924+
925+ foreign import runPure "function runPure(f) {\
926+ \ return f();\
927+ \}" :: forall a. Pure a -> a
928+
929+ instance Prelude.Monad (Eff e) where
930+ return = retEff
931+ (>>=) = bindEff
932+
933+ foreign import untilE "function untilE(f) {\
934+ \ return function() {\
935+ \ while (!f()) { }\
936+ \ return {};\
937+ \ };\
938+ \}" :: forall e. Eff e Boolean -> Eff e {}
939+
940+ foreign import whileE "function whileE(f) {\
941+ \ return function(a) {\
942+ \ return function() {\
943+ \ while (f()) {\
944+ \ a();\
945+ \ }\
946+ \ return {};\
947+ \ };\
948+ \ };\
949+ \}" :: forall e a. Eff e Boolean -> Eff e a -> Eff e {}
950+
951+ foreign import forE "function forE(lo) {\
952+ \ return function(hi) {\
953+ \ return function(f) {\
954+ \ return function() {\
955+ \ for (var i = lo; i < hi; i++) {\
956+ \ f(i)();\
957+ \ }\
958+ \ };\
959+ \ };\
960+ \ };\
961+ \}" :: forall e. Number -> Number -> (Number -> Eff e {}) -> Eff e {}
962+
963+
964+ foreign import foreachE "function foreachE(as) {\
965+ \ return function(f) {\
966+ \ for (var i = 0; i < as.length; i++) {\
967+ \ f(as[i])();\
968+ \ }\
969+ \ };\
970+ \}" :: forall e a. [a] -> (a -> Eff e {}) -> Eff e {}
971+
972+
973+module Random where
974+
975+ import Eff
976+
977+ foreign import data Random :: !
978+
979+ foreign import random "function random() {\
980+ \ return Math.random();\
981+ \}" :: forall e. Eff (random :: Random | e) Number
982+
983+module Errors where
984+
985+ import Eff
986+
987+ foreign import data Error :: * -> !
988+
989+ foreign import throwError "function throwError(e) {\
990+ \ return function() {\
991+ \ throw e;\
992+ \ };\
993+ \}" :: forall a e r. e -> Eff (err :: Error e | r) a
994+
995+ foreign import catchError "function catchError(c) {\
996+ \ return function(t) {\
997+ \ return function() {\
998+ \ try {\
999+ \ return t();\
1000+ \ } catch(e) {\
1001+ \ return c(e)();\
1002+ \ }\
1003+ \ };\
1004+ \ };\
1005+ \}" :: forall e r a. (e -> Eff r a) -> Eff (err :: Error e | r) a -> Eff r a
1006+
1007+module IORef where
1008+
1009+ import Eff
1010+
1011+ foreign import data Ref :: !
1012+
1013+ foreign import data IORef :: * -> *
1014+
1015+ foreign import newIORef "function newIORef(val) {\
1016+ \ return function () {\
1017+ \ return { value: val };\
1018+ \ };\
1019+ \}" :: forall s r. s -> Eff (ref :: Ref | r) (IORef s)
1020+
1021+ foreign import readIORef "function readIORef(ref) {\
1022+ \ return function() {\
1023+ \ return ref.value;\
1024+ \ };\
1025+ \}" :: forall s r. IORef s -> Eff (ref :: Ref | r) s
1026+
1027+
1028+ foreign import modifyIORef "function modifyIORef(ref) {\
1029+ \ return function(f) {\
1030+ \ return function() {\
1031+ \ ref.value = f(ref.value);\
1032+ \ return {};\
1033+ \ };\
1034+ \ };\
1035+ \}" :: forall s r. IORef s -> (s -> s) -> Eff (ref :: Ref | r) {}
1036+
1037+ foreign import writeIORef "function writeIORef(ref) {\
1038+ \ return function(val) {\
1039+ \ return function() {\
1040+ \ ref.value = val;\
1041+ \ return {};\
1042+ \ };\
1043+ \ };\
1044+ \}" :: forall s r. IORef s -> s -> Eff (ref :: Ref | r) {}
1045+
1046+ foreign import unsafeRunIORef "function unsafeRunIORef(f) {\
1047+ \ return f;\
1048+ \}" :: forall eff a. Eff (ref :: Ref | eff) a -> Eff eff a
1049+
1050+module Trace where
1051+
1052+ import Prelude
1053+ import Eff
1054+
1055+ foreign import data Trace :: !
1056+
1057+ foreign import trace "function trace(s) {\
1058+ \ return function() {\
1059+ \ console.log(s);\
1060+ \ return {};\
1061+ \ };\
1062+ \}" :: forall r. String -> Eff (trace :: Trace | r) {}
1063+
1064+ print :: forall a r. (Prelude.Show a) => a -> Eff (trace :: Trace | r) {}
1065+ print o = trace (show o)
1066+
1067+module ST where
1068+
1069+ import Eff
1070+
1071+ foreign import data ST :: * -> !
1072+
1073+ foreign import data STRef :: * -> * -> *
1074+
1075+ foreign import data STArray :: * -> * -> *
1076+
1077+ foreign import newSTRef "function newSTRef(val) {\
1078+ \ return function () {\
1079+ \ return { value: val };\
1080+ \ };\
1081+ \}" :: forall a h r. a -> Eff (st :: ST h | r) (STRef h a)
1082+
1083+ foreign import readSTRef "function readSTRef(ref) {\
1084+ \ return function() {\
1085+ \ return ref.value;\
1086+ \ };\
1087+ \}" :: forall a h r. STRef h a -> Eff (st :: ST h | r) a
1088+
1089+ foreign import modifySTRef "function modifySTRef(ref) {\
1090+ \ return function(f) {\
1091+ \ return function() {\
1092+ \ return ref.value = f(ref.value);\
1093+ \ };\
1094+ \ };\
1095+ \}" :: forall a h r. STRef h a -> (a -> a) -> Eff (st :: ST h | r) a
1096+
1097+ foreign import writeSTRef "function writeSTRef(ref) {\
1098+ \ return function(a) {\
1099+ \ return function() {\
1100+ \ return ref.value = a;\
1101+ \ };\
1102+ \ };\
1103+ \}" :: forall a h r. STRef h a -> a -> Eff (st :: ST h | r) a
1104+
1105+ foreign import newSTArray "function newSTArray(len) {\
1106+ \ return function(a) {\
1107+ \ return function() {\
1108+ \ var arr = [];\
1109+ \ for (var i = 0; i < len; i++) {\
1110+ \ arr[i] = a;\
1111+ \ };\
1112+ \ return arr;\
1113+ \ };\
1114+ \ };\
1115+ \}" :: forall a h r. Number -> a -> Eff (st :: ST h | r) (STArray h a)
1116+
1117+ foreign import peekSTArray "function peekSTArray(arr) {\
1118+ \ return function(i) {\
1119+ \ return function() {\
1120+ \ return arr[i];\
1121+ \ };\
1122+ \ };\
1123+ \}" :: forall a h r. STArray h a -> Eff (st :: ST h | r) a
1124+
1125+ foreign import pokeSTArray "function pokeSTArray(arr) {\
1126+ \ return function(i) {\
1127+ \ return function(a) {\
1128+ \ return function() {\
1129+ \ return arr[i] = a;\
1130+ \ };\
1131+ \ };\
1132+ \ };\
1133+ \}" :: forall a h r. STArray h a -> Number -> a -> Eff (st :: ST h | r) a
1134+
1135+ foreign import runST "function runST(f) {\
1136+ \ return f;\
1137+ \}" :: forall a r. (forall h. Eff (st :: ST h | r) a) -> Eff r a
1138+
1139+ foreign import runSTArray "function runSTArray(f) {\
1140+ \ return f;\
1141+ \}" :: forall a r. (forall h. Eff (st :: ST h | r) (STArray h a)) -> Eff r [a]
1142+
prelude/tests/.gitignorenew file+1
@@ -0,0 +1 @@
1+Eff.js
prelude/tests/Eff.pursnew file+60
@@ -0,0 +1,60 @@
1+module Tests where
2+
3+import Prelude
4+import Eff
5+import Errors
6+import Trace
7+import Global
8+
9+test1 n = runPure (catchError (\s -> return 0) $ do
10+ case {} of
11+ _ | n > 10 -> do
12+ throwError "Error!"
13+ _ -> return n)
14+
15+test2 = do
16+ trace "Hello World"
17+ throwError "Error!"
18+
19+test3 n = catchError (\s -> return 0) $ do
20+ case {} of
21+ _ | n > 10 -> do
22+ trace "n > 10"
23+ throwError "Error!"
24+ _ -> return n
25+
26+test4 = do
27+ trace "Hello World!"
28+ return 0
29+
30+test5 _ = do
31+ trace "Hello World!"
32+ test5 {}
33+
34+test6 s = do
35+ trace s
36+ test6 (s ++ " test")
37+
38+import ST
39+
40+test7 _ = do
41+ n <- runST (do
42+ r <- newSTRef 0
43+ modifySTRef r $ \n -> n + 1
44+ readSTRef r)
45+ print n
46+
47+test8 _ = (\_1 _2 -> {}) <$> print "Test" <*> print 8
48+
49+test9 _ = runST (do
50+ r <- newSTRef 1
51+ whileE (return true) $ do
52+ n <- readSTRef r
53+ trace $ "Count " ++ show n
54+ modifySTRef r $ (+) 1)
55+
56+module Main where
57+
58+import Tests
59+
60+main = test5 {}
prelude/tests/build.shnew file+2
@@ -0,0 +1,2 @@
1+psc ../prelude.purs Eff.purs --magic-do --tco --run-main --no-prelude --entry-point Main -o Eff.js
2+
prelude/updateDocs.shnew file+2
@@ -0,0 +1,2 @@
1+../dist/build/docgen/docgen prelude.purs > README.md
2+pandoc -o ../docs/source/prelude.rst README.md
psc/Main.hsnew file+128
@@ -0,0 +1,128 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Main
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+module Main where
16+
17+import qualified Language.PureScript as P
18+import System.Console.CmdTheLine
19+import Control.Applicative
20+import Control.Monad (forM)
21+import System.Exit (exitSuccess, exitFailure)
22+import qualified System.IO.UTF8 as U
23+import Text.Parsec (ParseError)
24+import qualified Paths_purescript as Paths
25+import Data.Version (showVersion)
26+
27+preludeFilename :: IO FilePath
28+preludeFilename = Paths.getDataFileName "prelude/prelude.purs"
29+
30+readInput :: Maybe [FilePath] -> IO (Either ParseError [P.Module])
31+readInput Nothing = getContents >>= return . P.runIndentParser "" P.parseModules
32+readInput (Just input) = fmap (fmap concat . sequence) $ forM input $ \inputFile -> do
33+ text <- U.readFile inputFile
34+ return $ P.runIndentParser inputFile P.parseModules text
35+
36+compile :: P.Options -> Maybe [FilePath] -> Maybe FilePath -> Maybe FilePath -> IO ()
37+compile opts input output externs = do
38+ modules <- readInput input
39+ case modules of
40+ Left err -> do
41+ U.print err
42+ exitFailure
43+ Right ms ->
44+ case P.compile opts ms of
45+ Left err -> do
46+ U.putStrLn err
47+ exitFailure
48+ Right (js, exts, _) -> do
49+ case output of
50+ Just path -> U.writeFile path js
51+ Nothing -> U.putStrLn js
52+ case externs of
53+ Nothing -> return ()
54+ Just filePath -> U.writeFile filePath exts
55+ exitSuccess
56+
57+useStdIn :: Term Bool
58+useStdIn = value . flag $ (optInfo [ "s", "stdin" ])
59+ { optDoc = "Read from standard input" }
60+
61+inputFiles :: Term [FilePath]
62+inputFiles = value $ posAny [] $ posInfo
63+ { posDoc = "The input .ps files" }
64+
65+outputFile :: Term (Maybe FilePath)
66+outputFile = value $ opt Nothing $ (optInfo [ "o", "output" ])
67+ { optDoc = "The output .js file" }
68+
69+externsFile :: Term (Maybe FilePath)
70+externsFile = value $ opt Nothing $ (optInfo [ "e", "externs" ])
71+ { optDoc = "The output .e.ps file" }
72+
73+tco :: Term Bool
74+tco = value $ flag $ (optInfo [ "tco" ])
75+ { optDoc = "Perform tail call optimizations" }
76+
77+performRuntimeTypeChecks :: Term Bool
78+performRuntimeTypeChecks = value $ flag $ (optInfo [ "runtime-type-checks" ])
79+ { optDoc = "Generate runtime type checks" }
80+
81+noPrelude :: Term Bool
82+noPrelude = value $ flag $ (optInfo [ "no-prelude" ])
83+ { optDoc = "Omit the Prelude" }
84+
85+magicDo :: Term Bool
86+magicDo = value $ flag $ (optInfo [ "magic-do" ])
87+ { optDoc = "Overload the do keyword to generate efficient code specifically for the Eff monad." }
88+
89+runMain :: Term (Maybe String)
90+runMain = value $ defaultOpt (Just "Main") Nothing $ (optInfo [ "main" ])
91+ { optDoc = "Generate code to run the main method in the specified module." }
92+
93+noOpts :: Term Bool
94+noOpts = value $ flag $ (optInfo [ "no-opts" ])
95+ { optDoc = "Skip the optimization phase." }
96+
97+browserNamespace :: Term String
98+browserNamespace = value $ opt "PS" $ (optInfo [ "browser-namespace" ])
99+ { optDoc = "Specify the namespace that PureScript modules will be exported to when running in the browser." }
100+
101+dceModules :: Term [String]
102+dceModules = value $ optAll [] $ (optInfo [ "m", "module" ])
103+ { optDoc = "Enables dead code elimination, all code which is not a transitive dependency of a specified module will be removed. This argument can be used multiple times." }
104+
105+options :: Term P.Options
106+options = P.Options <$> tco <*> performRuntimeTypeChecks <*> magicDo <*> runMain <*> noOpts <*> browserNamespace <*> dceModules
107+
108+stdInOrInputFiles :: FilePath -> Term (Maybe [FilePath])
109+stdInOrInputFiles prelude = combine <$> useStdIn <*> (not <$> noPrelude) <*> inputFiles
110+ where
111+ combine False True input = Just (prelude : input)
112+ combine False False input = Just input
113+ combine True _ _ = Nothing
114+
115+term :: FilePath -> Term (IO ())
116+term prelude = compile <$> options <*> stdInOrInputFiles prelude <*> outputFile <*> externsFile
117+
118+termInfo :: TermInfo
119+termInfo = defTI
120+ { termName = "psc"
121+ , version = showVersion $ Paths.version
122+ , termDoc = "Compiles PureScript to Javascript"
123+ }
124+
125+main :: IO ()
126+main = do
127+ prelude <- preludeFilename
128+ run (term prelude, termInfo)
psci/Main.hsnew file+167
@@ -0,0 +1,167 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Main
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+{-# LANGUAGE FlexibleContexts #-}
16+
17+module Main where
18+
19+import Control.Applicative
20+import Control.Monad
21+import Control.Monad.Trans.Class
22+import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
23+
24+import Data.List (nub, isPrefixOf)
25+import Data.Maybe (mapMaybe)
26+import Data.Traversable (traverse)
27+
28+import System.Console.Haskeline
29+import System.Directory (createDirectoryIfMissing, findExecutable)
30+import System.Exit
31+import System.Environment.XDG.BaseDir
32+import System.Process
33+
34+import qualified Language.PureScript as P
35+import qualified Paths_purescript as Paths
36+import qualified System.IO.UTF8 as U (readFile)
37+import qualified Text.Parsec as Parsec (eof)
38+
39+getPreludeFilename :: IO FilePath
40+getPreludeFilename = Paths.getDataFileName "prelude/prelude.purs"
41+
42+options :: P.Options
43+options = P.Options True False True (Just "Main") True "PS" []
44+
45+completion :: [P.Module] -> CompletionFunc IO
46+completion ms = completeWord Nothing " \t\n\r" findCompletions
47+ where
48+ findCompletions :: String -> IO [Completion]
49+ findCompletions str = do
50+ files <- listFiles str
51+ let names = nub [ show qual
52+ | P.Module moduleName ds <- ms
53+ , ident <- mapMaybe getDeclName ds
54+ , qual <- [ P.Qualified Nothing ident
55+ , P.Qualified (Just moduleName) ident]
56+ ]
57+ let matches = filter (isPrefixOf str) names
58+ return $ map simpleCompletion matches ++ files
59+ getDeclName :: P.Declaration -> Maybe P.Ident
60+ getDeclName (P.ValueDeclaration ident _ _ _) = Just ident
61+ getDeclName _ = Nothing
62+
63+createTemporaryModule :: [P.ProperName] -> P.Value -> P.Module
64+createTemporaryModule imports value =
65+ let
66+ moduleName = P.ModuleName [P.ProperName "Main"]
67+ importDecl m = P.ImportDeclaration m Nothing
68+ traceModule = P.ModuleName [P.ProperName "Trace"]
69+ trace = P.Var (P.Qualified (Just traceModule) (P.Ident "print"))
70+ mainDecl = P.ValueDeclaration (P.Ident "main") [] Nothing
71+ (P.Do [ P.DoNotationBind (P.VarBinder (P.Ident "it")) value
72+ , P.DoNotationValue (P.App trace (P.Var (P.Qualified Nothing (P.Ident "it"))) )
73+ ])
74+ in
75+ P.Module moduleName $ map (importDecl . P.ModuleName . return) imports ++ [mainDecl]
76+
77+handleDeclaration :: [P.Module] -> [P.ProperName] -> P.Value -> InputT IO ()
78+handleDeclaration loadedModules imports value = do
79+ let m = createTemporaryModule imports value
80+ case P.compile options (loadedModules ++ [m]) of
81+ Left err -> outputStrLn err
82+ Right (js, _, _) -> do
83+ process <- lift findNodeProcess
84+ result <- lift $ traverse (\node -> readProcessWithExitCode node [] js) process
85+ case result of
86+ Just (ExitSuccess, out, _) -> outputStrLn out
87+ Just (ExitFailure _, _, err) -> outputStrLn err
88+ Nothing -> outputStrLn "Couldn't find node.js"
89+
90+data Command
91+ = Empty
92+ | Expression [String]
93+ | Import String
94+ | LoadModule FilePath
95+ | Reload deriving (Show, Eq)
96+
97+getCommand :: InputT IO Command
98+getCommand = do
99+ firstLine <- getInputLine "> "
100+ case firstLine of
101+ Nothing -> return Empty
102+ Just (':':'i':' ':moduleName) -> return $ Import moduleName
103+ Just (':':'m':' ':modulePath) -> return $ LoadModule modulePath
104+ Just ":r" -> return Reload
105+ Just (':':_) -> outputStrLn "Unknown command" >> getCommand
106+ Just other -> Expression <$> go [other]
107+ where
108+ go ls = do
109+ l <- getInputLine " "
110+ case l of
111+ Nothing -> return $ reverse ls
112+ Just l' -> go (l' : ls)
113+
114+loadModule :: FilePath -> IO (Either String [P.Module])
115+loadModule moduleFile = do
116+ print moduleFile
117+ moduleText <- U.readFile moduleFile
118+ return . either (Left . show) Right $ P.runIndentParser "" P.parseModules moduleText
119+
120+findNodeProcess :: IO (Maybe String)
121+findNodeProcess = runMaybeT . msum $ map (MaybeT . findExecutable) names
122+ where names = ["nodejs", "node"]
123+
124+getHistoryFilename :: IO FilePath
125+getHistoryFilename = do
126+ purescriptConfig <- getUserConfigDir "purescript"
127+ createDirectoryIfMissing True purescriptConfig
128+ getUserConfigFile "purescript" "psci_history"
129+
130+main :: IO ()
131+main = do
132+ preludeFilename <- getPreludeFilename
133+ (Right prelude) <- loadModule preludeFilename
134+ historyFilename <- getHistoryFilename
135+ let settings = defaultSettings {historyFile = Just historyFilename}
136+ runInputT (setComplete (completion prelude) settings) $ do
137+ outputStrLn " ____ ____ _ _ "
138+ outputStrLn "| _ \\ _ _ _ __ ___/ ___| ___ _ __(_)_ __ | |_ "
139+ outputStrLn "| |_) | | | | '__/ _ \\___ \\ / __| '__| | '_ \\| __|"
140+ outputStrLn "| __/| |_| | | | __/___) | (__| | | | |_) | |_ "
141+ outputStrLn "|_| \\__,_|_| \\___|____/ \\___|_| |_| .__/ \\__|"
142+ outputStrLn " |_| "
143+ outputStrLn ""
144+ outputStrLn "Expressions are terminated using Ctrl+D"
145+ go [P.ProperName "Prelude", P.ProperName "Eff"] prelude
146+ where
147+ go imports loadedModules = do
148+ cmd <- getCommand
149+ case cmd of
150+ Empty -> go imports loadedModules
151+ Expression ls -> do
152+ case P.runIndentParser "" (P.whiteSpace *> P.parseValue <* Parsec.eof) (unlines ls) of
153+ Left err -> outputStrLn (show err)
154+ Right decl -> handleDeclaration loadedModules imports decl
155+ go imports loadedModules
156+ Import moduleName -> go (imports ++ [P.ProperName moduleName]) loadedModules
157+ LoadModule moduleFile -> do
158+ ms <- lift $ loadModule moduleFile
159+ case ms of
160+ Left err -> outputStrLn err
161+ Right ms' -> go imports (loadedModules ++ ms')
162+ Reload -> do
163+ preludeFilename <- lift getPreludeFilename
164+ (Right prelude) <- lift $ loadModule preludeFilename
165+ go [P.ProperName "Prelude"] prelude
166+
167+
psgo.cabaldeleted−145
@@ -1,145 +0,0 @@
1−cabal-version: 1.12
2−
3−-- This file has been generated from package.yaml by hpack version 0.35.0.
4−--
5−-- see: https://github.com/sol/hpack
6−
7−name: psgo
8−version: 0.1.0.0
9−description: Please see the README on Github at <https://github.com/andyarvanitis/purescript-native#readme>
10−homepage: https://github.com/andyarvanitis/purescript-native#readme
11−bug-reports: https://github.com/andyarvanitis/purescript-native/issues
12−author: Andy Arvanitis
13−maintainer: example@example.com
14−copyright: 2018 Andy Arvanitis
15−license: BSD3
16−license-file: LICENSE
17−build-type: Simple
18−extra-source-files:
19− README.md
20− ChangeLog.md
21− stack.yaml
22− support/ffi-loader.go
23− support/go.mod.ffi-loader
24− support/go.mod.output
25− support/go.mod.working
26−
27−source-repository head
28− type: git
29− location: https://github.com/andyarvanitis/purescript-native
30−
31−library
32− exposed-modules:
33− CodeGen.IL
34− CodeGen.IL.Common
35− CodeGen.IL.Optimizer
36− CodeGen.IL.Optimizer.Common
37− CodeGen.IL.Optimizer.Inliner
38− CodeGen.IL.Optimizer.MagicDo
39− CodeGen.IL.Optimizer.TCO
40− CodeGen.IL.Printer
41− Tests
42− other-modules:
43− Paths_psgo
44− hs-source-dirs:
45− src
46− default-extensions:
47− ConstraintKinds
48− DataKinds
49− DeriveFunctor
50− EmptyDataDecls
51− FlexibleContexts
52− KindSignatures
53− LambdaCase
54− MultiParamTypeClasses
55− NoImplicitPrelude
56− PatternGuards
57− PatternSynonyms
58− RankNTypes
59− RecordWildCards
60− OverloadedStrings
61− ScopedTypeVariables
62− TupleSections
63− ViewPatterns
64− build-depends:
65− aeson >=1.0 && <1.5
66− , base >=4.7 && <5
67− , base-compat >=0.6.0
68− , bytestring >=0.10.8.2 && <0.11
69− , containers
70− , directory
71− , file-embed
72− , filemanip
73− , filepath
74− , gitrev
75− , monad-parallel >=0.7.2.2 && <0.8
76− , mtl >=2.1.0 && <2.3.0
77− , pattern-arrows >=0.0.2 && <0.1
78− , process
79− , protolude >=0.1.6
80− , purescript
81− , safe >=0.3.9 && <0.4
82− , text
83− , transformers >=0.3.0 && <0.6
84− default-language: Haskell2010
85−
86−executable psgo
87− main-is: Main.hs
88− other-modules:
89− Paths_psgo
90− hs-source-dirs:
91− app
92− ghc-options: -threaded -rtsopts -with-rtsopts=-N
93− build-depends:
94− aeson >=1.0 && <1.5
95− , base >=4.7 && <5
96− , base-compat >=0.6.0
97− , bytestring >=0.10.8.2 && <0.11
98− , containers
99− , directory
100− , file-embed
101− , filemanip
102− , filepath
103− , gitrev
104− , monad-parallel >=0.7.2.2 && <0.8
105− , mtl >=2.1.0 && <2.3.0
106− , pattern-arrows >=0.0.2 && <0.1
107− , process
108− , protolude >=0.1.6
109− , psgo
110− , purescript
111− , safe >=0.3.9 && <0.4
112− , text
113− , transformers >=0.3.0 && <0.6
114− default-language: Haskell2010
115−
116−test-suite psgo-test
117− type: exitcode-stdio-1.0
118− main-is: Spec.hs
119− other-modules:
120− Paths_psgo
121− hs-source-dirs:
122− test
123− ghc-options: -threaded -rtsopts -with-rtsopts=-N
124− build-depends:
125− aeson >=1.0 && <1.5
126− , base >=4.7 && <5
127− , base-compat >=0.6.0
128− , bytestring >=0.10.8.2 && <0.11
129− , containers
130− , directory
131− , file-embed
132− , filemanip
133− , filepath
134− , gitrev
135− , monad-parallel >=0.7.2.2 && <0.8
136− , mtl >=2.1.0 && <2.3.0
137− , pattern-arrows >=0.0.2 && <0.1
138− , process
139− , protolude >=0.1.6
140− , psgo
141− , purescript
142− , safe >=0.3.9 && <0.4
143− , text
144− , transformers >=0.3.0 && <0.6
145− default-language: Haskell2010
purescript.cabalnew file+107
@@ -0,0 +1,107 @@
1+name: purescript
2+version: 0.4.1
3+cabal-version: >=1.8
4+build-type: Simple
5+license: MIT
6+license-file: LICENSE
7+copyright: (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
8+maintainer: Phil Freeman <paf31@cantab.net>
9+stability: experimental
10+synopsis: PureScript Programming Language Compiler
11+description: A small compile-to-JS language with extensible records and type-safe blocks
12+category: Language
13+author: Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>
14+data-files: prelude/prelude.purs
15+data-dir: ""
16+
17+library
18+ build-depends: base >=4 && <5, cmdtheline -any, containers -any,
19+ directory -any, filepath -any, mtl -any, parsec -any, syb -any,
20+ transformers -any, utf8-string -any, pattern-arrows -any, monad-unify >= 0.2 && < 0.3
21+ exposed-modules: Data.Generics.Extras
22+ Language.PureScript
23+ Language.PureScript.Options
24+ Language.PureScript.Declarations
25+ Language.PureScript.Kinds
26+ Language.PureScript.Names
27+ Language.PureScript.Types
28+ Language.PureScript.Values
29+ Language.PureScript.Scope
30+ Language.PureScript.DeadCodeElimination
31+ Language.PureScript.Sugar
32+ Language.PureScript.ModuleDependencies
33+ Language.PureScript.Sugar.CaseDeclarations
34+ Language.PureScript.Sugar.DoNotation
35+ Language.PureScript.Sugar.TypeDeclarations
36+ Language.PureScript.Sugar.BindingGroups
37+ Language.PureScript.Sugar.Operators
38+ Language.PureScript.Sugar.TypeClasses
39+ Language.PureScript.Sugar.Let
40+ Language.PureScript.CodeGen
41+ Language.PureScript.CodeGen.Common
42+ Language.PureScript.CodeGen.Externs
43+ Language.PureScript.CodeGen.JS
44+ Language.PureScript.CodeGen.JS.AST
45+ Language.PureScript.CodeGen.Monad
46+ Language.PureScript.CodeGen.Optimize
47+ Language.PureScript.Parser
48+ Language.PureScript.Parser.Common
49+ Language.PureScript.Parser.Declarations
50+ Language.PureScript.Parser.Kinds
51+ Language.PureScript.Parser.State
52+ Language.PureScript.Parser.Types
53+ Language.PureScript.Parser.Values
54+ Language.PureScript.Pretty
55+ Language.PureScript.Pretty.Common
56+ Language.PureScript.Pretty.JS
57+ Language.PureScript.Pretty.Kinds
58+ Language.PureScript.Pretty.Types
59+ Language.PureScript.Pretty.Values
60+ Language.PureScript.TypeChecker
61+ Language.PureScript.TypeChecker.Kinds
62+ Language.PureScript.TypeChecker.Monad
63+ Language.PureScript.TypeChecker.Synonyms
64+ Language.PureScript.TypeChecker.Types
65+ exposed: True
66+ buildable: True
67+ hs-source-dirs: src
68+ other-modules:
69+
70+executable psc
71+ build-depends: base >=4 && <5, cmdtheline -any, containers -any,
72+ directory -any, filepath -any, mtl -any, parsec -any,
73+ purescript -any, syb -any, transformers -any, utf8-string -any
74+ main-is: Main.hs
75+ buildable: True
76+ hs-source-dirs: psc
77+ other-modules:
78+ ghc-options: -Wall -O2 -fno-warn-unused-do-bind
79+
80+executable psci
81+ build-depends: base >=4 && <5, containers -any, directory -any,
82+ mtl -any, parsec -any, haskeline <=0.7.1.1, purescript -any,
83+ syb -any, transformers -any, utf8-string -any, process -any,
84+ xdg-basedir -any
85+ main-is: Main.hs
86+ buildable: True
87+ hs-source-dirs: psci
88+ other-modules:
89+ ghc-options: -Wall -O2
90+
91+executable docgen
92+ build-depends: base >=4 && <5, cmdtheline -any, purescript -any, utf8-string -any,
93+ process -any, mtl -any
94+ main-is: Main.hs
95+ buildable: True
96+ hs-source-dirs: docgen
97+ other-modules:
98+ ghc-options: -Wall -O2
99+
100+test-suite tests
101+ build-depends: base >=4 && <5, containers -any, directory -any,
102+ filepath -any, mtl -any, parsec -any, purescript -any, syb -any,
103+ transformers -any, utf8-string -any, process -any
104+ type: exitcode-stdio-1.0
105+ main-is: Main.hs
106+ buildable: True
107+ hs-source-dirs: tests
src/CodeGen/IL.hsdeleted−321
@@ -1,321 +0,0 @@
1−-- | This module generates code in the core imperative representation from
2−-- elaborated PureScript code.
3−module CodeGen.IL
4− ( module AST
5− , module Common
6− , moduleToIL
7− ) where
8−
9−import Prelude.Compat
10−import Protolude (ordNub)
11−
12−import Control.Arrow ((&&&))
13−import Control.Monad (forM, liftM, replicateM, void)
14−import Control.Monad.Supply.Class
15−
16−import Data.List ((\\), delete, intersect, nub)
17−import qualified Data.Foldable as F
18−import qualified Data.Map as M
19−import Data.Maybe (fromMaybe, isNothing, mapMaybe)
20−import Data.Monoid ((<>))
21−import Data.String (fromString)
22−import Data.Text (Text)
23−import qualified Data.Text as T
24−
25−import Language.PureScript.AST.SourcePos
26−import Language.PureScript.CoreImp.AST (AST)
27−import qualified Language.PureScript.CoreImp.AST as AST
28−import Language.PureScript.CoreFn
29−import Language.PureScript.Crash
30−import Language.PureScript.Names
31−import Language.PureScript.Options
32−import Language.PureScript.PSString (PSString, mkString)
33−import Language.PureScript.Traversals (sndM)
34−import qualified Language.PureScript.Constants as C
35−
36−import System.FilePath.Posix ((</>))
37−
38−import CodeGen.IL.Common as Common
39−import CodeGen.IL.Optimizer
40−import CodeGen.IL.Printer
41−
42−data DeclType = ModuleDecl | LetDecl | RecLetDecl deriving (Eq)
43−
44−-- | Generate code in the simplified intermediate representation for all declarations in a
45−-- module.
46−moduleToIL
47− :: forall m
48− -- . (Monad m, MonadReader Options m, MonadSupply m, MonadError MultipleErrors m)
49− . (Monad m, MonadSupply m)
50− => Module Ann
51− -> Text
52− -> m (Text, [Text], [AST], Text, Text)
53−moduleToIL (Module _ coms mn _ imps _ foreigns decls) project =
54− do
55− ilDecls <- mapM (bindToIL ModuleDecl) decls
56− optimized <- traverse (traverse (optimize modName')) ilDecls
57− let optimized' = concat optimized
58− values = annotValue <$> optimized'
59− foreigns' = moduleIdentToIL <$> foreigns
60− interface = interfaceSource modName values foreigns
61− imports = nub . concat $ importToIL <$> optimized'
62− implHeader = implHeaderSource modName imports project
63− implFooter = implFooterSource (runModuleName mn) foreigns
64− return $ (interface, foreigns', optimized', implHeader, implFooter)
65− where
66− modName = moduleNameToIL mn
67− modName' = AST.Var Nothing modName
68−
69− annotValue :: AST -> (Text, Bool)
70− annotValue (AST.Function _ (Just name) [] (AST.Block _ [AST.Return _ ret]))
71− | isLiteral ret = (name, True)
72− annotValue (AST.Function _ (Just name) [] _) = (name, False)
73− annotValue _ = error "Unexpected top-level value form"
74−
75− -- | Extracts all declaration names from a binding group.
76− getNames :: Bind Ann -> [Ident]
77− getNames (NonRec _ ident _) = [ident]
78− getNames (Rec vals) = map (snd . fst) vals
79−
80− -- | Generates IL code for a module import
81− --
82− importToIL :: AST -> [Text]
83− importToIL = AST.everything (++) modRef
84− where
85− modRef (AST.Indexer _ (AST.Var _ _) (AST.Var _ mname))
86− | not $ T.null mname = [extract mname]
87− modRef _ = []
88− extract :: Text -> Text
89− extract = T.replace "_" "." . T.dropWhileEnd (=='_')
90−
91− -- |
92− -- Generate code in the simplified intermediate representation for a declaration
93− --
94− bindToIL :: DeclType -> Bind Ann -> m [AST]
95− bindToIL dt (NonRec ann ident val) = return <$> nonRecToIL dt ann ident val
96− bindToIL dt (Rec vals) = forM vals (uncurry . uncurry $ nonRecToIL dt')
97− where
98− dt' = if dt == LetDecl then RecLetDecl else dt
99−
100− -- | Generate code in the simplified intermediate representation for a single non-recursive
101− -- declaration.
102− --
103− -- The main purpose of this function is to handle code generation for comments.
104− nonRecToIL :: DeclType -> Ann -> Ident -> Expr Ann -> m AST
105− nonRecToIL dt a i e@(extractAnn -> (_, com, _, _)) | not (null com) = do
106− -- withoutComment <- asks optionsNoComments
107− let withoutComment = False
108− if withoutComment
109− then nonRecToIL dt a i (modifyAnn removeComments e)
110− else AST.Comment Nothing com <$> nonRecToIL dt a i (modifyAnn removeComments e)
111− nonRecToIL ModuleDecl (ss, _, _, _) ident val = do
112− il <- valueToIL val
113− pure $ AST.Function Nothing (Just $ moduleIdentToIL ident) [] (AST.Block Nothing [AST.Return Nothing il])
114− nonRecToIL RecLetDecl (ss, _, _, _) ident val = do
115− ilExpr <- valueToIL val
116− pure $ AST.Assignment Nothing (AST.Var Nothing $ identToIL ident) ilExpr
117− nonRecToIL _ (ss, _, _, _) ident val = do
118− il <- valueToIL val
119− pure $ AST.VariableIntroduction Nothing (identToIL ident) (Just il)
120−
121− -- | Generate code in the simplified intermediate representation for a variable based on a
122− -- PureScript identifier.
123− var :: Ident -> AST
124− var = AST.Var Nothing . identToIL
125−
126− accessorString :: PSString -> AST -> AST
127− accessorString prop = AST.Indexer Nothing (AST.StringLiteral Nothing prop)
128−
129− -- | Generate code in the simplified intermediate representation for a value or expression.
130−
131− valueToIL :: Expr Ann -> m AST
132− valueToIL (Literal (pos, _, _, _) l) = literalToValueIL pos l
133− valueToIL (Accessor _ prop val) =
134− accessorString prop <$> valueToIL val
135− valueToIL (ObjectUpdate _ o ps) = do
136− obj <- valueToIL o
137− updates <- mapM (sndM valueToIL) ps
138− obj' <- freshName'
139− let objVar = AST.Var Nothing obj'
140− copy = AST.VariableIntroduction Nothing obj' (Just $ copyDict obj)
141− assign (k, v) = AST.Assignment Nothing (accessorString k objVar) v
142− sts = copy : (assign <$> updates) ++ [AST.Return Nothing objVar]
143− return $ AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing sts)) []
144− valueToIL (Abs _ arg val) = do
145− ret <- valueToIL val
146− let ilArg = case arg of
147− UnusedIdent -> []
148− _ -> [identToIL arg]
149− return $ AST.Function Nothing Nothing ilArg (AST.Block Nothing [AST.Return Nothing ret])
150− valueToIL e@App{} = do
151− let (f, args) = unApp e []
152− args' <- mapM valueToIL args
153− fn <- valueToIL f
154− case f of
155− Var (_, _, _, Just IsNewtype) _ -> return (head args')
156− _ -> flip (foldl (\fn a -> AST.App Nothing fn [a])) args' <$> valueToIL f
157− where
158− unApp :: Expr Ann -> [Expr Ann] -> (Expr Ann, [Expr Ann])
159− unApp (App _ val arg) args = unApp val (arg : args)
160− unApp other args = (other, args)
161− valueToIL (Var _ ident) = return $ varToIL ident
162− valueToIL (Case (ss, _, _, _) values binders) = do
163− vals <- mapM valueToIL values
164− bindersToIL ss binders vals
165− valueToIL (Let _ ds val) = do
166− let recurs = concatMap getNames $ filter isRec ds
167− recurDs = (\v -> AST.VariableIntroduction Nothing (identToIL v) Nothing) <$> recurs
168− ds' <- concat <$> mapM (bindToIL LetDecl) ds
169− ret <- valueToIL val
170− return $ AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing (recurDs ++ ds' ++ [AST.Return Nothing ret]))) []
171− where
172− isRec :: Bind Ann -> Bool
173− isRec (Rec _) = True
174− isRec _ = False
175− valueToIL (Constructor (_, _, _, Just IsNewtype) _ (ProperName ctor) _) = error "IsNewtype"
176− valueToIL (Constructor _ _ (ProperName ctor) fields) =
177− let body = AST.ObjectLiteral Nothing $ (mkString ctor, AST.BooleanLiteral Nothing True) :
178− ((\field -> (mkString (identToIL field), var field)) `map` fields)
179− fn = foldr (\f inner -> AST.Function Nothing Nothing [identToIL f] (AST.Block Nothing [AST.Return Nothing inner])) body fields
180− in return fn
181−
182−
183− iife :: Text -> [AST] -> AST
184− iife v exprs = AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing $ exprs ++ [AST.Return Nothing $ AST.Var Nothing v])) []
185−
186− literalToValueIL :: SourceSpan -> Literal (Expr Ann) -> m AST
187− literalToValueIL ss (NumericLiteral (Left i)) = return $ AST.NumericLiteral (Just ss) (Left i)
188− literalToValueIL ss (NumericLiteral (Right n)) = return $ AST.NumericLiteral (Just ss) (Right n)
189− literalToValueIL ss (StringLiteral s) = return $ AST.StringLiteral (Just ss) s
190− literalToValueIL ss (CharLiteral c) = return $ AST.StringLiteral (Just ss) (fromString [c])
191− literalToValueIL ss (BooleanLiteral b) = return $ AST.BooleanLiteral (Just ss) b
192− literalToValueIL ss (ArrayLiteral xs) = AST.ArrayLiteral (Just ss) <$> mapM valueToIL xs
193− literalToValueIL ss (ObjectLiteral ps) = AST.ObjectLiteral (Just ss) <$> mapM (sndM valueToIL) ps
194−
195− -- | Generate code in the simplified intermediate representation for a reference to a
196− -- variable.
197− varToIL :: Qualified Ident -> AST
198− varToIL (Qualified Nothing ident) = var ident
199− varToIL qual = qualifiedToIL id qual
200−
201− -- | Generate code in the simplified intermediate representation for a reference to a
202− -- variable that may have a qualified name.
203− qualifiedToIL :: (a -> Ident) -> Qualified a -> AST
204− qualifiedToIL f (Qualified (Just (ModuleName mn')) a) | mn' == C.prim = AST.Var Nothing . moduleIdentToIL $ f a
205− qualifiedToIL f (Qualified (Just mn') a) | mn /= mn' = AST.Indexer Nothing (AST.Var Nothing . moduleIdentToIL $ f a) (AST.Var Nothing (moduleNameToIL mn'))
206− qualifiedToIL f (Qualified _ a) = AST.Indexer Nothing (AST.Var Nothing . moduleIdentToIL $ f a) (AST.Var Nothing "")
207−
208− -- foreignIdent :: Ident -> AST
209− -- foreignIdent ident = accessorString (mkString $ runIdent ident) (AST.Var Nothing "$foreign")
210−
211− -- | Generate code in the simplified intermediate representation for pattern match binders
212− -- and guards.
213− bindersToIL :: SourceSpan -> [CaseAlternative Ann] -> [AST] -> m AST
214− bindersToIL ss binders vals = do
215− valNames <- replicateM (length vals) freshName'
216− let assignments = zipWith (AST.VariableIntroduction Nothing) valNames (map Just vals)
217− ils <- forM binders $ \(CaseAlternative bs result) -> do
218− ret <- guardsToIL result
219− go valNames ret bs
220− return $ AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing (assignments ++ concat ils ++ [AST.Throw Nothing (AST.StringLiteral Nothing $ mkString failedPatternMessage)])))
221− []
222− where
223− go :: [Text] -> [AST] -> [Binder Ann] -> m [AST]
224− go _ done [] = return done
225− go (v:vs) done' (b:bs) = do
226− done'' <- go vs done' bs
227− binderToIL v done'' b
228− go _ _ _ = internalError "Invalid arguments to bindersToIL"
229−
230− failedPatternMessage :: Text
231− failedPatternMessage = "Failed pattern match at " <> runModuleName mn <> " " <> displayStartEndPos ss
232−
233− guardsToIL :: Either [(Guard Ann, Expr Ann)] (Expr Ann) -> m [AST]
234− guardsToIL (Left gs) = traverse genGuard gs where
235− genGuard (cond, val) = do
236− cond' <- valueToIL cond
237− val' <- valueToIL val
238− return
239− (AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo cond' (AST.BooleanLiteral Nothing True))
240− (AST.Block Nothing [AST.Return Nothing val']) Nothing)
241−
242− guardsToIL (Right v) = return . AST.Return Nothing <$> valueToIL v
243−
244− -- | Generate code in the simplified intermediate representation for a pattern match
245− -- binder.
246− binderToIL :: Text -> [AST] -> Binder Ann -> m [AST]
247− binderToIL _ done NullBinder{} = return done
248− binderToIL varName done (LiteralBinder _ l) =
249− literalToBinderIL varName done l
250− binderToIL varName done (VarBinder _ ident) =
251− return (AST.VariableIntroduction Nothing (identToIL ident) (Just (AST.Var Nothing varName)) : done)
252− binderToIL varName done (ConstructorBinder (_, _, _, Just IsNewtype) _ _ [b]) =
253− binderToIL varName done b
254− binderToIL varName done (ConstructorBinder (_, _, _, Just (IsConstructor ctorType fields)) _ (Qualified _ (ProperName ctor)) bs) = do
255− il <- go (zip fields bs) done
256− return $ case ctorType of
257− ProductType -> il
258− SumType ->
259− [AST.IfElse Nothing (AST.InstanceOf Nothing (AST.Var Nothing varName) (AST.StringLiteral Nothing (mkString ctor)))
260− (AST.Block Nothing il)
261− Nothing]
262− where
263− go :: [(Ident, Binder Ann)] -> [AST] -> m [AST]
264− go [] done' = return done'
265− go ((field, binder) : remain) done' = do
266− argVar <- freshName'
267− done'' <- go remain done'
268− il <- binderToIL argVar done'' binder
269− return (AST.VariableIntroduction Nothing argVar (Just $ accessorString (mkString $ identToIL field) $ AST.Var Nothing varName) : il)
270−
271− binderToIL _ _ ConstructorBinder{} =
272− internalError "binderToIL: Invalid ConstructorBinder in binderToIL"
273− binderToIL varName done (NamedBinder _ ident binder) = do
274− il <- binderToIL varName done binder
275− return (AST.VariableIntroduction Nothing (identToIL ident) (Just (AST.Var Nothing varName)) : il)
276−
277− literalToBinderIL :: Text -> [AST] -> Literal (Binder Ann) -> m [AST]
278− literalToBinderIL varName done (NumericLiteral num) =
279− return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.NumericLiteral Nothing num)) (AST.Block Nothing done) Nothing]
280− literalToBinderIL varName done (CharLiteral c) =
281− return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.StringLiteral Nothing (fromString [c]))) (AST.Block Nothing done) Nothing]
282− literalToBinderIL varName done (StringLiteral str) =
283− return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.StringLiteral Nothing str)) (AST.Block Nothing done) Nothing]
284− literalToBinderIL varName done (BooleanLiteral True) =
285− return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.BooleanLiteral Nothing True)) (AST.Block Nothing done) Nothing]
286− literalToBinderIL varName done (BooleanLiteral False) =
287− return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.BooleanLiteral Nothing False)) (AST.Block Nothing done) Nothing]
288− -- return [AST.IfElse Nothing (AST.Unary Nothing AST.Not (AST.Var Nothing varName)) (AST.Block Nothing done) Nothing]
289− literalToBinderIL varName done (ObjectLiteral bs) = go done bs
290− where
291− go :: [AST] -> [(PSString, Binder Ann)] -> m [AST]
292− go done' [] = return done'
293− go done' ((prop, binder):bs') = do
294− propVar <- freshName'
295− done'' <- go done' bs'
296− il <- binderToIL propVar done'' binder
297− return (AST.VariableIntroduction Nothing propVar (Just (accessorString prop (AST.Var Nothing varName))) : il)
298− literalToBinderIL varName done (ArrayLiteral bs) = do
299− il <- go done 0 bs
300− return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo
301− (arrayLength $ AST.Var Nothing varName)
302− (AST.NumericLiteral Nothing (Left (fromIntegral $ length bs))))
303− (AST.Block Nothing il) Nothing]
304− where
305− go :: [AST] -> Integer -> [Binder Ann] -> m [AST]
306− go done' _ [] = return done'
307− go done' index (binder:bs') = do
308− elVar <- freshName'
309− done'' <- go done' (index + 1) bs'
310− il <- binderToIL elVar done'' binder
311− return (AST.VariableIntroduction Nothing elVar (Just (AST.Indexer Nothing (AST.NumericLiteral Nothing (Left index)) (AST.Var Nothing varName))) : il)
312−
313−emptyAnn :: Ann
314−emptyAnn = (SourceSpan "" (SourcePos 0 0) (SourcePos 0 0), [], Nothing, Nothing)
315−
316−arrayLength :: AST -> AST
317−arrayLength a = AST.App Nothing (AST.Var Nothing arrayLengthFn) [a]
318−-- arrayLength a = AST.Var Nothing (arrayLengthFn <> "(" <> prettyPrintIL1 a <> ")")
319−
320−copyDict :: AST -> AST
321−copyDict a = AST.App Nothing (AST.Var Nothing copyDictFn) [a]
src/CodeGen/IL/Common.hsdeleted−196
@@ -1,196 +0,0 @@
1−-- | Common code generation utility functions
2−module CodeGen.IL.Common where
3−
4−import Prelude.Compat
5−
6−import Control.Monad.Supply.Class (MonadSupply, freshName)
7−import Data.Char
8−import Data.Maybe (maybe)
9−import Data.Monoid ((<>))
10−import Data.Text (Text)
11−import qualified Data.Text as T
12−
13−import Language.PureScript.Crash
14−import Language.PureScript.Names
15−
16−import qualified Language.PureScript.Constants as C
17−
18−moduleNameToIL :: ModuleName -> Text
19−moduleNameToIL (ModuleName mn) =
20− let name = T.replace "." "_" mn
21− in if nameIsILBuiltIn name then (name <> moduleRenamerMarker) else name
22−
23−moduleNameToIL' :: ModuleName -> Text
24−moduleNameToIL' (ModuleName mn) = T.replace "_" "." mn
25−
26−-- | Convert an 'Ident' into a valid IL identifier:
27−--
28−-- * Alphanumeric characters are kept unmodified.
29−--
30−-- * Reserved IL identifiers are wrapped with '_'.
31−--
32−identToIL :: Ident -> Text
33−identToIL UnusedIdent = unusedName
34−identToIL (Ident "$__unused") = unusedName
35−identToIL (Ident name) | name == C.undefined = undefinedName -- Note: done in Printer.hs too
36−identToIL (Ident name) = properToIL name
37−identToIL (GenIdent _ _) = internalError "GenIdent in identToIL"
38−
39−moduleIdentToIL :: Ident -> Text
40−moduleIdentToIL UnusedIdent = unusedName
41−moduleIdentToIL (Ident name) | name == C.undefined = undefinedName
42−moduleIdentToIL (Ident name) = moduleProperToIL name
43−moduleIdentToIL (GenIdent _ _) = internalError "GenIdent in identToIL"
44−
45−undefinedName :: Text
46−undefinedName = "Undefined"
47−
48−unusedName :: Text
49−unusedName = "_"
50−
51−properToIL :: Text -> Text
52−properToIL name
53− | nameIsILReserved name = "ˉ" <> name
54− | otherwise = T.concatMap identCharToText name
55−
56−-- | Attempts to find a human-readable name for a symbol, if none has been specified returns the
57−-- ordinal value.
58−identCharToText :: Char -> Text
59−identCharToText 'ṩ' = "_ṩ"
60−identCharToText c | isAlphaNum c = T.singleton c
61−identCharToText '_' = "_"
62−identCharToText '\'' = "ꞌ" -- lowercase saltillo
63−identCharToText c = error (show (ord c)) -- TODO: should never occur now(?)
64−
65−moduleProperToIL :: Text -> Text
66−moduleProperToIL = T.concatMap identCharToText
67−
68−-- | Checks whether an identifier name is reserved in IL.
69−nameIsILReserved :: Text -> Bool
70−nameIsILReserved name =
71− name `elem` ilAnyReserved
72−
73−-- | Checks whether a name matches a built-in value in IL.
74−nameIsILBuiltIn :: Text -> Bool
75−nameIsILBuiltIn name =
76− name `elem`
77− [ "Any"
78− , "Apply"
79− , "Contains"
80− , "CopyDict"
81− , "Dict"
82− , "EffFn"
83− , "Fn"
84− , "Foreign"
85− , "Get"
86− , "Index"
87− , "Is"
88− , "Length"
89− , "Once"
90− , "Run"
91− , "Undefined"
92− ]
93−
94−ilAnyReserved :: [Text]
95−ilAnyReserved =
96− concat
97− [ ilKeywords
98− , ilLiterals
99− ]
100−
101−ilKeywords :: [Text]
102−ilKeywords =
103− [ "break"
104− , "case"
105− , "chan"
106− , "const"
107− , "continue"
108− , "default"
109− , "defer"
110− , "else"
111− , "fallthrough"
112− , "for"
113− , "func"
114− , "go"
115− , "goto"
116− , "if"
117− , "import"
118− , "interface"
119− , "map"
120− , "package"
121− , "range"
122− , "return"
123− , "select"
124− , "struct"
125− , "switch"
126− , "type"
127− , "var"
128− ]
129−
130−ilLiterals :: [Text]
131−ilLiterals =
132− [ "init"
133− , "nil"
134− , "int"
135− , "int8"
136− , "int16"
137− , "int32"
138− , "int64"
139− , "uint"
140− , "uint8"
141− , "uint16"
142− , "uint32"
143− , "uint64"
144− , "uintptr"
145− , "float32"
146− , "float64"
147− , "complex64"
148− , "complex128"
149− , "byte"
150− , "rune"
151− , "string"
152− ]
153−
154−withPrefix :: Text -> Text
155−withPrefix s = "Ꞌ" <> s -- uppercase saltillo
156−
157−anyType :: Text
158−anyType = "Any"
159−
160−dictType :: Text
161−dictType = "Dict"
162−
163−arrayType :: Text
164−arrayType = "[]" <> anyType
165−
166−uncurriedFnType :: Int -> Text
167−uncurriedFnType i = "Fn" <> (T.pack . show $ i)
168−
169−int :: Text
170−int = "int"
171−
172−float :: Text
173−float = "float64"
174−
175−bool :: Text
176−bool = "bool"
177−
178−string :: Text
179−string = "string"
180−
181−arrayLengthFn :: Text
182−arrayLengthFn = "Length"
183−
184−indexFn :: Text
185−indexFn = "Index"
186−
187−copyDictFn :: Text
188−copyDictFn = "CopyDict"
189−
190−freshName' :: MonadSupply m => m Text
191−freshName' = do
192− name <- freshName
193− return $ T.replace "$" "ṩ" name
194−
195−moduleRenamerMarker :: Text
196−moduleRenamerMarker = "__"
src/CodeGen/IL/Optimizer.hsdeleted−81
@@ -1,81 +0,0 @@
1−-- | This module optimizes code in the intermediate representation.
2−module CodeGen.IL.Optimizer (optimize) where
3−
4−import Prelude.Compat
5−
6−import Control.Monad.Supply.Class (MonadSupply)
7−import Data.Text (Text)
8−import Language.PureScript.CoreImp.AST
9−import Language.PureScript.CoreImp.Optimizer.Blocks
10−import Language.PureScript.CoreImp.Optimizer.Common hiding (isDict)
11−import Language.PureScript.CoreImp.Optimizer.Inliner (etaConvert, evaluateIifes, inlineVariables, unThunk)
12−import Language.PureScript.CoreImp.Optimizer.Unused
13−
14−import CodeGen.IL.Common (unusedName)
15−import CodeGen.IL.Optimizer.Inliner
16−import CodeGen.IL.Optimizer.MagicDo
17−import CodeGen.IL.Optimizer.TCO
18−
19−import qualified Language.PureScript.Constants as C
20−
21−-- | Apply a series of optimizer passes to simplified IL code
22−optimize :: MonadSupply m => AST -> AST -> m AST
23−optimize mn il = do
24− il' <- untilFixedPoint (inlineFnComposition . inlineUnsafeCoerce . inlineUnsafePartial . tidyUp) il
25− il'' <- untilFixedPoint (return . ignoreUnusedResults . inlineCommonValues . inlineCommonOperators . tidyUp) . tco mn . inlineST
26− =<< untilFixedPoint (return . magicDoST)
27− =<< untilFixedPoint (return . magicDoEff)
28− =<< untilFixedPoint (return . magicDoEffect) il'
29− untilFixedPoint (return . collapseVarDeclarations) il''
30− where
31− tidyUp :: AST -> AST
32− tidyUp = applyAll
33− [ collapseNestedBlocks
34− , collapseNestedIfs
35− , collapseIfChecks
36− , removeCodeAfterReturnStatements
37− , unThunk
38− , etaConvert
39− , evaluateIifes
40− , inlineVariables
41− ]
42−
43−untilFixedPoint :: (Monad m, Eq a) => (a -> m a) -> a -> m a
44−untilFixedPoint f = go
45− where
46− go a = do
47− a' <- f a
48− if a' == a then return a' else go a'
49−
50−collapseIfChecks :: AST -> AST
51−collapseIfChecks = everywhere collapse where
52− collapse :: AST -> AST
53− collapse (IfElse _ (Binary _ EqualTo (BooleanLiteral _ True) (BooleanLiteral _ True)) (Block _ [exprs]) _) = exprs
54− collapse (IfElse _ (Binary _ EqualTo (Indexer _ (Var _ prop) (Var _ val)) (BooleanLiteral _ True)) (Block _ [exprs]) _)
55− | prop == "otherwise" && val == "Data_Boolean" = exprs
56− collapse exprs = exprs
57−
58−collapseVarDeclarations :: AST -> AST
59−collapseVarDeclarations = everywhere collapse where
60− collapse :: AST -> AST
61− collapse (Block ss sts) = Block ss (go Nothing sts)
62− collapse s = s
63−
64− go :: Maybe Text -> [AST] -> [AST]
65− go _ [] = []
66− go Nothing (decl@(VariableIntroduction _ var (Just _)) : sts) = decl : go (Just var) (go Nothing sts)
67− go (Just var') ((VariableIntroduction ss var (Just val)) : sts)
68− | var == var' = (Assignment ss (Var Nothing var) val) : go (Just var') sts
69− go var' (s:sts) = s : go var' sts
70−
71−ignoreUnusedResults :: AST -> AST
72−ignoreUnusedResults = everywhere $ removeFromBlock go
73− where
74− go :: [AST] -> [AST]
75− go [] = []
76− go (VariableIntroduction ss var (Just s) : sts)
77− | not $ any (everything (||) (isUsed var)) sts = sts'
78− where
79− sts' | App{} <- s = s : (go sts)
80− | otherwise = go sts
81− go (s:sts) = s : go sts
src/CodeGen/IL/Optimizer/Common.hsdeleted−18
@@ -1,18 +0,0 @@
1−-- | Common functions used by the various optimizer phases
2−module CodeGen.IL.Optimizer.Common where
3−
4−import Prelude.Compat
5−
6−import Data.Text (Text)
7−
8−import Language.PureScript.CoreImp.AST
9−import Language.PureScript.PSString (PSString, decodeString)
10−
11−isDict :: (Text, PSString) -> AST -> Bool
12−isDict (moduleName, dictName) (Indexer _ (Var _ x) (Var _ y)) =
13− Just x == decodeString dictName && y == moduleName
14−isDict _ _ = False
15−
16−isDict' :: [(Text, PSString)] -> AST -> Bool
17−isDict' xs il = any (`isDict` il) xs
18−
src/CodeGen/IL/Optimizer/Inliner.hsdeleted−435
@@ -1,435 +0,0 @@
1−-- | This module performs basic inlining of known functions
2−module CodeGen.IL.Optimizer.Inliner
3− ( inlineCommonValues
4− , inlineCommonOperators
5− , inlineFnComposition
6− , inlineUnsafeCoerce
7− , inlineUnsafePartial
8− ) where
9−
10−import Prelude.Compat
11−
12−import Control.Monad.Supply.Class (MonadSupply)
13−
14−import Data.Either (rights)
15−import Data.Maybe (fromMaybe)
16−import Data.String (IsString, fromString)
17−import Data.Text (Text)
18−import qualified Data.Text as T
19−
20−import Language.PureScript.PSString (PSString, decodeString, mkString)
21−import Language.PureScript.CoreImp.AST
22−import Language.PureScript.CoreImp.Optimizer.Common hiding (isDict, isDict')
23−import Language.PureScript.AST (SourceSpan(..))
24−import qualified Language.PureScript.Constants as C
25−
26−import CodeGen.IL.Common
27−import CodeGen.IL.Optimizer.Common
28−
29−-- TODO: Potential bug:
30−-- Shouldn't just inline this case: { var x = 0; x.toFixed(10); }
31−-- Needs to be: { 0..toFixed(10); }
32−-- Probably needs to be fixed in pretty-printer instead.
33−shouldInline :: AST -> Bool
34−shouldInline (Var _ _) = True
35−shouldInline (NumericLiteral _ _) = True
36−shouldInline (StringLiteral _ _) = True
37−shouldInline (BooleanLiteral _ _) = True
38−shouldInline (Indexer _ index val) = shouldInline index && shouldInline val
39−shouldInline _ = False
40−
41−inlineCommonValues :: AST -> AST
42−inlineCommonValues = everywhere convert
43− where
44− convert :: AST -> AST
45− convert (App ss fn [dict])
46− | isDict' [semiringNumber, semiringInt] dict && isDict fnZero fn = NumericLiteral ss (Left 0)
47− | isDict' [semiringNumber, semiringInt] dict && isDict fnOne fn = NumericLiteral ss (Left 1)
48− | isDict boundedBoolean dict && isDict fnBottom fn = BooleanLiteral ss False
49− | isDict boundedBoolean dict && isDict fnTop fn = BooleanLiteral ss True
50− convert (App ss (App _ fn [dict]) [x])
51− | isDict ringInt dict && isDict fnNegate fn = Unary ss Negate (unbox x $ snd ringInt)
52− convert (App ss (App _ (App _ fn [dict]) [x]) [y])
53− | isDict semiringInt dict && isDict fnAdd fn = intOp ss Add semiringInt x y
54− | isDict semiringInt dict && isDict fnMultiply fn = intOp ss Multiply semiringInt x y
55− | isDict ringInt dict && isDict fnSubtract fn = intOp ss Subtract ringInt x y
56− convert other = other
57− fnZero = (C.dataSemiring, C.zero)
58− fnOne = (C.dataSemiring, C.one)
59− fnBottom = (C.dataBounded, C.bottom)
60− fnTop = (C.dataBounded, C.top)
61− fnAdd = (C.dataSemiring, C.add)
62− fnMultiply = (C.dataSemiring, C.mul)
63− fnSubtract = (C.dataRing, C.sub)
64− fnNegate = (C.dataRing, C.negate)
65− intOp ss op (_, d) x y = Binary ss op (unbox x d) (unbox y d)
66−
67−inlineCommonOperators :: AST -> AST
68−inlineCommonOperators = everywhereTopDown $ applyAll $
69− [ binary semiringNumber opAdd Add
70− , binary semiringNumber opMul Multiply
71−
72− , binary ringNumber opSub Subtract
73− , unary ringNumber opNegate Negate
74−
75− , binary euclideanRingNumber opDiv Divide
76−
77− -- , binary eqNumber opEq EqualTo
78− -- , binary eqNumber opNotEq NotEqualTo
79− , binary eqInt opEq EqualTo
80− , binary eqInt opNotEq NotEqualTo
81− , binary eqString opEq EqualTo
82− , binary eqString opNotEq NotEqualTo
83− , binary eqChar opEq EqualTo
84− , binary eqChar opNotEq NotEqualTo
85− , binary eqBoolean opEq EqualTo
86− , binary eqBoolean opNotEq NotEqualTo
87−
88− , binary ordBoolean opLessThan LessThan
89− , binary ordBoolean opLessThanOrEq LessThanOrEqualTo
90− , binary ordBoolean opGreaterThan GreaterThan
91− , binary ordBoolean opGreaterThanOrEq GreaterThanOrEqualTo
92− , binary ordChar opLessThan LessThan
93− , binary ordChar opLessThanOrEq LessThanOrEqualTo
94− , binary ordChar opGreaterThan GreaterThan
95− , binary ordChar opGreaterThanOrEq GreaterThanOrEqualTo
96− , binary ordInt opLessThan LessThan
97− , binary ordInt opLessThanOrEq LessThanOrEqualTo
98− , binary ordInt opGreaterThan GreaterThan
99− , binary ordInt opGreaterThanOrEq GreaterThanOrEqualTo
100− , binary ordNumber opLessThan LessThan
101− , binary ordNumber opLessThanOrEq LessThanOrEqualTo
102− , binary ordNumber opGreaterThan GreaterThan
103− , binary ordNumber opGreaterThanOrEq GreaterThanOrEqualTo
104− , binary ordString opLessThan LessThan
105− , binary ordString opLessThanOrEq LessThanOrEqualTo
106− , binary ordString opGreaterThan GreaterThan
107− , binary ordString opGreaterThanOrEq GreaterThanOrEqualTo
108−
109− , binary semigroupString opAppend Add
110−
111− , binary heytingAlgebraBoolean opConj And
112− , binary heytingAlgebraBoolean opDisj Or
113− , unary heytingAlgebraBoolean opNot Not
114−
115− , binary' C.dataIntBits C.or BitwiseOr
116− , binary' C.dataIntBits C.and BitwiseAnd
117− , binary' C.dataIntBits C.xor BitwiseXor
118− , binary' C.dataIntBits C.shl ShiftLeft
119− , binary' C.dataIntBits C.shr ShiftRight
120− , unary' C.dataIntBits C.complement BitwiseNot
121−
122− , inlineNonClassFunction (isModFn (C.dataFunction, C.apply)) $ \f x -> App Nothing f [x]
123− , inlineNonClassFunction (isModFn (C.dataFunction, C.applyFlipped)) $ \x f -> App Nothing f [x]
124− , inlineUnsafeIndex (isModFnWithDict (C.dataArray, C.unsafeIndex)) $ flip (Indexer Nothing)
125− ] ++
126− [ fn | i <- [0..10], fn <- [ mkFn i, runFn i ] ] ++
127− [ fn | i <- [0..10], fn <- [ mkEffFn C.controlMonadEffUncurried C.mkEffFn i, runEffFn C.controlMonadEffUncurried C.runEffFn i ] ] ++
128− [ fn | i <- [0..10], fn <- [ mkEffFn C.effectUncurried C.mkEffectFn i, runEffFn C.effectUncurried C.runEffectFn i ] ]
129− where
130− binary :: (Text, PSString) -> (Text, PSString) -> BinaryOperator -> AST -> AST
131− binary dict@(_, d) fns op = convert where
132− convert :: AST -> AST
133− convert (App ss (App _ (App _ fn [dict']) [x]) [y])
134− | isDict dict dict' && isDict fns fn = Binary ss op (unbox x d) (unbox y d)
135− convert other = other
136− binary' :: Text -> PSString -> BinaryOperator -> AST -> AST
137− binary' moduleName opString op = convert where
138− convert :: AST -> AST
139− convert (App ss (App _ fn [x]) [y]) | isDict (moduleName, opString) fn = Binary ss op (unbox x mn) (unbox y mn)
140− convert other = other
141− mn :: PSString
142− mn = mkString moduleName
143− unary :: (Text, PSString) -> (Text, PSString) -> UnaryOperator -> AST -> AST
144− unary dicts@(_, d) fns op = convert where
145− convert :: AST -> AST
146− convert (App ss (App _ fn [dict']) [x]) | isDict dicts dict' && isDict fns fn = Unary ss op (unbox x d)
147− convert other = other
148− unary' :: Text -> PSString -> UnaryOperator -> AST -> AST
149− unary' moduleName fnName op = convert where
150− convert :: AST -> AST
151− convert (App ss fn [x]) | isDict (moduleName, fnName) fn = Unary ss op (unbox x fnName)
152− convert other = other
153−
154− mkFn :: Int -> AST -> AST
155− mkFn = mkFn' C.dataFunctionUncurried C.mkFn $ \ss1 ss2 ss3 args il ->
156− Function ss1 Nothing args (Block ss2 [Return ss3 il])
157−
158− mkEffFn :: Text -> Text -> Int -> AST -> AST
159− mkEffFn modName fnName = mkFn' modName fnName $ \ss1 ss2 ss3 args il ->
160− Function ss1 Nothing args (Block ss2 [Return ss3 (App ss3 il [])])
161−
162− mkFn' :: Text -> Text -> (Maybe SourceSpan -> Maybe SourceSpan -> Maybe SourceSpan -> [Text] -> AST -> AST) -> Int -> AST -> AST
163− mkFn' modName fnName res 0 = convert where
164− convert :: AST -> AST
165− convert (App _ mkFnN [Function s1 Nothing [_] (Block s2 [Return s3 il])]) | isNFn modName fnName 0 mkFnN =
166− res s1 s2 s3 [] il
167− convert other = other
168− mkFn' modName fnName res n = convert where
169− convert :: AST -> AST
170− convert orig@(App ss mkFnN [fn]) | isNFn modName fnName n mkFnN =
171− case collectArgs n [] fn of
172− Just (args, [Return ss' ret]) -> res ss ss ss' args ret
173− _ -> orig
174− convert other = other
175− collectArgs :: Int -> [Text] -> AST -> Maybe ([Text], [AST])
176− collectArgs 1 acc (Function _ Nothing [oneArg] (Block _ il)) | length acc == n - 1 = Just (reverse (oneArg : acc), il)
177− collectArgs m acc (Function _ Nothing [oneArg] (Block _ [Return _ ret])) = collectArgs (m - 1) (oneArg : acc) ret
178− collectArgs _ _ _ = Nothing
179−
180− isNFn :: Text -> Text -> Int -> AST -> Bool
181− isNFn expectMod prefix n (Indexer _ (Var _ name) (Var _ modName)) | modName == expectMod =
182− name == fromString (T.unpack prefix <> show n)
183− isNFn _ _ _ _ = False
184−
185− runFn :: Int -> AST -> AST
186− runFn = runFn' C.dataFunctionUncurried C.runFn (\ss f args ->
187− let len = length args
188− typ = mkString $ uncurriedFnType len in
189− if len > 0
190− then App ss (App Nothing (StringLiteral Nothing typ) [f]) args
191− else App ss f args)
192− runEffFn :: Text -> Text -> Int -> AST -> AST
193− runEffFn modName fnName = runFn' modName fnName $ \ss fn acc ->
194− let typ = mkString . uncurriedFnType $ length acc in
195− Function ss Nothing [] (Block ss [Return ss (App ss (App Nothing (StringLiteral Nothing typ) [fn]) acc)])
196−
197− runFn' :: Text -> Text -> (Maybe SourceSpan -> AST -> [AST] -> AST) -> Int -> AST -> AST
198− runFn' modName runFnName res n = convert where
199− convert :: AST -> AST
200− convert il = fromMaybe il $ go n [] il
201−
202− go :: Int -> [AST] -> AST -> Maybe AST
203− go 0 acc (App ss runFnN [fn]) | isNFn modName runFnName n runFnN && length acc == n =
204− Just $ res ss fn acc
205− go m acc (App _ lhs [arg]) = go (m - 1) (arg : acc) lhs
206− go _ _ _ = Nothing
207−
208− inlineNonClassFunction :: (AST -> Bool) -> (AST -> AST -> AST) -> AST -> AST
209− inlineNonClassFunction p f = convert where
210− convert :: AST -> AST
211− convert (App _ (App _ op' [x]) [y]) | p op' = f x y
212− convert other = other
213−
214− inlineUnsafeIndex :: (AST -> Bool) -> (AST -> AST -> AST) -> AST -> AST
215− inlineUnsafeIndex p _ = convert where
216− convert :: AST -> AST
217− convert (App _ (App ss op' [x]) [y@NumericLiteral{}])
218− | p op' = Indexer ss y x
219− convert (App _ (App ss op' [x]) [y])
220− | p op' = App ss (Var Nothing indexFn) [x, y]
221− convert other = other
222−
223− isModFn :: (Text, PSString) -> AST -> Bool
224− isModFn (m, op) (Indexer _ (Var _ op') (Var _ m')) =
225− m == m' && decodeString op == Just op'
226− isModFn _ _ = False
227−
228− isModFnWithDict :: (Text, PSString) -> AST -> Bool
229− isModFnWithDict (m, op) (App _ (Indexer _ (Var _ op') (Var _ m')) [Var _ _]) =
230− m == m' && decodeString op == Just op'
231− isModFnWithDict _ _ = False
232−
233−-- (f <<< g $ x) = f (g x)
234−-- (f <<< g) = \x -> f (g x)
235−inlineFnComposition :: forall m. MonadSupply m => AST -> m AST
236−inlineFnComposition = everywhereTopDownM convert where
237− convert :: AST -> m AST
238− convert (App s1 (App s2 (App _ (App _ fn [dict']) [x]) [y]) [z])
239− | isFnCompose dict' fn = return $ App s1 x [App s2 y [z]]
240− | isFnComposeFlipped dict' fn = return $ App s2 y [App s1 x [z]]
241− convert app@(App ss (App _ (App _ fn [dict']) _) _)
242− | isFnCompose dict' fn || isFnComposeFlipped dict' fn = mkApps ss <$> goApps app <*> freshName'
243− convert other = return other
244−
245− mkApps :: Maybe SourceSpan -> [Either AST (Text, AST)] -> Text -> AST
246− mkApps ss fns a = App ss (Function ss Nothing [] (Block ss $ vars <> [Return Nothing comp])) []
247− where
248− vars = uncurry (VariableIntroduction ss) . fmap Just <$> rights fns
249− comp = Function ss Nothing [a] (Block ss [Return Nothing apps])
250− apps = foldr (\fn acc -> App ss (mkApp fn) [acc]) (Var ss a) fns
251−
252− mkApp :: Either AST (Text, AST) -> AST
253− mkApp = either id $ \(name, arg) -> Var (getSourceSpan arg) name
254−
255− goApps :: AST -> m [Either AST (Text, AST)]
256− goApps (App _ (App _ (App _ fn [dict']) [x]) [y])
257− | isFnCompose dict' fn = mappend <$> goApps x <*> goApps y
258− | isFnComposeFlipped dict' fn = mappend <$> goApps y <*> goApps x
259− goApps app@(App {}) = pure . Right . (,app) <$> freshName'
260− goApps other = pure [Left other]
261−
262− isFnCompose :: AST -> AST -> Bool
263− isFnCompose dict' fn = isDict semigroupoidFn dict' && isDict fnCompose fn
264−
265− isFnComposeFlipped :: AST -> AST -> Bool
266− isFnComposeFlipped dict' fn = isDict semigroupoidFn dict' && isDict fnComposeFlipped fn
267−
268− fnCompose :: forall a b. (IsString a, IsString b) => (a, b)
269− fnCompose = (C.controlSemigroupoid, C.compose)
270−
271− fnComposeFlipped :: forall a b. (IsString a, IsString b) => (a, b)
272− fnComposeFlipped = (C.controlSemigroupoid, C.composeFlipped)
273−
274−inlineUnsafeCoerce :: AST -> AST
275−inlineUnsafeCoerce = everywhereTopDown convert where
276− convert (App _ (Indexer _ (Var _ unsafeCoerceFn) (Var _ unsafeCoerce)) [ comp ])
277− | unsafeCoerceFn == C.unsafeCoerceFn && unsafeCoerce == C.unsafeCoerce
278− = comp
279− convert other = other
280−
281−inlineUnsafePartial :: AST -> AST
282−inlineUnsafePartial = everywhereTopDown convert where
283− convert (App ss fn [ comp ])
284− | isDict fnUnsafePartial fn
285− = App ss comp []
286− where
287− fnUnsafePartial :: forall a b. (IsString a, IsString b) => (a, b)
288− fnUnsafePartial = (C.partialUnsafe, C.unsafePartial)
289− convert other = other
290−
291−semiringNumber :: forall a b. (IsString a, IsString b) => (a, b)
292−semiringNumber = (C.dataSemiring, C.semiringNumber)
293−
294−semiringInt :: forall a b. (IsString a, IsString b) => (a, b)
295−semiringInt = (C.dataSemiring, C.semiringInt)
296−
297−ringNumber :: forall a b. (IsString a, IsString b) => (a, b)
298−ringNumber = (C.dataRing, C.ringNumber)
299−
300−ringInt :: forall a b. (IsString a, IsString b) => (a, b)
301−ringInt = (C.dataRing, C.ringInt)
302−
303−euclideanRingNumber :: forall a b. (IsString a, IsString b) => (a, b)
304−euclideanRingNumber = (C.dataEuclideanRing, C.euclideanRingNumber)
305−
306−-- eqNumber :: forall a b. (IsString a, IsString b) => (a, b)
307−-- eqNumber = (C.dataEq, C.eqNumber)
308−
309−eqInt :: forall a b. (IsString a, IsString b) => (a, b)
310−eqInt = (C.dataEq, C.eqInt)
311−
312−eqString :: forall a b. (IsString a, IsString b) => (a, b)
313−eqString = (C.dataEq, C.eqString)
314−
315−eqChar :: forall a b. (IsString a, IsString b) => (a, b)
316−eqChar = (C.dataEq, C.eqChar)
317−
318−eqBoolean :: forall a b. (IsString a, IsString b) => (a, b)
319−eqBoolean = (C.dataEq, C.eqBoolean)
320−
321−ordBoolean :: forall a b. (IsString a, IsString b) => (a, b)
322−ordBoolean = (C.dataOrd, C.ordBoolean)
323−
324−ordNumber :: forall a b. (IsString a, IsString b) => (a, b)
325−ordNumber = (C.dataOrd, C.ordNumber)
326−
327−ordInt :: forall a b. (IsString a, IsString b) => (a, b)
328−ordInt = (C.dataOrd, C.ordInt)
329−
330−ordString :: forall a b. (IsString a, IsString b) => (a, b)
331−ordString = (C.dataOrd, C.ordString)
332−
333−ordChar :: forall a b. (IsString a, IsString b) => (a, b)
334−ordChar = (C.dataOrd, C.ordChar)
335−
336−semigroupString :: forall a b. (IsString a, IsString b) => (a, b)
337−semigroupString = (C.dataSemigroup, C.semigroupString)
338−
339−boundedBoolean :: forall a b. (IsString a, IsString b) => (a, b)
340−boundedBoolean = (C.dataBounded, C.boundedBoolean)
341−
342−heytingAlgebraBoolean :: forall a b. (IsString a, IsString b) => (a, b)
343−heytingAlgebraBoolean = (C.dataHeytingAlgebra, C.heytingAlgebraBoolean)
344−
345−semigroupoidFn :: forall a b. (IsString a, IsString b) => (a, b)
346−semigroupoidFn = (C.controlSemigroupoid, C.semigroupoidFn)
347−
348−opAdd :: forall a b. (IsString a, IsString b) => (a, b)
349−opAdd = (C.dataSemiring, C.add)
350−
351−opMul :: forall a b. (IsString a, IsString b) => (a, b)
352−opMul = (C.dataSemiring, C.mul)
353−
354−opEq :: forall a b. (IsString a, IsString b) => (a, b)
355−opEq = (C.dataEq, C.eq)
356−
357−opNotEq :: forall a b. (IsString a, IsString b) => (a, b)
358−opNotEq = (C.dataEq, C.notEq)
359−
360−opLessThan :: forall a b. (IsString a, IsString b) => (a, b)
361−opLessThan = (C.dataOrd, C.lessThan)
362−
363−opLessThanOrEq :: forall a b. (IsString a, IsString b) => (a, b)
364−opLessThanOrEq = (C.dataOrd, C.lessThanOrEq)
365−
366−opGreaterThan :: forall a b. (IsString a, IsString b) => (a, b)
367−opGreaterThan = (C.dataOrd, C.greaterThan)
368−
369−opGreaterThanOrEq :: forall a b. (IsString a, IsString b) => (a, b)
370−opGreaterThanOrEq = (C.dataOrd, C.greaterThanOrEq)
371−
372−opAppend :: forall a b. (IsString a, IsString b) => (a, b)
373−opAppend = (C.dataSemigroup, C.append)
374−
375−opSub :: forall a b. (IsString a, IsString b) => (a, b)
376−opSub = (C.dataRing, C.sub)
377−
378−opNegate :: forall a b. (IsString a, IsString b) => (a, b)
379−opNegate = (C.dataRing, C.negate)
380−
381−opDiv :: forall a b. (IsString a, IsString b) => (a, b)
382−opDiv = (C.dataEuclideanRing, C.div)
383−
384−opConj :: forall a b. (IsString a, IsString b) => (a, b)
385−opConj = (C.dataHeytingAlgebra, C.conj)
386−
387−opDisj :: forall a b. (IsString a, IsString b) => (a, b)
388−opDisj = (C.dataHeytingAlgebra, C.disj)
389−
390−opNot :: forall a b. (IsString a, IsString b) => (a, b)
391−opNot = (C.dataHeytingAlgebra, C.not)
392−
393−unbox :: AST -> PSString -> AST
394−unbox e d = select . inlineCommonValues $ inlineCommonOperators e
395− where
396− select :: AST -> AST
397− select e' =
398− case e' of
399− Var{} -> unbox' e'
400− App{} -> unbox' e'
401− Indexer{} -> unbox' e'
402− _ -> e'
403− unbox' :: AST -> AST
404− unbox' e' = maybe e' (\t -> App Nothing (StringLiteral Nothing t) [e']) $ unboxType d
405−
406−unboxType :: PSString -> Maybe PSString
407−unboxType s = do
408− t <- decodeString s
409− t' <- unboxType' t
410− return $ mkString t'
411− where
412− unboxType' :: Text -> Maybe Text
413− unboxType' t
414− | t == C.eqInt ||
415− t == C.semiringInt ||
416− t == C.ringInt ||
417− t == C.ordInt ||
418− t == C.dataIntBits
419− = Just int
420− | t == C.semiringNumber ||
421− t == C.ringNumber ||
422− t == C.ordNumber ||
423− t == C.euclideanRingNumber
424− = Just float
425− | t == C.eqBoolean ||
426− t == C.ordBoolean ||
427− t == C.heytingAlgebraBoolean
428− = Just bool
429− | t == C.eqChar ||
430− t == C.eqString ||
431− t == C.ordChar ||
432− t == C.ordString ||
433− t == C.semigroupString
434− = Just string
435− | otherwise = Nothing
src/CodeGen/IL/Optimizer/MagicDo.hsdeleted−146
@@ -1,146 +0,0 @@
1−-- | This module implements the "Magic Do" optimization, which inlines calls to return
2−-- and bind for the Eff monad, as well as some of its actions.
3−module CodeGen.IL.Optimizer.MagicDo (magicDoEffect, magicDoEff, magicDoST, inlineST) where
4−
5−import Prelude.Compat
6−import Protolude (ordNub)
7−
8−import Data.Maybe (fromJust, isJust)
9−import Data.Text (Text)
10−
11−import Language.PureScript.CoreImp.AST
12−import Language.PureScript.CoreImp.Optimizer.Common hiding (isDict)
13−import Language.PureScript.PSString (PSString, decodeString, mkString)
14−import qualified Language.PureScript.Constants as C
15−
16−import CodeGen.IL.Common (undefinedName, unusedName)
17−import CodeGen.IL.Optimizer.Common
18−
19−-- | Inline type class dictionaries for >>= and return for the Eff monad
20−--
21−-- E.g.
22−--
23−-- Prelude[">>="](dict)(m1)(function(x) {
24−-- return ...;
25−-- })
26−--
27−-- becomes
28−--
29−-- function __do {
30−-- var x = m1();
31−-- ...
32−-- }
33−magicDoEff :: AST -> AST
34−magicDoEff = magicDo C.eff C.effDictionaries
35−
36−magicDoEffect :: AST -> AST
37−magicDoEffect = magicDo C.effect C.effectDictionaries
38−
39−magicDoST :: AST -> AST
40−magicDoST = magicDo C.st C.stDictionaries
41−
42−magicDo :: Text -> C.EffectDictionaries -> AST -> AST
43−magicDo effectModule C.EffectDictionaries{..} = everywhereTopDown convert
44− where
45− -- Desugar monomorphic calls to >>= and return for the Eff monad
46− convert :: AST -> AST
47− -- Desugar pure
48− convert (App _ (App _ pure' [val]) []) | isPure pure' = val
49− -- Desugar discard
50− convert (App _ (App _ bind [m]) [Function s1 Nothing [unused] (Block s2 il)]) | isDiscard bind && unused == unusedName =
51− Function s1 Nothing [] $ Block s2 (App s2 m [] : map applyReturns il )
52− -- Desugar bind
53− convert (App _ (App _ bind [m]) [Function s1 Nothing [arg] (Block s2 il)]) | isBind bind =
54− Function s1 Nothing [] $ Block s2 (VariableIntroduction s2 arg (Just (App s2 m [])) : map applyReturns il)
55− -- Desugar untilE
56− convert (App s1 (App _ f [arg]) []) | isEffFunc edUntil f =
57− App s1 (Function s1 Nothing [] (Block s1 [ While s1 (Unary s1 Not (App s1 arg [])) (Block s1 []), Return s1 $ ObjectLiteral s1 []])) []
58− -- Desugar whileE
59− convert (App _ (App _ (App s1 f [arg1]) [arg2]) []) | isEffFunc edWhile f =
60− App s1 (Function s1 Nothing [] (Block s1 [ While s1 (App s1 arg1 []) (Block s1 [ App s1 arg2 [] ]), Return s1 $ ObjectLiteral s1 []])) []
61− -- -- Inline __do returns
62− -- convert (Return _ (App _ (Function _ (Just ident) [] body) [])) | ident == fnName = body
63− -- Inline double applications
64− convert (App _ (App s1 (Function s2 Nothing [] (Block ss body)) []) []) =
65− App s1 (Function s2 Nothing [] (Block ss (applyReturns `fmap` body))) []
66− convert other = other
67− -- Check if an expression represents a monomorphic call to >>= for the Eff monad
68− isBind (App _ fn [dict]) | isDict (effectModule, edBindDict) dict && isBindPoly fn = True
69− isBind _ = False
70− -- Check if an expression represents a call to @discard@
71− isDiscard (App _ (App _ fn [dict1]) [dict2])
72− | isDict (C.controlBind, C.discardUnitDictionary) dict1 &&
73− isDict (effectModule, edBindDict) dict2 &&
74− isDiscardPoly fn = True
75− isDiscard _ = False
76−
77− -- Check if an expression represents a monomorphic call to pure or return for the Eff applicative
78− isPure (App _ fn [dict]) | isDict (effectModule, edApplicativeDict) dict && isPurePoly fn = True
79− isPure _ = False
80− -- Check if an expression represents the polymorphic >>= function
81− isBindPoly = isDict (C.controlBind, C.bind)
82− -- Check if an expression represents the polymorphic pure function
83− isPurePoly = isDict (C.controlApplicative, C.pure')
84− -- Check if an expression represents the polymorphic discard function
85− isDiscardPoly = isDict (C.controlBind, C.discard)
86− -- Check if an expression represents a function in the Effect module
87− isEffFunc name (Indexer _ (StringLiteral _ name') (Var _ eff)) = eff == effectModule && name == name'
88− isEffFunc _ _ = False
89−
90− applyReturns :: AST -> AST
91− applyReturns (Return ss ret) = Return ss (App ss ret [])
92− applyReturns (Block ss ils) = Block ss (map applyReturns ils)
93− applyReturns (While ss cond il) = While ss cond (applyReturns il)
94− applyReturns (For ss v lo hi il) = For ss v lo hi (applyReturns il)
95− applyReturns (ForIn ss v xs il) = ForIn ss v xs (applyReturns il)
96− applyReturns (IfElse ss cond t f) = IfElse ss cond (applyReturns t) (applyReturns `fmap` f)
97− applyReturns other = other
98−
99−-- | Inline functions in the ST module
100−inlineST :: AST -> AST
101−inlineST = everywhere convertBlock
102− where
103− -- Look for runST blocks and inline the STRefs there.
104− -- If all STRefs are used in the scope of the same runST, only using { read, write, modify }STRef then
105− -- we can be more aggressive about inlining, and actually turn STRefs into local variables.
106− convertBlock (App s1 f [arg]) | isSTFunc C.runST f =
107− let refs = ordNub . findSTRefsIn $ arg
108− usages = findAllSTUsagesIn arg
109− allUsagesAreLocalVars = all (\u -> let v = toVar u in isJust v && fromJust v `elem` refs) usages
110− localVarsDoNotEscape = all (\r -> length (r `appearingIn` arg) == length (filter (\u -> let v = toVar u in v == Just r) usages)) refs
111− in App s1 (everywhere (convert (allUsagesAreLocalVars && localVarsDoNotEscape)) arg) []
112− convertBlock other = other
113− -- Convert a block in a safe way, preserving object wrappers of references,
114− -- or in a more aggressive way, turning wrappers into local variables depending on the
115− -- agg(ressive) parameter.
116− convert agg (App s1 f [arg]) | isSTFunc C.newSTRef f =
117− Function s1 Nothing [] (Block s1 [Return s1 $ if agg then arg else ObjectLiteral s1 [(mkString C.stRefValue, arg)]])
118− convert agg (App _ (App s1 f [ref]) []) | isSTFunc C.readSTRef f =
119− if agg then ref else Indexer s1 (StringLiteral s1 C.stRefValue) ref
120− convert agg (App _ (App _ (App s1 f [arg]) [ref]) []) | isSTFunc C.writeSTRef f =
121− if agg then Assignment s1 ref arg else Assignment s1 (Indexer s1 (StringLiteral s1 C.stRefValue) ref) arg
122− convert agg (App _ (App _ (App s1 f [func]) [ref]) []) | isSTFunc C.modifySTRef f =
123− if agg then Assignment s1 ref (App s1 func [ref]) else Assignment s1 (Indexer s1 (StringLiteral s1 C.stRefValue) ref) (App s1 func [Indexer s1 (StringLiteral s1 C.stRefValue) ref])
124− convert _ other = other
125− -- Check if an expression represents a function in the ST module
126− isSTFunc name (Indexer _ (StringLiteral _ name') (Var _ st)) = st == C.st && name == name'
127− isSTFunc _ _ = False
128− -- Find all ST Refs initialized in this block
129− findSTRefsIn = everything (++) isSTRef
130− where
131− isSTRef (VariableIntroduction _ ident (Just (App _ (App _ f [_]) []))) | isSTFunc C.newSTRef f = [ident]
132− isSTRef _ = []
133− -- Find all STRefs used as arguments to readSTRef, writeSTRef, modifySTRef
134− findAllSTUsagesIn = everything (++) isSTUsage
135− where
136− isSTUsage (App _ (App _ f [ref]) []) | isSTFunc C.readSTRef f = [ref]
137− isSTUsage (App _ (App _ (App _ f [_]) [ref]) []) | isSTFunc C.writeSTRef f || isSTFunc C.modifySTRef f = [ref]
138− isSTUsage _ = []
139− -- Find all uses of a variable
140− appearingIn ref = everything (++) isVar
141− where
142− isVar e@(Var _ v) | v == ref = [e]
143− isVar _ = []
144− -- Convert a AST value to a String if it is a Var
145− toVar (Var _ v) = Just v
146− toVar _ = Nothing
src/CodeGen/IL/Optimizer/TCO.hsdeleted−141
@@ -1,141 +0,0 @@
1−module CodeGen.IL.Optimizer.TCO (tco, tcoLoop) where
2−
3−import Prelude.Compat
4−
5−import Data.Text (Text)
6−import Data.Monoid ((<>))
7−import Language.PureScript.CoreImp.AST
8−import Language.PureScript.AST.SourcePos (SourceSpan)
9−import Safe (headDef, tailSafe)
10−import CodeGen.IL.Common
11−
12−import qualified Language.PureScript.Constants as C
13−
14−tcoLoop :: Text
15−tcoLoop = "ṩtco_loop"
16−
17−tco :: AST -> AST -> AST
18−tco mn = everywhere convert where
19− tcoVar :: Text -> Text
20− tcoVar arg = "ṩtco_var_" <> arg
21−
22− copyVar :: Text -> Text
23− copyVar arg = "ṩcopy_" <> arg
24−
25− tcoDone :: Text
26− tcoDone = "ṩtco_done"
27−
28− tcoResult :: Text
29− tcoResult = "ṩtco_result"
30−
31− convert :: AST -> AST
32− convert fn@(Function ss (Just name) args _)
33− | isTailRecursive name body'
34− = replace (toLoop name outerArgs innerArgs body')
35− where
36− innerArgs = headDef [] argss
37− outerArgs = concat . reverse $ tailSafe argss
38− (argss, body', replace) = collectAllFunctionArgs [] id fn
39− convert (Assignment ss (Var _ name) fn@(Function _ Nothing _ _))
40− | isTailRecursive name body'
41− = Assignment ss (Var ss name) (replace (toLoop name outerArgs innerArgs body'))
42− where
43− innerArgs = headDef [] argss
44− outerArgs = concat . reverse $ tailSafe argss
45− (argss, body', replace) = collectAllFunctionArgs [] id fn
46− convert js = js
47−
48− collectAllFunctionArgs :: [[Text]] -> (AST -> AST) -> AST -> ([[Text]], AST, AST -> AST)
49− collectAllFunctionArgs allArgs f (Function s1 ident args (Block s2 (body@(Return _ _):_))) =
50− collectAllFunctionArgs (args : allArgs) (\b -> f (Function s1 ident (map copyVar args) (Block s2 [b]))) body
51− collectAllFunctionArgs allArgs f (Function ss ident args body@(Block _ _)) =
52− (args : allArgs, body, f . Function ss ident (map copyVar args))
53− collectAllFunctionArgs allArgs f (Return s1 (Function s2 ident args (Block s3 [body]))) =
54− collectAllFunctionArgs (args : allArgs) (\b -> f (Return s1 (Function s2 ident (map copyVar args) (Block s3 [b])))) body
55− collectAllFunctionArgs allArgs f (Return s1 (Function s2 ident args body@(Block _ _))) =
56− (args : allArgs, body, f . Return s1 . Function s2 ident (map copyVar args))
57− collectAllFunctionArgs allArgs f body = (allArgs, body, f)
58−
59− isTailRecursive :: Text -> AST -> Bool
60− isTailRecursive ident js = countSelfReferences js > 0 && allInTailPosition js where
61− countSelfReferences = everything (+) match where
62− match :: AST -> Int
63− match (Var _ ident') | ident == ident' = 1
64− match _ = 0
65−
66− allInTailPosition (Return _ expr)
67− | isSelfCall ident expr = countSelfReferences expr == 1
68− | otherwise = countSelfReferences expr == 0
69− allInTailPosition (While _ js1 body)
70− = countSelfReferences js1 == 0 && allInTailPosition body
71− allInTailPosition (For _ _ js1 js2 body)
72− = countSelfReferences js1 == 0 && countSelfReferences js2 == 0 && allInTailPosition body
73− allInTailPosition (ForIn _ _ js1 body)
74− = countSelfReferences js1 == 0 && allInTailPosition body
75− allInTailPosition (IfElse _ js1 body el)
76− = countSelfReferences js1 == 0 && allInTailPosition body && all allInTailPosition el
77− allInTailPosition (Block _ body)
78− = all allInTailPosition body
79− allInTailPosition (Throw _ js1)
80− = countSelfReferences js1 == 0
81− allInTailPosition (ReturnNoResult _)
82− = True
83− allInTailPosition (VariableIntroduction _ _ js1)
84− = all ((== 0) . countSelfReferences) js1
85− allInTailPosition (Assignment _ _ js1)
86− = countSelfReferences js1 == 0
87− allInTailPosition (Comment _ _ js1)
88− = allInTailPosition js1
89− allInTailPosition _
90− = False
91−
92− toLoop :: Text -> [Text] -> [Text] -> AST -> AST
93− toLoop ident outerArgs innerArgs js =
94− Block rootSS $
95− concatMap (\arg -> [ VariableIntroduction rootSS (tcoVar arg) . Just $
96− Var rootSS (copyVar arg) ]) (outerArgs ++ innerArgs) ++
97− [ Assignment rootSS (Var rootSS $ "var " <> tcoDone) $ BooleanLiteral Nothing False
98− , VariableIntroduction rootSS tcoResult Nothing
99− , Assignment rootSS (Var rootSS $ "var " <> tcoLoop) (Function rootSS (Just tcoLoop) (outerArgs ++ innerArgs) (Block rootSS [loopify js]))
100− , While rootSS (Unary Nothing Not (Var rootSS tcoDone))
101− (Block rootSS
102− [(Assignment rootSS (Var rootSS tcoResult) (App rootSS (Var rootSS tcoLoop) ((map (Var rootSS . tcoVar) outerArgs) ++ (map (Var rootSS . copyVar) innerArgs))))])
103− , Return rootSS (Var rootSS tcoResult)
104− ]
105− where
106− rootSS = Nothing
107−
108− loopify :: AST -> AST
109− loopify (Return ss ret)
110− | isSelfCall ident ret =
111− let
112− allArgumentValues = concat $ collectArgs [] ret
113− in
114− Block ss $
115− zipWith (\val arg ->
116− Assignment ss (Var ss (tcoVar arg)) val) allArgumentValues outerArgs
117− ++ zipWith (\val arg ->
118− Assignment ss (Var ss (copyVar arg)) val) (drop (length outerArgs) allArgumentValues) innerArgs
119− ++ [ ReturnNoResult ss ]
120− | otherwise = Block ss [ markDone ss, Return ss ret ]
121− loopify (ReturnNoResult ss) = Block ss [ markDone ss, ReturnNoResult ss ]
122− loopify (While ss cond body) = While ss cond (loopify body)
123− loopify (For ss i js1 js2 body) = For ss i js1 js2 (loopify body)
124− loopify (ForIn ss i js1 body) = ForIn ss i js1 (loopify body)
125− loopify (IfElse ss cond body el) = IfElse ss cond (loopify body) (fmap loopify el)
126− loopify (Block ss body) = Block ss (map loopify body)
127− loopify other = other
128−
129− markDone :: Maybe SourceSpan -> AST
130− markDone ss = Assignment ss (Var ss tcoDone) (BooleanLiteral ss True)
131−
132− collectArgs :: [[AST]] -> AST -> [[AST]]
133− collectArgs acc (App _ fn args') = collectArgs (args' : acc) fn
134− collectArgs acc _ = acc
135−
136− isSelfCall :: Text -> AST -> Bool
137− isSelfCall ident (App _ (Var _ ident') _) = ident == ident'
138− isSelfCall ident (App _ (Indexer _ (Var _ ident') (Var _ mn')) _) = mn' == "" && ident == ident'
139− isSelfCall ident (App _ (Indexer _ (Var _ ident') mn') _) = mn' == mn && ident == ident'
140− isSelfCall ident (App _ fn _) = isSelfCall ident fn
141− isSelfCall _ _ = False
src/CodeGen/IL/Printer.hsdeleted−527
@@ -1,527 +0,0 @@
1−-- | Pretty printer for the AST
2−module CodeGen.IL.Printer
3− ( prettyPrintIL
4− , prettyPrintIL1
5− , prettyPrintILWithSourceMaps
6− , interfaceSource
7− , implHeaderSource
8− , implFooterSource
9− , isLiteral
10− , modLabel
11− , modPrefix
12− , ffiLoader
13− ) where
14−
15−import Prelude.Compat
16−
17−import Control.Arrow ((<+>))
18−import Control.Monad (forM, mzero)
19−import Control.Monad.State (StateT, evalStateT)
20−import Control.PatternArrows
21−import Data.List (filter, (\\))
22−import qualified Control.Arrow as A
23−
24−import Data.Maybe (fromMaybe)
25−import Data.Monoid ((<>))
26−import Data.Text (Text)
27−import qualified Data.Text as T
28−
29−import Language.PureScript.AST (SourceSpan(..))
30−import Language.PureScript.CoreImp.AST
31−import Language.PureScript.Comments
32−import Language.PureScript.Crash
33−import Language.PureScript.Names (Ident, runIdent)
34−import Language.PureScript.Pretty.Common
35−import Language.PureScript.PSString (PSString, decodeString, mkString)
36−
37−import CodeGen.IL.Common
38−import CodeGen.IL.Optimizer.TCO (tcoLoop)
39−
40−import qualified Language.PureScript.Constants as C
41−
42−-- TODO (Christoph): Get rid of T.unpack / pack
43−
44−literals :: (Emit gen) => Pattern PrinterState AST gen
45−literals = mkPattern' match'
46− where
47− match' :: (Emit gen) => AST -> StateT PrinterState Maybe gen
48− match' il = (addMapping' (getSourceSpan il) <>) <$> match il
49−
50− match :: (Emit gen) => AST -> StateT PrinterState Maybe gen
51− match (NumericLiteral _ n) = return $ emit $ T.pack $ either show show n
52− match (StringLiteral _ s) = return $ emit $ stringLiteral s
53− match (BooleanLiteral _ True) = return $ emit "true"
54− match (BooleanLiteral _ False) = return $ emit "false"
55− match (ArrayLiteral _ xs) = mconcat <$> sequence
56− [ return . emit $ arrayType <> "{"
57− , intercalate (emit ", ") <$> forM xs prettyPrintIL'
58− , return $ emit "}"
59− ]
60− -- match (ObjectLiteral _ []) = return $ emit "std::initializer_list<std::pair<const string, boxed>>{}"
61− match (ObjectLiteral _ ps) = mconcat <$> sequence
62− [ return . emit $ dictType <> "{"
63− , withIndent $ do
64− ils <- forM ps $ \(key, value) -> do
65− value' <- prettyPrintIL' value
66− return $ objectPropertyToString key <> value'
67− return $ intercalate (emit " ") $ map (<> emit ",") ils
68− , return $ emit "}"
69− ]
70− where
71− objectPropertyToString :: (Emit gen) => PSString -> gen
72− objectPropertyToString s = emit $ stringLiteral s <> ": "
73− match (Block _ sts) = mconcat <$> sequence
74− [ return $ emit "{\n"
75− , withIndent $ prettyStatements sts
76− , return $ emit "\n"
77− , currentIndent
78− , return $ emit "}"
79− ]
80− match (Var _ ident) | ident == C.undefined = return $ emit undefinedName
81− match (Var _ ident) = return $ emit ident
82− match (VariableIntroduction _ ident value) = mconcat <$> sequence
83− [ return . emit $ varDecl <> " " <> ident <> " " <> anyType
84− , maybe (return mempty) (fmap (emit " = " <>) . prettyPrintIL') value
85− ]
86− match (Assignment _ target value) = mconcat <$> sequence
87− [ prettyPrintIL' target
88− , return $ emit " = "
89− , prettyPrintIL' value
90− ]
91− match (App _ val []) = mconcat <$> sequence
92− [ return $ emit "Run("
93− , prettyPrintIL' val
94− , return $ emit ")"
95− ]
96− match (App _ (StringLiteral _ u) [arg])
97− | Just ty <- decodeString u = mconcat <$> sequence
98− [ prettyPrintIL' arg
99− , return $ emit ".("
100− , return $ emit ty
101− , return $ emit ")"
102− ]
103− match (App _ (Var _ fn) [arg]) | fn == arrayLengthFn = mconcat <$> sequence
104− [ return $ emit fn
105− , return $ emit "("
106− , prettyPrintIL' arg
107− , return $ emit ")"
108− ]
109− match (App _ (Var _ fn) args) | fn == indexFn = mconcat <$> sequence
110− [ return $ emit fn
111− , return $ emit "("
112− , intercalate (emit ", ") <$> forM args prettyPrintIL'
113− , return $ emit ")"
114− ]
115− match (App _ (Var _ fn) args) | fn == tcoLoop = mconcat <$> sequence
116− [ return $ emit fn
117− , return $ emit "("
118− , intercalate (emit ", ") <$> forM args prettyPrintIL'
119− , return $ emit ")"
120− ]
121− match (App _ (App Nothing (StringLiteral Nothing fnx) [fn@Function{}]) args)
122− | Just ftype <- decodeString fnx
123− , "Fn" `T.isPrefixOf` ftype = mconcat <$> sequence
124− [ prettyPrintIL' fn
125− , return $ emit "("
126− , intercalate (emit ", ") <$> forM args prettyPrintIL'
127− , return $ emit ")"
128− ]
129− match (App _ (App Nothing (StringLiteral Nothing fnx) [fn]) args)
130− | Just ftype <- decodeString fnx
131− , "Fn" `T.isPrefixOf` ftype = mconcat <$> sequence
132− [ prettyPrintIL' fn
133− , return $ emit ".("
134− , return $ emit ftype
135− , return $ emit ")("
136− , intercalate (emit ", ") <$> forM args prettyPrintIL'
137− , return $ emit ")"
138− ]
139− match app@(App{})
140− | (val, args) <- unApp app []
141− , length args > 1
142− = mconcat <$> sequence
143− [ return $ emit "Apply("
144− , prettyPrintIL' val
145− , return $ emit ", "
146− , intercalate (emit ", ") <$> forM args prettyPrintIL'
147− , return $ emit ")"
148− ]
149− match (App _ val args) = mconcat <$> sequence
150− [ return $ emit "Apply("
151− , prettyPrintIL' val
152− , return $ emit ", "
153− , intercalate (emit ", ") <$> forM args prettyPrintIL'
154− , return $ emit ")"
155− ]
156− match (Function _ (Just name) [] (Block _ [Return _ ret]))
157− | isComplexLiteral ret = mconcat <$> sequence
158− [ return $ emit "\n"
159− , return . emit $ varDecl <> " " <> initName name <> " Once\n"
160− , prettyPrintIL' $ VariableIntroduction Nothing (valueName name) Nothing
161− , return $ emit "\n\n"
162− , return $ emit "func "
163− , return . emit $ withPrefix name
164− , return . emit $ "() " <> anyType <> " "
165− , return $ emit "{\n"
166− , withIndent $ do
167− indentString <- currentIndent
168− return $ indentString <> (emit $ initName name <> ".Do(func() {\n") <>
169− indentString <> indentString <> (emit $ valueName name <> " = ")
170− , withIndent $ do
171− case ret of
172− Function _ Nothing args body -> mconcat <$> sequence
173− [ return $ emit "func("
174− , return . emit $ intercalate ", " (renderArg anyType <$> args)
175− , return . emit $ ") " <> anyType <> " "
176− , prettyPrintIL' body
177− ]
178− _ -> do
179− prettyPrintIL' ret
180− , return $ emit "\n"
181− , withIndent $ do
182− indentString <- currentIndent
183− return $ indentString <> (emit $ "})\n" <> "return " <> valueName name <>"\n")
184− , return $ emit "}\n\n"
185− ]
186− match (Function _ (Just name) [] ret) = mconcat <$> sequence
187− [ return $ emit "func "
188− , return . emit $ withPrefix name
189− , return . emit $ "() " <> anyType <> " "
190− , prettyPrintIL' ret
191− ]
192− match (Function _ _ args ret) = mconcat <$> sequence
193− [ return $ emit "func("
194− , return . emit $ intercalate ", " (renderArg anyType <$> args)
195− , return . emit $ ") " <> anyType <> " "
196− , prettyPrintIL' ret
197− ]
198− match (Indexer _ (Var _ name) (Var _ "")) = mconcat <$> sequence
199− [ prettyPrintIL' (Var Nothing $ withPrefix name)
200− , return $ emit "()"
201− ]
202− match (Indexer _ (Var _ name) val) = mconcat <$> sequence
203− [ prettyPrintIL' val
204− , return $ emit "."
205− , prettyPrintIL' (Var Nothing $ withPrefix name)
206− , return $ emit "()"
207− ]
208− match (Indexer _ prop@StringLiteral{} val@ObjectLiteral{}) = mconcat <$> sequence
209− [ prettyPrintIL' val
210− , return $ emit "["
211− , prettyPrintIL' prop
212− , return $ emit "]"
213− ]
214− match (Indexer _ prop@StringLiteral{} val) = mconcat <$> sequence
215− [ prettyPrintIL' val
216− , return $ emit ".("
217− , return $ emit dictType
218− , return $ emit ")["
219− , prettyPrintIL' prop
220− , return $ emit "]"
221− ]
222− match (Indexer _ index val@ArrayLiteral{}) = mconcat <$> sequence
223− [ prettyPrintIL' val
224− , return $ emit "["
225− , prettyPrintIL' index
226− , return $ emit "]"
227− ]
228− match (Indexer _ index val) = mconcat <$> sequence
229− [ prettyPrintIL' val
230− , return $ emit ".("
231− , return $ emit arrayType
232− , return $ emit ")["
233− , prettyPrintIL' index
234− , return $ emit "]"
235− ]
236− match (InstanceOf _ val ty) = mconcat <$> sequence
237− [ return $ emit "Is("
238− , prettyPrintIL' val
239− , return $ emit ", "
240− , prettyPrintIL' ty
241− , return $ emit ")"
242− ]
243− match (While _ cond sts) = mconcat <$> sequence
244− [ return $ emit "for "
245− , prettyPrintIL' cond
246− , return $ emit " "
247− , prettyPrintIL' sts
248− ]
249− match (For _ ident start end sts) = mconcat <$> sequence
250− [ return $ emit $ "for var " <> ident <> " = "
251− , prettyPrintIL' start
252− , return $ emit $ "; " <> ident <> " < "
253− , prettyPrintIL' end
254− , return $ emit $ "; " <> ident <> "++ "
255− , prettyPrintIL' sts
256− ]
257− match (ForIn _ ident obj sts) = mconcat <$> sequence
258− [ return $ emit $ "for var " <> ident <> " in "
259− , prettyPrintIL' obj
260− , return $ emit " "
261− , prettyPrintIL' sts
262− ]
263− match (IfElse _ (Binary _ EqualTo cond@Binary{} (BooleanLiteral Nothing True)) thens elses) = mconcat <$> sequence
264− [ return $ emit "if "
265− , prettyPrintIL' cond
266− , return $ emit " "
267− , prettyPrintIL' thens
268− , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintIL') elses
269− ]
270− match (IfElse _ (Binary _ EqualTo cond@Binary{} (BooleanLiteral Nothing False)) thens elses) = mconcat <$> sequence
271− [ return $ emit "if !("
272− , prettyPrintIL' cond
273− , return $ emit ") "
274− , prettyPrintIL' thens
275− , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintIL') elses
276− ]
277− match (IfElse _ cond thens elses) = mconcat <$> sequence
278− [ return $ emit "if "
279− , prettyPrintIL' cond
280− , return $ emit " "
281− , prettyPrintIL' thens
282− , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintIL') elses
283− ]
284− match (Return _ value) = mconcat <$> sequence
285− [ return $ emit "return "
286− , prettyPrintIL' value
287− ]
288− match (ReturnNoResult _) = return . emit $ "return " <> undefinedName
289− -- match (Throw _ _) = return mempty
290− match (Throw _ value) = mconcat <$> sequence
291− [ return $ emit "panic("
292− , prettyPrintIL' value
293− , return $ emit ")"
294− ]
295− match (Comment _ com il) = mconcat <$> sequence
296− [ return $ emit "\n"
297− , mconcat <$> forM com comment
298− , prettyPrintIL' il
299− ]
300− match _ = mzero
301−
302− comment :: (Emit gen) => Comment -> StateT PrinterState Maybe gen
303− comment (LineComment com) = fmap mconcat $ sequence $
304− [ currentIndent
305− , return $ emit "//" <> emit com <> emit "\n"
306− ]
307− comment (BlockComment com) = fmap mconcat $ sequence $
308− [ currentIndent
309− , return $ emit "/**\n"
310− ] ++
311− map asLine (T.lines com) ++
312− [ currentIndent
313− , return $ emit " */\n"
314− , currentIndent
315− ]
316− where
317− asLine :: (Emit gen) => Text -> StateT PrinterState Maybe gen
318− asLine s = do
319− i <- currentIndent
320− return $ i <> emit " * " <> (emit . removeComments) s <> emit "\n"
321−
322− removeComments :: Text -> Text
323− removeComments t =
324− case T.stripPrefix "*/" t of
325− Just rest -> removeComments rest
326− Nothing -> case T.uncons t of
327− Just (x, xs) -> x `T.cons` removeComments xs
328− Nothing -> ""
329−
330−unary' :: (Emit gen) => UnaryOperator -> (AST -> Text) -> Operator PrinterState AST gen
331−unary' op mkStr = Wrap match (<>)
332− where
333− match :: (Emit gen) => Pattern PrinterState AST (gen, AST)
334− match = mkPattern match'
335− where
336− match' (Unary _ op' val) | op' == op = Just (emit $ mkStr val, val)
337− match' _ = Nothing
338−
339−unary :: (Emit gen) => UnaryOperator -> Text -> Operator PrinterState AST gen
340−unary op str = unary' op (const str)
341−
342−negateOperator :: (Emit gen) => Operator PrinterState AST gen
343−negateOperator = unary' Negate (\v -> if isNegate v then "- " else "-")
344− where
345− isNegate (Unary _ Negate _) = True
346− isNegate _ = False
347−
348−binary :: (Emit gen) => BinaryOperator -> Text -> Operator PrinterState AST gen
349−binary op str = AssocL match (\v1 v2 -> v1 <> emit (" " <> str <> " ") <> v2)
350− where
351− match :: Pattern PrinterState AST (AST, AST)
352− match = mkPattern match'
353− where
354− match' (Binary _ op' v1 v2) | op' == op = Just (v1, v2)
355− match' _ = Nothing
356−
357−isLiteral :: AST -> Bool
358−isLiteral Function{} = True
359−isLiteral NumericLiteral{} = True
360−isLiteral StringLiteral{} = True
361−isLiteral BooleanLiteral{} = True
362−isLiteral ObjectLiteral{} = True
363−isLiteral ArrayLiteral{} = True
364−isLiteral _ = False
365−
366−isComplexLiteral :: AST -> Bool
367−-- isComplexLiteral Function{} = True
368−isComplexLiteral ObjectLiteral{} = True
369−isComplexLiteral ArrayLiteral{} = True
370−isComplexLiteral _ = False
371−
372−unApp :: AST -> [AST] -> (AST, [AST])
373−unApp (App _ val [arg]) args = unApp val (arg : args)
374−unApp other args = (other, args)
375−
376−prettyStatements :: (Emit gen) => [AST] -> StateT PrinterState Maybe gen
377−prettyStatements sts = do
378− ils <- forM sts prettyPrintIL'
379− indentString <- currentIndent
380− return $ intercalate (emit "\n") $ map (indentString <>) ils
381−
382−-- | Generate a pretty-printed string representing a collection of C++ expressions at the same indentation level
383−prettyPrintILWithSourceMaps :: [AST] -> (Text, [SMap])
384−prettyPrintILWithSourceMaps il =
385− let StrPos (_, s, mp) = (fromMaybe (internalError "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyStatements) il
386− in (s, mp)
387−
388−prettyPrintIL :: [AST] -> Text
389−prettyPrintIL = maybe (internalError "Incomplete pattern") runPlainString . flip evalStateT (PrinterState 0) . prettyStatements
390−
391−-- | Generate an indented, pretty-printed string representing a C++ expression
392−prettyPrintIL' :: (Emit gen) => AST -> StateT PrinterState Maybe gen
393−prettyPrintIL' = A.runKleisli $ runPattern matchValue
394− where
395− matchValue :: (Emit gen) => Pattern PrinterState AST gen
396− matchValue = buildPrettyPrinter operators (literals <+> fmap parensPos matchValue)
397− operators :: (Emit gen) => OperatorTable PrinterState AST gen
398− operators =
399− OperatorTable [ [ unary New "?" ]
400− , [ unary Not "!"
401− , unary BitwiseNot "~"
402− , unary Positive "+"
403− , negateOperator ]
404− , [ binary Multiply "*"
405− , binary Divide "/"
406− , binary Modulus "%" ]
407− , [ binary Add "+"
408− , binary Subtract "-" ]
409− , [ binary ShiftLeft "<<"
410− , binary ShiftRight ">>" ]
411− , [ binary LessThan "<"
412− , binary LessThanOrEqualTo "<="
413− , binary GreaterThan ">"
414− , binary GreaterThanOrEqualTo ">=" ]
415− , [ binary EqualTo "=="
416− , binary NotEqualTo "!=" ]
417− , [ binary BitwiseAnd "&" ]
418− , [ binary BitwiseXor "^" ]
419− , [ binary BitwiseOr "|" ]
420− , [ binary And "&&" ]
421− , [ binary Or "||" ]
422− ]
423−
424−prettyPrintIL1 :: AST -> Text
425−prettyPrintIL1 = maybe (internalError "Incomplete pattern") runPlainString . flip evalStateT (PrinterState 0) . prettyPrintIL'
426−
427−stringLiteral :: PSString -> Text
428−stringLiteral pss | Just s <- decodeString pss = stringLiteral' s
429− where
430− stringLiteral' :: Text -> Text
431− stringLiteral' s = "\"" <> T.concatMap encodeChar s <> "\""
432− encodeChar :: Char -> Text
433− encodeChar '\0' = "\\x00"
434− encodeChar '\b' = "\\b"
435− encodeChar '\t' = "\\t"
436− encodeChar '\n' = "\\n"
437− encodeChar '\v' = "\\v"
438− encodeChar '\f' = "\\f"
439− encodeChar '\r' = "\\r"
440− encodeChar '"' = "\\\""
441− encodeChar '\\' = "\\\\"
442− encodeChar c = T.singleton $ c
443−stringLiteral _ = "\"\\uFFFD\""
444−
445−interfaceSource :: Text -> [(Text,Bool)] -> [Ident] -> Text
446−interfaceSource _ _ _ = ""
447−
448−implHeaderSource :: Text -> [Text] -> Text -> Text
449−implHeaderSource mn imports otherPrefix =
450− "// Code generated by psgo. DO NOT EDIT.\n\n" <>
451− "package " <> (if mn == "Main" || mn == "Test_Main" then "main" else mn) <> "\n\n" <>
452− "import . \"" <> runtime <> "\"\n" <>
453− (if mn == "Main" || mn == "Test_Main"
454− then "import _ \"" <> otherPrefix <> "/" <> ffiLoader <> "\"\n"
455− else "\n") <>
456− "import (\n" <>
457− (T.concat $ formatImport <$> imports) <> ")\n\n" <>
458− "type _ = Any\n\n"
459− where
460− formatImport :: Text -> Text
461− formatImport s =
462− "\t\"" <> otherPrefix <> "/" <> modPrefix <> "/" <> moduleRenamer s <> "\"\n"
463− moduleRenamer :: Text -> Text
464− moduleRenamer s
465− | (s', sfx) <- T.breakOn moduleRenamerMarker s,
466− not $ T.null sfx = s'
467− moduleRenamer s = s
468−
469−implFooterSource :: Text -> [Ident] -> Text
470−implFooterSource mn foreigns =
471− "\n\n\n" <>
472− (if null foreigns
473− then ""
474− else ("// Foreign values\n\n" <>
475− "var " <> foreignDict <> " = "<> foreignMod <> "(\"" <> mn <> "\")\n\n" <>
476− (T.concat $ (\foreign' ->
477− let name = moduleIdentToIL foreign' in
478− varDecl <> " " <> initName name <> " Once\n" <>
479− varDecl <> " " <> valueName name <> " " <> anyType <> "\n\n" <>
480− "func " <>
481− withPrefix name <>
482− "() Any { \n" <>
483− " " <> initName name <> ".Do(func() {\n" <>
484− " " <> valueName name <> " = " <>
485− "Get(" <> foreignDict <> ", " <>
486− (stringLiteral . mkString $ runIdent foreign') <> ")\n" <>
487− " })\n" <>
488− " return " <> valueName name <> "\n" <>
489− "}\n\n") <$> foreigns))) <>
490− if mn == "Main" || mn == "Test.Main" then mainSource else "\n"
491− where
492− mainSource :: Text
493− mainSource = "\
494− \func main() {\n\
495− \ Run(Ꞌmain())\n\
496− \}\n\n\
497− \"
498−
499−varDecl :: Text
500−varDecl = "var"
501−
502−renderArg :: Text -> Text -> Text
503−renderArg decl arg = arg <> " " <> decl
504−
505−foreignMod :: Text
506−foreignMod = "Foreign"
507−
508−foreignDict :: Text
509−foreignDict = "foreign"
510−
511−modLabel :: Text
512−modLabel = "purescript-native"
513−
514−modPrefix :: Text
515−modPrefix = modLabel <> "/output"
516−
517−runtime :: Text
518−runtime = "github.com/" <> modLabel <> "/go-runtime"
519−
520−ffiLoader :: Text
521−ffiLoader = modLabel <> "/ffi-loader"
522−
523−initName :: Text -> Text
524−initName s = "ᛌ" <> s <> "_once"
525−
526−valueName :: Text -> Text
527−valueName s = "ᛧ" <> s
src/Data/Generics/Extras.hsnew file+28
@@ -0,0 +1,28 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Data.Generics.Extras
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- Additional SYB combinators
13+--
14+-----------------------------------------------------------------------------
15+
16+{-# LANGUAGE Rank2Types #-}
17+
18+module Data.Generics.Extras where
19+
20+import Data.Data
21+
22+-- |
23+-- Apply a top-down monadic transformation everywhere
24+--
25+everywhereM' :: (Monad m, Data d) => (forall d1. (Data d1) => d1 -> m d1) -> d -> m d
26+everywhereM' f x = do
27+ y <- f x
28+ gmapM (everywhereM' f) y
src/Language/PureScript.hsnew file+82
@@ -0,0 +1,82 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- The main compiler module
13+--
14+-----------------------------------------------------------------------------
15+
16+module Language.PureScript (module P, compile) where
17+
18+import Language.PureScript.Values as P
19+import Language.PureScript.Types as P
20+import Language.PureScript.Kinds as P
21+import Language.PureScript.Declarations as P
22+import Language.PureScript.Names as P
23+import Language.PureScript.Parser as P
24+import Language.PureScript.CodeGen as P
25+import Language.PureScript.TypeChecker as P
26+import Language.PureScript.Pretty as P
27+import Language.PureScript.Sugar as P
28+import Language.PureScript.Options as P
29+import Language.PureScript.ModuleDependencies as P
30+import Language.PureScript.DeadCodeElimination as P
31+
32+import Data.List (intercalate)
33+import Data.Maybe (mapMaybe, fromMaybe)
34+import Control.Monad (when, forM)
35+import Control.Monad.State.Lazy
36+import Control.Applicative ((<$>), (<|>))
37+import qualified Data.Map as M
38+
39+-- |
40+-- Compile a collection of modules
41+--
42+-- The compilation pipeline proceeds as follows:
43+--
44+-- * Sort the modules based on module dependencies, checking for cyclic dependencies.
45+--
46+-- * Perform a set of desugaring passes.
47+--
48+-- * Type check, and elaborate values to include type annotations and type class dictionaries.
49+--
50+-- * Regroup values to take into account new value dependencies introduced by elaboration.
51+--
52+-- * Eliminate dead code.
53+--
54+-- * Generate Javascript, and perform optimization passes.
55+--
56+-- * Pretty-print the generated Javascript
57+--
58+compile :: Options -> [Module] -> Either String (String, String, Environment)
59+compile opts ms = do
60+ sorted <- sortModules ms
61+ desugared <- desugar sorted
62+ (elaborated, env) <- runCheck $ forM desugared $ \(Module moduleName decls) -> do
63+ modify (\s -> s { checkCurrentModule = Just moduleName })
64+ Module moduleName <$> typeCheckAll mainModuleIdent moduleName decls
65+ regrouped <- createBindingGroupsModule . collapseBindingGroupsModule $ elaborated
66+ let entryPoints = (ModuleName . splitProperNames) `map` optionsModules opts
67+ let elim = if null entryPoints then regrouped else eliminateDeadCode env entryPoints regrouped
68+ let js = mapMaybe (flip (moduleToJs opts) env) elim
69+ let exts = intercalate "\n" . map (flip moduleToPs env) $ elim
70+ js' <- case optionsMain opts of
71+ Just mainModuleName -> do
72+ when ((ModuleName [ProperName mainModuleName], Ident "main") `M.notMember` (names env)) $
73+ Left $ mainModuleName ++ ".main is undefined"
74+ return $ js ++ [JSApp (JSAccessor "main" (JSAccessor mainModuleName (JSVar "_ps"))) []]
75+ _ -> return js
76+ return (prettyPrintJS [(wrapExportsContainer opts js')], exts, env)
77+ where
78+ mainModuleIdent = ModuleName . splitProperNames <$> optionsMain opts
79+ splitProperNames s = case dropWhile (== '.') s of
80+ "" -> []
81+ s' -> ProperName w : splitProperNames s''
82+ where (w, s'') = break (== '.') s'
src/Language/PureScript/CodeGen.hsnew file+26
@@ -0,0 +1,26 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.CodeGen
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- A collection of modules related to code generation:
13+--
14+-- [@Language.PureScript.CodeGen.JS@] Code generator for Javascript
15+--
16+-- [@Language.PureScript.CodeGen.Externs@] Code generator for extern (foreign import) files
17+--
18+-- [@Language.PureScript.CodeGen.Optimize@] Optimization passes for generated Javascript
19+--
20+-----------------------------------------------------------------------------
21+
22+module Language.PureScript.CodeGen (module C) where
23+
24+import Language.PureScript.CodeGen.JS as C
25+import Language.PureScript.CodeGen.Externs as C
26+import Language.PureScript.CodeGen.Optimize as C
src/Language/PureScript/CodeGen/Common.hsnew file+132
@@ -0,0 +1,132 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.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+-- Common code generation utility functions
13+--
14+-----------------------------------------------------------------------------
15+
16+module Language.PureScript.CodeGen.Common where
17+
18+import Data.Char
19+import Data.List (intercalate)
20+import Language.PureScript.Names
21+
22+-- |
23+-- Convert an Ident into a valid Javascript identifier:
24+--
25+-- * Alphanumeric characters are kept unmodified.
26+--
27+-- * Reserved javascript identifiers are prefixed with '$$'.
28+--
29+-- * Symbols are prefixed with '$' followed by a symbol name or their ordinal value.
30+--
31+identToJs :: Ident -> String
32+identToJs (Ident name) | nameIsJsReserved name = "$$" ++ name
33+identToJs (Ident name) = concatMap identCharToString name
34+identToJs (Op op) = concatMap identCharToString op
35+identToJs (Escaped name) = name
36+
37+-- |
38+-- Attempts to find a human-readable name for a symbol, if none has been specified returns the
39+-- ordinal value.
40+--
41+identCharToString :: Char -> String
42+identCharToString c | isAlphaNum c = [c]
43+identCharToString '_' = "_"
44+identCharToString '.' = "$dot"
45+identCharToString '$' = "$dollar"
46+identCharToString '~' = "$tilde"
47+identCharToString '=' = "$eq"
48+identCharToString '<' = "$less"
49+identCharToString '>' = "$greater"
50+identCharToString '!' = "$bang"
51+identCharToString '#' = "$hash"
52+identCharToString '%' = "$percent"
53+identCharToString '^' = "$up"
54+identCharToString '&' = "$amp"
55+identCharToString '|' = "$bar"
56+identCharToString '*' = "$times"
57+identCharToString '/' = "$div"
58+identCharToString '+' = "$plus"
59+identCharToString '-' = "$minus"
60+identCharToString ':' = "$colon"
61+identCharToString '\\' = "$bslash"
62+identCharToString '?' = "$qmark"
63+identCharToString '@' = "$at"
64+identCharToString '\'' = "$prime"
65+identCharToString c = '$' : show (ord c)
66+
67+-- |
68+-- Checks whether an identifier name is reserved in Javascript.
69+--
70+nameIsJsReserved :: String -> Bool
71+nameIsJsReserved name =
72+ elem name [ "abstract"
73+ , "boolean"
74+ , "break"
75+ , "byte"
76+ , "case"
77+ , "catch"
78+ , "char"
79+ , "class"
80+ , "const"
81+ , "continue"
82+ , "debugger"
83+ , "default"
84+ , "delete"
85+ , "do"
86+ , "double"
87+ , "else"
88+ , "enum"
89+ , "export"
90+ , "extends"
91+ , "final"
92+ , "finally"
93+ , "float"
94+ , "for"
95+ , "function"
96+ , "goto"
97+ , "if"
98+ , "implements"
99+ , "import"
100+ , "in"
101+ , "instanceof"
102+ , "int"
103+ , "interface"
104+ , "let"
105+ , "long"
106+ , "native"
107+ , "new"
108+ , "package"
109+ , "private"
110+ , "protected"
111+ , "public"
112+ , "return"
113+ , "short"
114+ , "static"
115+ , "super"
116+ , "switch"
117+ , "synchronized"
118+ , "this"
119+ , "throw"
120+ , "throws"
121+ , "transient"
122+ , "try"
123+ , "typeof"
124+ , "var"
125+ , "void"
126+ , "volatile"
127+ , "while"
128+ , "with"
129+ , "yield" ]
130+
131+moduleNameToJs :: ModuleName -> String
132+moduleNameToJs (ModuleName pns) = intercalate "_" (runProperName `map` pns)
src/Language/PureScript/CodeGen/Externs.hsnew file+51
@@ -0,0 +1,51 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.CodeGen.Externs
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- This module generates code for \"externs\" files, i.e. files containing only foreign import declarations.
13+--
14+-----------------------------------------------------------------------------
15+
16+module Language.PureScript.CodeGen.Externs (
17+ moduleToPs
18+) where
19+
20+import Data.Maybe (maybeToList, mapMaybe)
21+import qualified Data.Map as M
22+import Language.PureScript.Declarations
23+import Language.PureScript.TypeChecker.Monad
24+import Language.PureScript.Pretty
25+import Language.PureScript.Names
26+import Data.List (intercalate)
27+
28+-- |
29+-- Generate foreign imports for all declarations in a module
30+--
31+moduleToPs :: Module -> Environment -> String
32+moduleToPs (Module mn decls) env =
33+ "module " ++ (runModuleName mn) ++ " where\n" ++
34+ (intercalate "\n" . map (" " ++) . concatMap (declToPs mn env) $ decls)
35+
36+declToPs :: ModuleName -> Environment -> Declaration -> [String]
37+declToPs path env (ValueDeclaration name _ _ _) = maybeToList $ do
38+ (ty, _) <- M.lookup (path, name) $ names env
39+ return $ "foreign import " ++ show name ++ " :: " ++ prettyPrintType ty
40+declToPs path env (BindingGroupDeclaration vals) = do
41+ flip mapMaybe vals $ \(name, _) -> do
42+ (ty, _) <- M.lookup (path, name) $ names env
43+ return $ "foreign import " ++ show name ++ " :: " ++ prettyPrintType ty
44+declToPs path env (DataDeclaration name _ _) = maybeToList $ do
45+ (kind, _) <- M.lookup (path, name) $ types env
46+ return $ "foreign import data " ++ show name ++ " :: " ++ prettyPrintKind kind
47+declToPs _ _ (ExternDataDeclaration name kind) =
48+ return $ "foreign import data " ++ show name ++ " :: " ++ prettyPrintKind kind
49+declToPs _ _ (TypeSynonymDeclaration name args ty) =
50+ return $ "type " ++ show name ++ " " ++ unwords args ++ " = " ++ prettyPrintType ty
51+declToPs _ _ _ = []
src/Language/PureScript/CodeGen/JS.hsnew file+336
@@ -0,0 +1,336 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.CodeGen.JS
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- This module generates code in the simplified Javascript intermediate representation from Purescript code
13+--
14+-----------------------------------------------------------------------------
15+
16+{-# LANGUAGE DoAndIfThenElse #-}
17+
18+module Language.PureScript.CodeGen.JS (
19+ module AST,
20+ declToJs,
21+ moduleToJs,
22+ wrapExportsContainer
23+) where
24+
25+import Data.Maybe (fromMaybe, mapMaybe)
26+import Data.List (sortBy)
27+import Data.Function (on)
28+import Data.Data (Data)
29+import Data.Generics (mkQ, everything)
30+
31+import Control.Arrow (second)
32+import Control.Monad (replicateM, forM)
33+
34+import qualified Data.Map as M
35+
36+import Language.PureScript.TypeChecker (Environment(..), NameKind(..))
37+import Language.PureScript.Values
38+import Language.PureScript.Names
39+import Language.PureScript.Scope
40+import Language.PureScript.Declarations
41+import Language.PureScript.Pretty.Common
42+import Language.PureScript.CodeGen.Monad
43+import Language.PureScript.Options
44+import Language.PureScript.CodeGen.JS.AST as AST
45+import Language.PureScript.Types
46+import Language.PureScript.CodeGen.Optimize
47+import Language.PureScript.CodeGen.Common
48+import Language.PureScript.TypeChecker.Monad (canonicalizeDataConstructor)
49+
50+-- |
51+-- Generate code in the simplified Javascript intermediate representation for all declarations in a
52+-- module.
53+--
54+moduleToJs :: Options -> Module -> Environment -> Maybe JS
55+moduleToJs opts (Module name decls) env =
56+ case jsDecls of
57+ [] -> Nothing
58+ _ -> Just $ JSAssignment (JSAccessor (moduleNameToJs name) (JSVar "_ps")) $
59+ JSApp (JSFunction Nothing ["module"] (JSBlock $ jsDecls ++ [JSReturn $ JSVar "module"]))
60+ [(JSBinary Or (JSAccessor (moduleNameToJs name) (JSVar "_ps")) (JSObjectLiteral []))]
61+ where
62+ jsDecls = (concat $ mapMaybe (\decl -> fmap (map $ optimize opts) $ declToJs opts name decl env) (decls))
63+
64+-- |
65+-- Generate code in the simplified Javascript intermediate representation for a declaration
66+--
67+declToJs :: Options -> ModuleName -> Declaration -> Environment -> Maybe [JS]
68+declToJs opts mp (ValueDeclaration ident _ _ val) e =
69+ Just $ [ JSVariableIntroduction (identToJs ident) (Just (valueToJs opts mp e val))
70+ , setExportProperty ident (var ident) ]
71+declToJs opts mp (BindingGroupDeclaration vals) e =
72+ Just $ concatMap (\(ident, val) ->
73+ [ JSVariableIntroduction (identToJs ident) (Just (valueToJs opts mp e val))
74+ , setExportProperty ident (var ident) ]
75+ ) vals
76+declToJs _ mp (DataDeclaration _ _ ctors) _ =
77+ Just $ flip concatMap ctors $ \(pn@(ProperName ctor), tys) ->
78+ [ JSVariableIntroduction ctor (Just (go pn 0 tys []))
79+ , setExportProperty (Escaped ctor) (JSVar ctor) ]
80+ where
81+ go pn _ [] values =
82+ JSObjectLiteral [ ("ctor", JSStringLiteral (show (Qualified (Just mp) pn))), ("values", JSArrayLiteral $ reverse values) ]
83+ go pn index (_ : tys') values =
84+ JSFunction Nothing ["value" ++ show index]
85+ (JSBlock [JSReturn (go pn (index + 1) tys' (JSVar ("value" ++ show index) : values))])
86+declToJs opts mp (DataBindingGroupDeclaration ds) e =
87+ Just $ concat $ mapMaybe (flip (declToJs opts mp) e) ds
88+declToJs _ mp (ExternDeclaration importTy ident (Just js) _) _ =
89+ Just $ [js, setExportProperty ident (var ident)]
90+declToJs _ _ _ _ = Nothing
91+
92+-- |
93+-- Generate code in the simplified Javascript intermediate representation for exporting a
94+-- declaration from a module.
95+--
96+setExportProperty :: Ident -> JS -> JS
97+setExportProperty ident val = JSAssignment (accessor ident (JSVar "module")) val
98+
99+-- |
100+-- Generate code in the simplified Javascript intermediate representation for a variable based on a
101+-- PureScript identifier.
102+--
103+var :: Ident -> JS
104+var = JSVar . identToJs
105+
106+-- |
107+-- Generate code in the simplified Javascript intermediate representation for an accessor based on
108+-- a PureScript identifier. If the name is not valid in Javascript (symbol based, reserved name) an
109+-- indexer is returned.
110+--
111+accessor :: Ident -> JS -> JS
112+accessor (Ident name) | nameIsJsReserved name = JSIndexer (JSStringLiteral name)
113+accessor (Op op) = JSIndexer (JSStringLiteral op)
114+accessor ident = JSAccessor (identToJs ident)
115+
116+-- |
117+-- Generate code in the simplified Javascript intermediate representation for a value or expression.
118+--
119+valueToJs :: Options -> ModuleName -> Environment -> Value -> JS
120+valueToJs _ _ _ (NumericLiteral n) = JSNumericLiteral n
121+valueToJs _ _ _ (StringLiteral s) = JSStringLiteral s
122+valueToJs _ _ _ (BooleanLiteral b) = JSBooleanLiteral b
123+valueToJs opts m e (ArrayLiteral xs) = JSArrayLiteral (map (valueToJs opts m e) xs)
124+valueToJs opts m e (ObjectLiteral ps) = JSObjectLiteral (map (second (valueToJs opts m e)) ps)
125+valueToJs opts m e (ObjectUpdate o ps) = JSApp (JSAccessor "extend" (JSVar "Object")) [ valueToJs opts m e o, JSObjectLiteral (map (second (valueToJs opts m e)) ps)]
126+valueToJs _ m e (Constructor (Qualified Nothing name)) =
127+ case M.lookup (m, name) (dataConstructors e) of
128+ Just (_, Alias aliasModule aliasIdent) -> qualifiedToJS m id (Qualified (Just aliasModule) aliasIdent)
129+ _ -> JSVar . runProperName $ name
130+valueToJs _ m _ (Constructor name) = qualifiedToJS m (Ident . runProperName) name
131+valueToJs opts m e (Case values binders) = bindersToJs opts m e binders (map (valueToJs opts m e) values)
132+valueToJs opts m e (IfThenElse cond th el) = JSConditional (valueToJs opts m e cond) (valueToJs opts m e th) (valueToJs opts m e el)
133+valueToJs opts m e (Accessor prop val) = JSAccessor prop (valueToJs opts m e val)
134+valueToJs opts m e (App val arg) = JSApp (valueToJs opts m e val) [valueToJs opts m e arg]
135+valueToJs opts m e (Abs arg val) = JSFunction Nothing [identToJs arg] (JSBlock [JSReturn (valueToJs opts m (bindName m arg e) val)])
136+valueToJs opts m e (TypedValue _ (Abs arg val) ty) | optionsPerformRuntimeTypeChecks opts = let arg' = identToJs arg in JSFunction Nothing [arg'] (JSBlock $ runtimeTypeChecks arg' ty ++ [JSReturn (valueToJs opts m e val)])
137+valueToJs _ m e (Var ident) = varToJs m e ident
138+valueToJs opts m e (TypedValue _ val _) = valueToJs opts m e val
139+valueToJs _ _ _ (TypeClassDictionary _ _) = error "Type class dictionary was not replaced"
140+valueToJs _ _ _ _ = error "Invalid argument to valueToJs"
141+
142+-- |
143+-- Temporarily extends the environment with a single local variable name
144+--
145+bindName :: ModuleName -> Ident -> Environment -> Environment
146+bindName m ident = bindNames m [ident]
147+
148+-- |
149+-- Temporarily extends the environment to include local variable names introduced by lambda
150+-- abstractions or case statements
151+--
152+bindNames :: ModuleName -> [Ident] -> Environment -> Environment
153+bindNames m idents env = env { names = M.fromList [ ((m, ident), (noType, LocalVariable)) | ident <- idents ] `M.union` names env }
154+ where
155+ noType = error "Temporary lambda variable type was read"
156+
157+
158+-- |
159+-- Generate code in the simplified Javascript intermediate representation for runtime type checks.
160+--
161+runtimeTypeChecks :: String -> Type -> [JS]
162+runtimeTypeChecks arg ty =
163+ let
164+ argTy = getFunctionArgumentType ty
165+ in
166+ maybe [] (argumentCheck (JSVar arg)) argTy
167+ where
168+ getFunctionArgumentType :: Type -> Maybe Type
169+ getFunctionArgumentType (TypeApp (TypeApp t funArg) _) | t == tyFunction = Just funArg
170+ getFunctionArgumentType (ForAll _ ty' _) = getFunctionArgumentType ty'
171+ getFunctionArgumentType _ = Nothing
172+ argumentCheck :: JS -> Type -> [JS]
173+ argumentCheck val t | t == tyNumber = [typeCheck val "number"]
174+ argumentCheck val t | t == tyString = [typeCheck val "string"]
175+ argumentCheck val t | t == tyBoolean = [typeCheck val "boolean"]
176+ argumentCheck val (TypeApp t _) | t == tyArray = [arrayCheck val]
177+ argumentCheck val (Object row) =
178+ let
179+ (pairs, _) = rowToList row
180+ in
181+ typeCheck val "object" : concatMap (\(prop, ty') -> argumentCheck (JSAccessor prop val) ty') pairs
182+ argumentCheck val (TypeApp (TypeApp t _) _) | t == tyFunction = [typeCheck val "function"]
183+ argumentCheck val (ForAll _ ty' _) = argumentCheck val ty'
184+ argumentCheck _ _ = []
185+ typeCheck :: JS -> String -> JS
186+ typeCheck js ty' = JSIfElse (JSBinary NotEqualTo (JSTypeOf js) (JSStringLiteral ty')) (JSBlock [JSThrow (JSStringLiteral $ ty' ++ " expected")]) Nothing
187+ arrayCheck :: JS -> JS
188+ arrayCheck js = JSIfElse (JSUnary Not (JSApp (JSAccessor "isArray" (JSVar "Array")) [js])) (JSBlock [JSThrow (JSStringLiteral "Array expected")]) Nothing
189+
190+-- |
191+-- Generate code in the simplified Javascript intermediate representation for a reference to a
192+-- variable.
193+--
194+varToJs :: ModuleName -> Environment -> Qualified Ident -> JS
195+varToJs m e qual@(Qualified _ ident) = go qual
196+ where
197+ go qual = case M.lookup (qualify m qual) (names e) of
198+ Just (_, ty) | isExtern ty -> var ident
199+ Just (_, Alias aliasModule aliasIdent) -> go (Qualified (Just aliasModule) aliasIdent)
200+ _ -> case qual of
201+ Qualified Nothing _ -> var ident
202+ _ -> qualifiedToJS m id qual
203+ isExtern (Extern ForeignImport) = True
204+ isExtern (Alias m' ident') = case M.lookup (m', ident') (names e) of
205+ Just (_, ty') -> isExtern ty'
206+ Nothing -> error "Undefined alias in varToJs"
207+ isExtern _ = False
208+
209+-- |
210+-- Generate code in the simplified Javascript intermediate representation for a reference to a
211+-- variable that may have a qualified name.
212+--
213+qualifiedToJS :: ModuleName -> (a -> Ident) -> Qualified a -> JS
214+qualifiedToJS m f (Qualified (Just m') a) | m /= m' = accessor (f a) (JSAccessor (moduleNameToJs m') $ JSVar "_ps")
215+qualifiedToJS m f (Qualified _ a) = JSVar $ identToJs (f a)
216+
217+-- |
218+-- Generate code in the simplified Javascript intermediate representation for pattern match binders
219+-- and guards.
220+--
221+bindersToJs :: Options -> ModuleName -> Environment -> [([Binder], Maybe Guard, Value)] -> [JS] -> JS
222+bindersToJs opts m e binders vals = runGen (map identToJs (unusedNames (binders, vals))) $ do
223+ valNames <- replicateM (length vals) fresh
224+ jss <- forM binders $ \(bs, grd, result) -> go valNames [JSReturn (valueToJs opts m (bindNames m (binderNames bs) e) result)] bs grd
225+ return $ JSApp (JSFunction Nothing valNames (JSBlock (concat jss ++ [JSThrow (JSStringLiteral "Failed pattern match")])))
226+ vals
227+ where
228+ go :: [String] -> [JS] -> [Binder] -> Maybe Guard -> Gen [JS]
229+ go _ done [] Nothing = return done
230+ go _ done [] (Just cond) = return [JSIfElse (valueToJs opts m e cond) (JSBlock done) Nothing]
231+ go (v:vs) done' (b:bs) grd = do
232+ done'' <- go vs done' bs grd
233+ binderToJs m e v done'' b
234+ go _ _ _ _ = error "Invalid arguments to bindersToJs"
235+
236+-- |
237+-- Collect all names introduced in binders in an expression
238+--
239+binderNames :: (Data d) => d -> [Ident]
240+binderNames = everything (++) (mkQ [] go)
241+ where
242+ go (VarBinder ident) = [ident]
243+ go _ = []
244+
245+-- |
246+-- Generate code in the simplified Javascript intermediate representation for a pattern match
247+-- binder.
248+--
249+binderToJs :: ModuleName -> Environment -> String -> [JS] -> Binder -> Gen [JS]
250+binderToJs _ _ _ done NullBinder = return done
251+binderToJs _ _ varName done (StringBinder str) =
252+ return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSStringLiteral str)) (JSBlock done) Nothing]
253+binderToJs _ _ varName done (NumberBinder num) =
254+ return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSNumericLiteral num)) (JSBlock done) Nothing]
255+binderToJs _ _ varName done (BooleanBinder True) =
256+ return [JSIfElse (JSVar varName) (JSBlock done) Nothing]
257+binderToJs _ _ varName done (BooleanBinder False) =
258+ return [JSIfElse (JSUnary Not (JSVar varName)) (JSBlock done) Nothing]
259+binderToJs m e varName done (VarBinder ident) =
260+ return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : done)
261+binderToJs m e varName done (ConstructorBinder ctor bs) = do
262+ js <- go 0 done bs
263+ if isOnlyConstructor m e ctor
264+ then
265+ return js
266+ else
267+ return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar varName)) (JSStringLiteral (show ((\(mp, nm) -> Qualified (Just mp) nm) $ canonicalizeDataConstructor m e ctor))))
268+ (JSBlock js)
269+ Nothing]
270+ where
271+ go :: Integer -> [JS] -> [Binder] -> Gen [JS]
272+ go _ done' [] = return done'
273+ go index done' (binder:bs') = do
274+ argVar <- fresh
275+ done'' <- go (index + 1) done' bs'
276+ js <- binderToJs m e argVar done'' binder
277+ return (JSVariableIntroduction argVar (Just (JSIndexer (JSNumericLiteral (Left index)) (JSAccessor "values" (JSVar varName)))) : js)
278+binderToJs m e varName done (ObjectBinder bs) = go done bs
279+ where
280+ go :: [JS] -> [(String, Binder)] -> Gen [JS]
281+ go done' [] = return done'
282+ go done' ((prop, binder):bs') = do
283+ propVar <- fresh
284+ done'' <- go done' bs'
285+ js <- binderToJs m e propVar done'' binder
286+ return (JSVariableIntroduction propVar (Just (JSAccessor prop (JSVar varName))) : js)
287+binderToJs m e varName done (ArrayBinder bs) = do
288+ js <- go done 0 bs
289+ return [JSIfElse (JSBinary EqualTo (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (Left (fromIntegral $ length bs)))) (JSBlock js) Nothing]
290+ where
291+ go :: [JS] -> Integer -> [Binder] -> Gen [JS]
292+ go done' _ [] = return done'
293+ go done' index (binder:bs') = do
294+ elVar <- fresh
295+ done'' <- go done' (index + 1) bs'
296+ js <- binderToJs m e elVar done'' binder
297+ return (JSVariableIntroduction elVar (Just (JSIndexer (JSNumericLiteral (Left index)) (JSVar varName))) : js)
298+binderToJs m e varName done (ConsBinder headBinder tailBinder) = do
299+ headVar <- fresh
300+ tailVar <- fresh
301+ js1 <- binderToJs m e headVar done headBinder
302+ js2 <- binderToJs m e tailVar js1 tailBinder
303+ return [JSIfElse (JSBinary GreaterThan (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (Left 0))) (JSBlock
304+ ( JSVariableIntroduction headVar (Just (JSIndexer (JSNumericLiteral (Left 0)) (JSVar varName))) :
305+ JSVariableIntroduction tailVar (Just (JSApp (JSAccessor "slice" (JSVar varName)) [JSNumericLiteral (Left 1)])) :
306+ js2
307+ )) Nothing]
308+binderToJs m e varName done (NamedBinder ident binder) = do
309+ js <- binderToJs m e varName done binder
310+ return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : js)
311+
312+-- |
313+-- Checks whether a data constructor is the only constructor for that type, used to simplify the
314+-- check when generating code for binders.
315+--
316+isOnlyConstructor :: ModuleName -> Environment -> Qualified ProperName -> Bool
317+isOnlyConstructor m e ctor =
318+ let (ty, _) = fromMaybe (error "Data constructor not found") $ qualify m ctor `M.lookup` dataConstructors e
319+ in numConstructors ty == 1
320+ where
321+ numConstructors ty = length $ filter (\(ty1, _) -> ((==) `on` typeConstructor) ty ty1) $ M.elems $ dataConstructors e
322+ typeConstructor (TypeConstructor qual) = qualify m qual
323+ typeConstructor (ForAll _ ty _) = typeConstructor ty
324+ typeConstructor (TypeApp (TypeApp t _) ty) | t == tyFunction = typeConstructor ty
325+ typeConstructor (TypeApp ty _) = typeConstructor ty
326+ typeConstructor fn = error $ "Invalid arguments to typeConstructor: " ++ show fn
327+
328+wrapExportsContainer :: Options -> [JS] -> JS
329+wrapExportsContainer opts modules = JSApp (JSFunction Nothing ["_ps"] $ JSBlock $ (JSStringLiteral "use strict") : modules) [exportSelector]
330+ where
331+ exportSelector = JSConditional (JSBinary And (JSBinary NotEqualTo (JSTypeOf $ JSVar "module") (JSStringLiteral "undefined")) (JSAccessor "exports" (JSVar "module")))
332+ (JSAccessor "exports" (JSVar "module"))
333+ (JSConditional (JSBinary NotEqualTo (JSTypeOf $ JSVar "window") (JSStringLiteral "undefined"))
334+ (JSAssignment (JSAccessor browserNamespace (JSVar "window")) (JSBinary Or (JSAccessor browserNamespace (JSVar "window")) (JSObjectLiteral [])))
335+ (JSApp (JSFunction Nothing [] $ JSBlock [JSThrow $ JSStringLiteral "PureScript doesn't know how to export modules in the current environment"]) []))
336+ browserNamespace = optionsBrowserNamespace opts
src/Language/PureScript/CodeGen/JS/AST.hsnew file+233
@@ -0,0 +1,233 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.CodeGen.JS.AST
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- Data types for the intermediate simplified-Javascript AST
13+--
14+-----------------------------------------------------------------------------
15+
16+{-# LANGUAGE DeriveDataTypeable #-}
17+
18+module Language.PureScript.CodeGen.JS.AST where
19+
20+import Data.Data
21+
22+
23+
24+-- |
25+-- Built-in unary operators
26+--
27+data UnaryOperator
28+ -- |
29+ -- Numeric negation
30+ --
31+ = Negate
32+ -- |
33+ -- Boolean negation
34+ --
35+ | Not
36+ -- |
37+ -- Bitwise negation
38+ --
39+ | BitwiseNot
40+ -- |
41+ -- Numeric unary \'plus\'
42+ --
43+ | Positive deriving (Show, Eq, Data, Typeable)
44+
45+-- |
46+-- Built-in binary operators
47+--
48+data BinaryOperator
49+ -- |
50+ -- Numeric addition
51+ --
52+ = Add
53+ -- |
54+ -- Numeric subtraction
55+ --
56+ | Subtract
57+ -- |
58+ -- Numeric multiplication
59+ --
60+ | Multiply
61+ -- |
62+ -- Numeric division
63+ --
64+ | Divide
65+ -- |
66+ -- Remainder
67+ --
68+ | Modulus
69+ -- |
70+ -- Generic equality test
71+ --
72+ | EqualTo
73+ -- |
74+ -- Generic inequality test
75+ --
76+ | NotEqualTo
77+ -- |
78+ -- Numeric less-than
79+ --
80+ | LessThan
81+ -- |
82+ -- Numeric less-than-or-equal
83+ --
84+ | LessThanOrEqualTo
85+ -- |
86+ -- Numeric greater-than
87+ --
88+ | GreaterThan
89+ -- |
90+ -- Numeric greater-than-or-equal
91+ --
92+ | GreaterThanOrEqualTo
93+ -- |
94+ -- Boolean and
95+ --
96+ | And
97+ -- |
98+ -- Boolean or
99+ --
100+ | Or
101+ -- |
102+ -- Bitwise and
103+ --
104+ | BitwiseAnd
105+ -- |
106+ -- Bitwise or
107+ --
108+ | BitwiseOr
109+ -- |
110+ -- Bitwise xor
111+ --
112+ | BitwiseXor
113+ -- |
114+ -- Bitwise left shift
115+ --
116+ | ShiftLeft
117+ -- |
118+ -- Bitwise right shift
119+ --
120+ | ShiftRight
121+ -- |
122+ -- Bitwise right shift with zero-fill
123+ --
124+ | ZeroFillShiftRight deriving (Show, Eq, Data, Typeable)
125+
126+-- |
127+-- Data type for simplified Javascript expressions
128+--
129+data JS
130+ -- |
131+ -- A numeric literal
132+ --
133+ = JSNumericLiteral (Either Integer Double)
134+ -- |
135+ -- A string literal
136+ --
137+ | JSStringLiteral String
138+ -- |
139+ -- A boolean literal
140+ --
141+ | JSBooleanLiteral Bool
142+ -- |
143+ -- A unary operator application
144+ --
145+ | JSUnary UnaryOperator JS
146+ -- |
147+ -- A binary operator application
148+ --
149+ | JSBinary BinaryOperator JS JS
150+ -- |
151+ -- An array literal
152+ --
153+ | JSArrayLiteral [JS]
154+ -- |
155+ -- An array indexer expression
156+ --
157+ | JSIndexer JS JS
158+ -- |
159+ -- An object literal
160+ --
161+ | JSObjectLiteral [(String, JS)]
162+ -- |
163+ -- An object property accessor expression
164+ --
165+ | JSAccessor String JS
166+ -- |
167+ -- A function introduction (optional name, arguments, body)
168+ --
169+ | JSFunction (Maybe String) [String] JS
170+ -- |
171+ -- Function application
172+ --
173+ | JSApp JS [JS]
174+ -- |
175+ -- Variable
176+ --
177+ | JSVar String
178+ -- |
179+ -- Conditional expression
180+ --
181+ | JSConditional JS JS JS
182+ -- |
183+ -- A block of expressions in braces
184+ --
185+ | JSBlock [JS]
186+ -- |
187+ -- A variable introduction and optional initialization
188+ --
189+ | JSVariableIntroduction String (Maybe JS)
190+ -- |
191+ -- A variable assignment
192+ --
193+ | JSAssignment JS JS
194+ -- |
195+ -- While loop
196+ --
197+ | JSWhile JS JS
198+ -- |
199+ -- For loop
200+ --
201+ | JSFor String JS JS JS
202+ -- |
203+ -- If-then-else statement
204+ --
205+ | JSIfElse JS JS (Maybe JS)
206+ -- |
207+ -- Return statement
208+ --
209+ | JSReturn JS
210+ -- |
211+ -- Throw statement
212+ --
213+ | JSThrow JS
214+ -- |
215+ -- Type-Of operator
216+ --
217+ | JSTypeOf JS
218+ -- |
219+ -- Labelled statement
220+ --
221+ | JSLabel String JS
222+ -- |
223+ -- Break statement
224+ --
225+ | JSBreak String
226+ -- |
227+ -- Continue statement
228+ --
229+ | JSContinue String
230+ -- |
231+ -- Raw Javascript (generated when parsing fails for an inline foreign import declaration)
232+ --
233+ | JSRaw String deriving (Show, Eq, Data, Typeable)
src/Language/PureScript/CodeGen/Monad.hsnew file+44
@@ -0,0 +1,44 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.CodeGen.Monad
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- Code generation monad
13+--
14+-- This monad provides a supply of fresh names which can be used to create variables.
15+--
16+-----------------------------------------------------------------------------
17+
18+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
19+
20+module Language.PureScript.CodeGen.Monad where
21+
22+import Control.Monad.State
23+import Control.Applicative
24+import Language.PureScript.Names
25+
26+-- |
27+-- Code generation monad data type
28+--
29+newtype Gen a = Gen { unGen :: State [String] a } deriving (Functor, Applicative, Monad, MonadState [String])
30+
31+-- |
32+-- Run a computation in the code generation monad
33+--
34+runGen :: [String] -> Gen a -> a
35+runGen names = flip evalState names . unGen
36+
37+-- |
38+-- Generate a fresh name
39+--
40+fresh :: Gen String
41+fresh = do
42+ (s:ss) <- get
43+ put ss
44+ return s
src/Language/PureScript/CodeGen/Optimize.hsnew file+474
@@ -0,0 +1,474 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Optimize
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- This module optimizes code in the simplified-Javascript intermediate representation.
13+--
14+-- The following optimizations are supported:
15+--
16+-- * Collapsing nested blocks
17+--
18+-- * Tail call elimination
19+--
20+-- * Inlining of (>>=) and ret for the Eff monad
21+--
22+-- * Removal of unused variables
23+--
24+-- * Removal of unnecessary thunks
25+--
26+-- * Eta conversion
27+--
28+-- * Inlining variables
29+--
30+-- * Inline Prelude.($), Prelude.(#), Prelude.(++), Prelude.(!!)
31+--
32+-- * Inlining primitive Javascript operators
33+--
34+-----------------------------------------------------------------------------
35+
36+module Language.PureScript.CodeGen.Optimize (
37+ optimize
38+) where
39+
40+import Data.Data
41+import Data.List (nub)
42+import Data.Maybe (fromJust, isJust, fromMaybe)
43+import Data.Generics
44+
45+import Language.PureScript.Names
46+import Language.PureScript.CodeGen.JS.AST
47+import Language.PureScript.Options
48+import Language.PureScript.CodeGen.Common (identToJs)
49+import Language.PureScript.Sugar.TypeClasses
50+ (mkDictionaryValueName)
51+import Language.PureScript.Types
52+
53+-- |
54+-- Apply a series of optimizer passes to simplified Javascript code
55+--
56+optimize :: Options -> JS -> JS
57+optimize opts | optionsNoOptimizations opts = id
58+ | otherwise = untilFixedPoint $ applyAll
59+ [ collapseNestedBlocks
60+ , tco opts
61+ , magicDo opts
62+ , removeUnusedVariables
63+ , unThunk
64+ , etaConvert
65+ , inlineVariables
66+ , inlineOperator "$" $ \f x -> JSApp f [x]
67+ , inlineOperator "#" $ \x f -> JSApp f [x]
68+ , inlineOperator "!!" $ flip JSIndexer
69+ , inlineOperator "++" $ JSBinary Add
70+ , inlineCommonOperators ]
71+
72+applyAll :: [a -> a] -> a -> a
73+applyAll = foldl1 (.)
74+
75+untilFixedPoint :: (Eq a) => (a -> a) -> a -> a
76+untilFixedPoint f a = go a
77+ where
78+ go a' = let a'' = f a' in
79+ if a'' == a' then a'' else go a''
80+
81+replaceIdent :: (Data d) => String -> JS -> d -> d
82+replaceIdent var1 js = everywhere (mkT replace)
83+ where
84+ replace (JSVar var2) | var1 == var2 = js
85+ replace other = other
86+
87+replaceIdents :: (Data d) => [(String, JS)] -> d -> d
88+replaceIdents vars = everywhere (mkT replace)
89+ where
90+ replace v@(JSVar var) = fromMaybe v $ lookup var vars
91+ replace other = other
92+
93+isReassigned :: (Data d) => String -> d -> Bool
94+isReassigned var1 = everything (||) (mkQ False check)
95+ where
96+ check :: JS -> Bool
97+ check (JSFunction _ args _) | var1 `elem` args = True
98+ check (JSVariableIntroduction arg _) | var1 == arg = True
99+ check (JSAssignment (JSVar arg) _) | var1 == arg = True
100+ check _ = False
101+
102+isRebound :: (Data d) => JS -> d -> Bool
103+isRebound js d = any (\var -> isReassigned var d) (everything (++) (mkQ [] variablesOf) js)
104+ where
105+ variablesOf (JSVar var) = [var]
106+ variablesOf _ = []
107+
108+isUsed :: (Data d) => String -> d -> Bool
109+isUsed var1 = everything (||) (mkQ False check)
110+ where
111+ check :: JS -> Bool
112+ check (JSVar var2) | var1 == var2 = True
113+ check (JSAssignment target _) | var1 == targetVariable target = True
114+ check _ = False
115+
116+targetVariable :: JS -> String
117+targetVariable (JSVar var) = var
118+targetVariable (JSAccessor _ tgt) = targetVariable tgt
119+targetVariable (JSIndexer _ tgt) = targetVariable tgt
120+targetVariable _ = error "Invalid argument to targetVariable"
121+
122+isUpdated :: (Data d) => String -> d -> Bool
123+isUpdated var1 = everything (||) (mkQ False check)
124+ where
125+ check :: JS -> Bool
126+ check (JSAssignment target _) | var1 == targetVariable target = True
127+ check _ = False
128+
129+shouldInline :: JS -> Bool
130+shouldInline (JSVar _) = True
131+shouldInline (JSNumericLiteral _) = True
132+shouldInline (JSStringLiteral _) = True
133+shouldInline (JSBooleanLiteral _) = True
134+shouldInline (JSAccessor _ val) = shouldInline val
135+shouldInline (JSIndexer index val) = shouldInline index && shouldInline val
136+shouldInline _ = False
137+
138+inlineVariables :: JS -> JS
139+inlineVariables = everywhere (mkT removeFromBlock)
140+ where
141+ removeFromBlock :: JS -> JS
142+ removeFromBlock (JSBlock sts) = JSBlock (go sts)
143+ removeFromBlock js = js
144+ go :: [JS] -> [JS]
145+ go [] = []
146+ go (s@(JSVariableIntroduction var (Just js)) : sts)
147+ | shouldInline js && not (isReassigned var sts) && not (isRebound js sts) && not (isUpdated var sts) =
148+ go (replaceIdent var js sts)
149+ go (s:sts) = s : go sts
150+
151+removeUnusedVariables :: JS -> JS
152+removeUnusedVariables = everywhere (mkT removeFromBlock)
153+ where
154+ removeFromBlock :: JS -> JS
155+ removeFromBlock (JSBlock sts) = JSBlock (go sts)
156+ removeFromBlock js = js
157+ go :: [JS] -> [JS]
158+ go [] = []
159+ go (JSVariableIntroduction var _ : sts) | not (isUsed var sts) = go sts
160+ go (s:sts) = s : go sts
161+
162+etaConvert :: JS -> JS
163+etaConvert = everywhere (mkT convert)
164+ where
165+ convert :: JS -> JS
166+ convert (JSBlock [JSReturn (JSApp (JSFunction Nothing idents block@(JSBlock body)) args)])
167+ | all shouldInline args &&
168+ not (any (flip isRebound block) (map JSVar idents)) &&
169+ not (or (map (flip isRebound block) args))
170+ = JSBlock (replaceIdents (zip idents args) body)
171+ convert js = js
172+
173+unThunk :: JS -> JS
174+unThunk = everywhere (mkT convert)
175+ where
176+ convert :: JS -> JS
177+ convert (JSBlock [JSReturn (JSApp (JSFunction Nothing [] (JSBlock body)) [])]) = JSBlock body
178+ convert js = js
179+
180+tco :: Options -> JS -> JS
181+tco opts | optionsTco opts = tco'
182+ | otherwise = id
183+
184+tco' :: JS -> JS
185+tco' = everywhere (mkT convert)
186+ where
187+ tcoLabel :: String
188+ tcoLabel = "tco"
189+ tcoVar :: String -> String
190+ tcoVar arg = "__tco_" ++ arg
191+ copyVar :: String -> String
192+ copyVar arg = "__copy_" ++ arg
193+ convert :: JS -> JS
194+ convert js@(JSVariableIntroduction name (Just fn@(JSFunction _ _ _))) =
195+ let
196+ (argss, body', replace) = collectAllFunctionArgs [] id fn
197+ in case () of
198+ _ | isTailCall name body' ->
199+ let
200+ allArgs = reverse $ concat argss
201+ in
202+ JSVariableIntroduction name (Just (replace (toLoop name allArgs body')))
203+ | otherwise -> js
204+ convert js = js
205+ collectAllFunctionArgs :: [[String]] -> (JS -> JS) -> JS -> ([[String]], JS, JS -> JS)
206+ collectAllFunctionArgs allArgs f (JSFunction ident args (JSBlock (body@(JSReturn _):_))) =
207+ collectAllFunctionArgs (args : allArgs) (\b -> f (JSFunction ident (map copyVar args) (JSBlock [b]))) body
208+ collectAllFunctionArgs allArgs f (JSFunction ident args body@(JSBlock _)) =
209+ (args : allArgs, body, \b -> f (JSFunction ident (map copyVar args) b))
210+ collectAllFunctionArgs allArgs f (JSReturn (JSFunction ident args (JSBlock [body]))) =
211+ collectAllFunctionArgs (args : allArgs) (\b -> f (JSReturn (JSFunction ident (map copyVar args) (JSBlock [b])))) body
212+ collectAllFunctionArgs allArgs f (JSReturn (JSFunction ident args body@(JSBlock _))) =
213+ (args : allArgs, body, \b -> f (JSReturn (JSFunction ident (map copyVar args) b)))
214+ collectAllFunctionArgs allArgs f body = (allArgs, body, f)
215+ isTailCall :: String -> JS -> Bool
216+ isTailCall ident js =
217+ let
218+ numSelfCalls = everything (+) (mkQ 0 countSelfCalls) js
219+ numSelfCallsInTailPosition = everything (+) (mkQ 0 countSelfCallsInTailPosition) js
220+ numSelfCallsUnderFunctions = everything (+) (mkQ 0 countSelfCallsUnderFunctions) js
221+ in
222+ numSelfCalls > 0
223+ && numSelfCalls == numSelfCallsInTailPosition
224+ && numSelfCallsUnderFunctions == 0
225+ where
226+ countSelfCalls :: JS -> Int
227+ countSelfCalls (JSApp (JSVar ident') _) | ident == ident' = 1
228+ countSelfCalls _ = 0
229+ countSelfCallsInTailPosition :: JS -> Int
230+ countSelfCallsInTailPosition (JSReturn ret) | isSelfCall ident ret = 1
231+ countSelfCallsInTailPosition _ = 0
232+ countSelfCallsUnderFunctions (JSFunction _ _ js') = everything (+) (mkQ 0 countSelfCalls) js'
233+ countSelfCallsUnderFunctions _ = 0
234+ toLoop :: String -> [String] -> JS -> JS
235+ toLoop ident allArgs js = JSBlock $
236+ map (\arg -> JSVariableIntroduction arg (Just (JSVar (copyVar arg)))) allArgs ++
237+ [ JSLabel tcoLabel $ JSWhile (JSBooleanLiteral True) (JSBlock [ everywhere (mkT loopify) js ]) ]
238+ where
239+ loopify :: JS -> JS
240+ loopify (JSReturn ret) | isSelfCall ident ret =
241+ let
242+ allArgumentValues = concat $ collectSelfCallArgs [] ret
243+ in
244+ JSBlock $ zipWith (\val arg ->
245+ JSVariableIntroduction (tcoVar arg) (Just val)) allArgumentValues allArgs
246+ ++ map (\arg ->
247+ JSAssignment (JSVar arg) (JSVar (tcoVar arg))) allArgs
248+ ++ [ JSContinue tcoLabel ]
249+ loopify other = other
250+ collectSelfCallArgs :: [[JS]] -> JS -> [[JS]]
251+ collectSelfCallArgs allArgumentValues (JSApp fn args') = collectSelfCallArgs (args' : allArgumentValues) fn
252+ collectSelfCallArgs allArgumentValues _ = allArgumentValues
253+ isSelfCall :: String -> JS -> Bool
254+ isSelfCall ident (JSApp (JSVar ident') _) | ident == ident' = True
255+ isSelfCall ident (JSApp fn _) = isSelfCall ident fn
256+ isSelfCall _ _ = False
257+
258+magicDo :: Options -> JS -> JS
259+magicDo opts | optionsMagicDo opts = inlineST . magicDo'
260+ | otherwise = id
261+
262+-- |
263+-- Inline type class dictionaries for >>= and return for the Eff monad
264+--
265+-- E.g.
266+--
267+-- Prelude[">>="](dict)(m1)(function(x) {
268+-- return ...;
269+-- })
270+--
271+-- becomes
272+--
273+-- function __do {
274+-- var x = m1();
275+-- ...
276+-- }
277+--
278+magicDo' :: JS -> JS
279+magicDo' = everywhere (mkT undo) . everywhere' (mkT convert)
280+ where
281+ -- The name of the function block which is added to denote a do block
282+ fnName = "__do"
283+ -- Desugar monomorphic calls to >>= and return for the Eff monad
284+ convert :: JS -> JS
285+ -- Desugar return
286+ convert (JSApp (JSApp ret [val]) []) | isReturn ret = val
287+ -- Desugae >>
288+ convert (JSApp (JSApp bind [m]) [JSFunction Nothing ["_"] (JSBlock [JSReturn ret])]) | isBind bind =
289+ JSFunction (Just fnName) [] $ JSBlock [ JSApp m [], JSReturn (JSApp ret []) ]
290+ -- Desugar >>=
291+ convert (JSApp (JSApp bind [m]) [JSFunction Nothing [arg] (JSBlock [JSReturn ret])]) | isBind bind =
292+ JSFunction (Just fnName) [] $ JSBlock [ JSVariableIntroduction arg (Just (JSApp m [])), JSReturn (JSApp ret []) ]
293+ -- Desugar untilE
294+ convert (JSApp (JSApp f [arg]) []) | isEffFunc "untilE" f =
295+ JSApp (JSFunction Nothing [] (JSBlock [ JSWhile (JSUnary Not (JSApp arg [])) (JSBlock []), JSReturn (JSObjectLiteral []) ])) []
296+ -- Desugar whileE
297+ convert (JSApp (JSApp (JSApp f [arg1]) [arg2]) []) | isEffFunc "whileE" f =
298+ JSApp (JSFunction Nothing [] (JSBlock [ JSWhile (JSApp arg1 []) (JSBlock [ JSApp arg2 [] ]), JSReturn (JSObjectLiteral []) ])) []
299+ convert other = other
300+ -- Check if an expression represents a monomorphic call to >>= for the Eff monad
301+ isBind (JSApp bindPoly [effDict]) | isBindPoly bindPoly && isEffDict effDict = True
302+ isBind _ = False
303+ -- Check if an expression represents a monomorphic call to return for the Eff monad
304+ isReturn (JSApp retPoly [effDict]) | isRetPoly retPoly && isEffDict effDict = True
305+ isReturn _ = False
306+ -- Check if an expression represents the polymorphic >>= function
307+ isBindPoly (JSAccessor prop (JSAccessor "Prelude" (JSVar "_ps"))) | prop == identToJs (Op ">>=") = True
308+ isBindPoly (JSIndexer (JSStringLiteral ">>=") (JSAccessor "Prelude" (JSVar "_ps"))) = True
309+ isBindPoly _ = False
310+ -- Check if an expression represents the polymorphic return function
311+ isRetPoly (JSAccessor "$return" (JSAccessor "Prelude" (JSVar "_ps"))) = True
312+ isRetPoly (JSIndexer (JSStringLiteral "return") (JSAccessor "Prelude" (JSVar "_ps"))) = True
313+ isRetPoly _ = False
314+ -- Check if an expression represents a function in the Ef module
315+ isEffFunc name (JSAccessor name' (JSAccessor "Eff" (JSVar "_ps"))) | name == name' = True
316+ isEffFunc _ _ = False
317+ -- Module names
318+ prelude = ModuleName [ProperName "Prelude"]
319+ effModule = ModuleName [ProperName "Eff"]
320+ -- The name of the type class dictionary for the Monad Eff instance
321+ Right (Ident effDictName) = mkDictionaryValueName
322+ effModule
323+ (Qualified (Just prelude) (ProperName "Monad"))
324+ (TypeConstructor (Qualified (Just effModule) (ProperName "Eff")))
325+ -- Check if an expression represents the Monad Eff dictionary
326+ isEffDict (JSApp (JSVar ident) [JSObjectLiteral []]) | ident == effDictName = True
327+ isEffDict (JSApp (JSAccessor prop (JSAccessor "Eff" (JSVar "_ps"))) [JSObjectLiteral []]) | prop == effDictName = True
328+ isEffDict _ = False
329+ -- Remove __do function applications which remain after desugaring
330+ undo :: JS -> JS
331+ undo (JSReturn (JSApp (JSFunction (Just ident) [] body) [])) | ident == fnName = body
332+ undo other = other
333+
334+-- |
335+-- Inline functions in the ST module
336+--
337+inlineST :: JS -> JS
338+inlineST = everywhere (mkT convertBlock)
339+ where
340+ -- Look for runST blocks and inline the STRefs there.
341+ -- If all STRefs are used in the scope of the same runST, only using { read, write, modify }STRef then
342+ -- we can be more aggressive about inlining, and actually turn STRefs into local variables.
343+ convertBlock (JSApp f [arg]) | isSTFunc "runST" f || isSTFunc "runSTArray" f =
344+ let refs = nub . findSTRefsIn $ arg
345+ usages = findAllSTUsagesIn arg
346+ allUsagesAreLocalVars = all (\u -> let v = toVar u in isJust v && fromJust v `elem` refs) usages
347+ localVarsDoNotEscape = all (\r -> length (r `appearingIn` arg) == length (filter (\u -> let v = toVar u in v == Just r) usages)) refs
348+ in everywhere (mkT $ convert allUsagesAreLocalVars) arg
349+ convertBlock other = other
350+ -- Convert a block in a safe way, preserving object wrappers of references,
351+ -- or in a more aggressive way, turning wrappers into local variables depending on the
352+ -- agg(ressive) parameter.
353+ convert agg (JSApp (JSApp f [arg]) []) | isSTFunc "newSTRef" f =
354+ if agg then arg else JSObjectLiteral [("value", arg)]
355+ convert agg (JSApp (JSApp f [ref]) []) | isSTFunc "readSTRef" f =
356+ if agg then ref else JSAccessor "value" ref
357+ convert agg (JSApp (JSApp (JSApp f [ref]) [arg]) []) | isSTFunc "writeSTRef" f =
358+ if agg then JSAssignment ref arg else JSAssignment (JSAccessor "value" ref) arg
359+ convert agg (JSApp (JSApp (JSApp f [ref]) [func]) []) | isSTFunc "modifySTRef" f =
360+ if agg then JSAssignment ref (JSApp func [ref]) else JSAssignment (JSAccessor "value" ref) (JSApp func [JSAccessor "value" ref])
361+ convert _ (JSApp (JSApp (JSApp f [arr]) [i]) []) | isSTFunc "peekSTArray" f =
362+ (JSIndexer i arr)
363+ convert _ (JSApp (JSApp (JSApp (JSApp f [arr]) [i]) [val]) []) | isSTFunc "pokeSTArray" f =
364+ JSAssignment (JSIndexer i arr) val
365+ convert _ other = other
366+ -- Check if an expression represents a function in the ST module
367+ isSTFunc name (JSAccessor name' (JSAccessor "ST" (JSVar "_ps"))) | name == name' = True
368+ isSTFunc _ _ = False
369+ -- Find all ST Refs initialized in this block
370+ findSTRefsIn = everything (++) (mkQ [] isSTRef)
371+ where
372+ isSTRef (JSVariableIntroduction ident (Just (JSApp (JSApp f [arg]) []))) | isSTFunc "newSTRef" f = [ident]
373+ isSTRef _ = []
374+ -- Find all STRefs used as arguments to readSTRef, writeSTRef, modifySTRef
375+ findAllSTUsagesIn = everything (++) (mkQ [] isSTUsage)
376+ where
377+ isSTUsage (JSApp (JSApp f [ref]) []) | isSTFunc "readSTRef" f = [ref]
378+ isSTUsage (JSApp (JSApp (JSApp f [ref]) [_]) []) | isSTFunc "writeSTRef" f || isSTFunc "modifySTRef" f = [ref]
379+ isSTUsage _ = []
380+ -- Find all uses of a variable
381+ appearingIn ref = everything (++) (mkQ [] isVar)
382+ where
383+ isVar e@(JSVar v) | v == ref = [e]
384+ isVar _ = []
385+ -- Convert a JS value to a String if it is a JSVar
386+ toVar (JSVar v) = Just v
387+ toVar _ = Nothing
388+
389+collapseNestedBlocks :: JS -> JS
390+collapseNestedBlocks = everywhere (mkT collapse)
391+ where
392+ collapse :: JS -> JS
393+ collapse (JSBlock sts) = JSBlock (concatMap go sts)
394+ collapse js = js
395+ go :: JS -> [JS]
396+ go (JSBlock sts) = sts
397+ go s = [s]
398+
399+inlineOperator :: String -> (JS -> JS -> JS) -> JS -> JS
400+inlineOperator op f = everywhere (mkT convert)
401+ where
402+ convert :: JS -> JS
403+ convert (JSApp (JSApp op [x]) [y]) | isOp op = f x y
404+ convert other = other
405+ isOp (JSAccessor longForm (JSAccessor "Prelude" (JSVar "_ps"))) | longForm == identToJs (Op op) = True
406+ isOp (JSIndexer (JSStringLiteral op') (JSAccessor "Prelude" (JSVar "_ps"))) | op == op' = True
407+ isOp _ = False
408+
409+inlineCommonOperators :: JS -> JS
410+inlineCommonOperators = applyAll
411+ [ binary "+" "Num" tyNumber Add
412+ , binary "-" "Num" tyNumber Subtract
413+ , binary "*" "Num" tyNumber Multiply
414+ , binary "/" "Num" tyNumber Divide
415+ , binary "%" "Num" tyNumber Modulus
416+ , unary "negate" "Num" tyNumber Negate
417+
418+ , binary "<" "Ord" tyNumber LessThan
419+ , binary ">" "Ord" tyNumber GreaterThan
420+ , binary "<=" "Ord" tyNumber LessThanOrEqualTo
421+ , binary ">=" "Ord" tyNumber GreaterThanOrEqualTo
422+
423+ , binary "==" "Eq" tyNumber EqualTo
424+ , binary "/=" "Eq" tyNumber NotEqualTo
425+ , binary "==" "Eq" tyString EqualTo
426+ , binary "/=" "Eq" tyString NotEqualTo
427+ , binary "==" "Eq" tyBoolean EqualTo
428+ , binary "/=" "Eq" tyBoolean NotEqualTo
429+
430+ , binaryFunction "shl" "Bits" tyNumber ShiftLeft
431+ , binaryFunction "shr" "Bits" tyNumber ShiftRight
432+ , binaryFunction "zshr" "Bits" tyNumber ZeroFillShiftRight
433+ , binary "&" "Bits" tyNumber BitwiseAnd
434+ , binary "|" "Bits" tyNumber BitwiseOr
435+ , binary "^" "Bits" tyNumber BitwiseXor
436+ , unary "complement" "Bits" tyNumber BitwiseNot
437+
438+ , binary "&&" "BoolLike" tyBoolean And
439+ , binary "||" "BoolLike" tyBoolean Or
440+ , unary "not" "BoolLike" tyBoolean Not
441+ ]
442+ where
443+ binary :: String -> String -> Type -> BinaryOperator -> JS -> JS
444+ binary opString className classTy op = everywhere (mkT convert)
445+ where
446+ convert :: JS -> JS
447+ convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict className classTy dict = JSBinary op x y
448+ convert other = other
449+ isOp (JSAccessor longForm (JSAccessor "Prelude" (JSVar ps))) | longForm == identToJs (Op opString) = True
450+ isOp (JSIndexer (JSStringLiteral op') (JSAccessor "Prelude" (JSVar "_ps"))) | opString == op' = True
451+ isOp _ = False
452+ binaryFunction :: String -> String -> Type -> BinaryOperator -> JS -> JS
453+ binaryFunction fnName className classTy op = everywhere (mkT convert)
454+ where
455+ convert :: JS -> JS
456+ convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict className classTy dict = JSBinary op x y
457+ convert other = other
458+ isOp (JSAccessor fnName' (JSAccessor "Prelude" (JSVar "_ps"))) | fnName == fnName' = True
459+ isOp _ = False
460+ unary :: String -> String -> Type -> UnaryOperator -> JS -> JS
461+ unary fnName className classTy op = everywhere (mkT convert)
462+ where
463+ convert :: JS -> JS
464+ convert (JSApp (JSApp fn [dict]) [x]) | isOp fn && isOpDict className classTy dict = JSUnary op x
465+ convert other = other
466+ isOp (JSAccessor fnName' (JSAccessor "Prelude" (JSVar "_ps"))) | fnName' == fnName = True
467+ isOp _ = False
468+ isOpDict className ty (JSApp (JSAccessor prop (JSAccessor "Prelude" (JSVar "_ps"))) [JSObjectLiteral []]) | prop == dictName = True
469+ where
470+ Right (Ident dictName) = mkDictionaryValueName
471+ (ModuleName [ProperName "Prim"])
472+ (Qualified (Just (ModuleName [ProperName "Prelude"])) (ProperName className))
473+ ty
474+ isOpDict _ _ _ = False
src/Language/PureScript/DeadCodeElimination.hsnew file+76
@@ -0,0 +1,76 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.DeadCodeElimination
4+-- Copyright : (c) 2014 Phil Freeman
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+module Language.PureScript.DeadCodeElimination (
16+ eliminateDeadCode
17+) where
18+
19+import Data.Data
20+import Data.List
21+import Data.Graph
22+import Data.Generics
23+import Data.Maybe (mapMaybe)
24+
25+import Language.PureScript.Names
26+import Language.PureScript.Values
27+import Language.PureScript.Declarations
28+import Language.PureScript.TypeChecker.Monad
29+
30+-- |
31+-- Eliminate all declarations which are not a transitive dependency of the entry point module
32+--
33+eliminateDeadCode :: Environment -> [ModuleName] -> [Module] -> [Module]
34+eliminateDeadCode env entryPoints ms =
35+ let declarations = concatMap (declarationsByModule env) ms
36+ (graph, _, vertexFor) = graphFromEdges $ map (\(key, deps) -> (key, key, deps)) declarations
37+ entryPointVertices = mapMaybe (vertexFor . fst) . filter (\((mn, _), _) -> mn `elem` entryPoints) $ declarations
38+ in flip map ms $ \(Module moduleName ds) -> Module moduleName (filter (isUsed (moduleName) graph vertexFor entryPointVertices) ds)
39+
40+type Key = (ModuleName, Either Ident ProperName)
41+
42+declarationsByModule :: Environment -> Module -> [(Key, [Key])]
43+declarationsByModule env (Module moduleName ds) = concatMap go $ ds
44+ where
45+ go :: Declaration -> [(Key, [Key])]
46+ go d@(ValueDeclaration name _ _ _) = [((moduleName, Left name), dependencies env (moduleName) d)]
47+ go (DataDeclaration _ _ dctors) = map (\(name, _) -> ((moduleName, Right name), [])) dctors
48+ go (ExternDeclaration _ name _ _) = [((moduleName, Left name), [])]
49+ go d@(BindingGroupDeclaration names) = map (\(name, _) -> ((moduleName, Left name), dependencies env moduleName d)) names
50+ go (DataBindingGroupDeclaration ds) = concatMap go ds
51+ go _ = []
52+
53+dependencies :: (Data d) => Environment -> ModuleName -> d -> [Key]
54+dependencies env moduleName = nub . everything (++) (mkQ [] values)
55+ where
56+ values :: Value -> [Key]
57+ values (Var ident) = let (mn, name) = canonicalize moduleName env ident in [(mn, Left name)]
58+ values (Constructor pn) = let (mn, name) = canonicalizeDataConstructor moduleName env pn in [(mn, Right name)]
59+ values _ = []
60+
61+isUsed :: ModuleName -> Graph -> (Key -> Maybe Vertex) -> [Vertex] -> Declaration -> Bool
62+isUsed moduleName graph vertexFor entryPointVertices (ValueDeclaration name _ _ _) =
63+ let Just v' = vertexFor (moduleName, Left name)
64+ in any (\v -> path graph v v') entryPointVertices
65+isUsed moduleName graph vertexFor entryPointVertices (DataDeclaration _ _ dctors) =
66+ any (\(pn, _) -> let Just v' = vertexFor (moduleName, Right pn)
67+ in any (\v -> path graph v v') entryPointVertices) dctors
68+isUsed moduleName graph vertexFor entryPointVertices (ExternDeclaration _ name _ _) =
69+ let Just v' = vertexFor (moduleName, Left name)
70+ in any (\v -> path graph v v') entryPointVertices
71+isUsed moduleName graph vertexFor entryPointVertices (BindingGroupDeclaration ds) =
72+ any (\(name, _) -> let Just v' = vertexFor (moduleName, Left name)
73+ in any (\v -> path graph v v') entryPointVertices) ds
74+isUsed moduleName graph vertexFor entryPointVertices (DataBindingGroupDeclaration ds) =
75+ any (isUsed moduleName graph vertexFor entryPointVertices) ds
76+isUsed _ _ _ _ _ = True
src/Language/PureScript/Declarations.hsnew file+171
@@ -0,0 +1,171 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Declarations
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- | Data types for modules and declarations
12+--
13+-----------------------------------------------------------------------------
14+
15+{-# LANGUAGE DeriveDataTypeable #-}
16+
17+module Language.PureScript.Declarations where
18+
19+import Language.PureScript.Values
20+import Language.PureScript.Types
21+import Language.PureScript.Names
22+import Language.PureScript.Kinds
23+import Language.PureScript.CodeGen.JS.AST
24+
25+import qualified Data.Data as D
26+
27+-- |
28+-- A precedence level for an infix operator
29+--
30+type Precedence = Integer
31+
32+-- |
33+-- Associativity for infix operators
34+--
35+data Associativity = Infixl | Infixr deriving (Show, D.Data, D.Typeable)
36+
37+-- |
38+-- Fixity data for infix operators
39+--
40+data Fixity = Fixity Associativity Precedence deriving (Show, D.Data, D.Typeable)
41+
42+-- |
43+-- A module declaration, consisting of a module name and a list of declarations
44+--
45+data Module = Module ModuleName [Declaration] deriving (Show, D.Data, D.Typeable)
46+
47+-- |
48+-- The type of a foreign import
49+--
50+data ForeignImportType
51+ -- |
52+ -- A regular foreign import
53+ --
54+ = ForeignImport
55+ -- |
56+ -- A foreign import which contains inline Javascript as a string literal
57+ --
58+ | InlineJavascript
59+ -- |
60+ -- A type class dictionary import, generated during desugaring of type class declarations
61+ --
62+ | TypeClassDictionaryImport
63+ -- |
64+ -- A type class dictionary member accessor import, generated during desugaring of type class declarations
65+ --
66+ | TypeClassAccessorImport deriving (Show, Eq, D.Data, D.Typeable)
67+
68+-- |
69+-- The data type of declarations
70+--
71+data Declaration
72+ -- |
73+ -- A data type declaration (name, arguments, data constructors)
74+ --
75+ = DataDeclaration ProperName [String] [(ProperName, [Type])]
76+ -- |
77+ -- A minimal mutually recursive set of data type declarations
78+ --
79+ | DataBindingGroupDeclaration [Declaration]
80+ -- |
81+ -- A type synonym declaration (name, arguments, type)
82+ --
83+ | TypeSynonymDeclaration ProperName [String] Type
84+ -- |
85+ -- A type declaration for a value (name, ty)
86+ --
87+ | TypeDeclaration Ident Type
88+ -- |
89+ -- A value declaration (name, top-level binders, optional guard, value)
90+ --
91+ | ValueDeclaration Ident [Binder] (Maybe Guard) Value
92+ -- |
93+ -- A minimal mutually recursive set of value declarations
94+ --
95+ | BindingGroupDeclaration [(Ident, Value)]
96+ -- |
97+ -- A foreign import declaration (type, name, optional inline Javascript, type)
98+ --
99+ | ExternDeclaration ForeignImportType Ident (Maybe JS) Type
100+ -- |
101+ -- A data type foreign import (name, kind)
102+ --
103+ | ExternDataDeclaration ProperName Kind
104+ -- |
105+ -- A fixity declaration (fixity data, operator name)
106+ --
107+ | FixityDeclaration Fixity String
108+ -- |
109+ -- A module import (module name, optional set of identifiers to import)
110+ --
111+ | ImportDeclaration ModuleName (Maybe [Either Ident ProperName])
112+ -- |
113+ -- A type class declaration (name, argument, member declarations)
114+ --
115+ | TypeClassDeclaration ProperName String [Declaration]
116+ -- |
117+ -- A type instance declaration (dependencies, class name, instance type, member declarations)
118+ --
119+ | TypeInstanceDeclaration [(Qualified ProperName, Type)] (Qualified ProperName) Type [Declaration]
120+ deriving (Show, D.Data, D.Typeable)
121+
122+-- |
123+-- Test if a declaration is a value declaration
124+--
125+isValueDecl :: Declaration -> Bool
126+isValueDecl (ValueDeclaration _ _ _ _) = True
127+isValueDecl _ = False
128+
129+-- |
130+-- Test if a declaration is a data type or type synonym declaration
131+--
132+isDataDecl :: Declaration -> Bool
133+isDataDecl (DataDeclaration _ _ _) = True
134+isDataDecl (TypeSynonymDeclaration _ _ _) = True
135+isDataDecl _ = False
136+
137+-- |
138+-- Test if a declaration is a module import
139+--
140+isImportDecl :: Declaration -> Bool
141+isImportDecl (ImportDeclaration _ _) = True
142+isImportDecl _ = False
143+
144+-- |
145+-- Test if a declaration is a data type foreign import
146+--
147+isExternDataDecl :: Declaration -> Bool
148+isExternDataDecl (ExternDataDeclaration _ _) = True
149+isExternDataDecl _ = False
150+
151+-- |
152+-- Test if a declaration is a fixity declaration
153+--
154+isFixityDecl :: Declaration -> Bool
155+isFixityDecl (FixityDeclaration _ _) = True
156+isFixityDecl _ = False
157+
158+-- |
159+-- Test if a declaration is a foreign import
160+--
161+isExternDecl :: Declaration -> Bool
162+isExternDecl (ExternDeclaration _ _ _ _) = True
163+isExternDecl _ = False
164+
165+-- |
166+-- Test if a declaration is a type class or instance declaration
167+--
168+isTypeClassDeclaration :: Declaration -> Bool
169+isTypeClassDeclaration (TypeClassDeclaration _ _ _) = True
170+isTypeClassDeclaration (TypeInstanceDeclaration _ _ _ _) = True
171+isTypeClassDeclaration _ = False
src/Language/PureScript/Kinds.hsnew file+46
@@ -0,0 +1,46 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Kinds
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+{-# LANGUAGE DeriveDataTypeable #-}
16+
17+module Language.PureScript.Kinds where
18+
19+import Data.Data
20+
21+import Control.Monad.Unify (Unknown)
22+
23+-- |
24+-- The data type of kinds
25+--
26+data Kind
27+ -- |
28+ -- Unification variable of type Kind
29+ --
30+ = KUnknown Unknown
31+ -- |
32+ -- The kind of types
33+ --
34+ | Star
35+ -- |
36+ -- The kind of effects
37+ --
38+ | Bang
39+ -- |
40+ -- Kinds for labelled, unordered rows without duplicates
41+ --
42+ | Row Kind
43+ -- |
44+ -- Function kinds
45+ --
46+ | FunKind Kind Kind deriving (Show, Eq, Data, Typeable)
src/Language/PureScript/ModuleDependencies.hsnew file+65
@@ -0,0 +1,65 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.ModuleDependencies
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- | Provides the ability to sort modules based on module dependencies
12+--
13+-----------------------------------------------------------------------------
14+
15+module Language.PureScript.ModuleDependencies (
16+ sortModules
17+) where
18+
19+import Data.Data
20+import Data.Graph
21+import Data.Generics
22+import Data.List (nub, intersect)
23+import Control.Applicative ((<$>))
24+
25+import Language.PureScript.Declarations
26+import Language.PureScript.Names
27+import Language.PureScript.Values
28+import Language.PureScript.Types
29+
30+-- |
31+-- Sort a collection of modules based on module dependencies.
32+--
33+-- Reports an error if the module graph contains a cycle.
34+--
35+sortModules :: [Module] -> Either String [Module]
36+sortModules ms = do
37+ let verts = map (\m -> (m, getModuleName m, usedModules m)) ms
38+ mapM toModule $ stronglyConnComp verts
39+
40+-- |
41+-- Calculate a list of used modules based on explicit imports and qualified names
42+--
43+usedModules :: (Data d) => d -> [ModuleName]
44+usedModules = nub . everything (++) (mkQ [] qualifiedIdents `extQ` qualifiedProperNames `extQ` imports)
45+ where
46+ qualifiedIdents :: Qualified Ident -> [ModuleName]
47+ qualifiedIdents (Qualified (Just mn) _) = [mn]
48+ qualifiedIdents _ = []
49+ qualifiedProperNames :: Qualified ProperName -> [ModuleName]
50+ qualifiedProperNames (Qualified (Just mn) _) = [mn]
51+ qualifiedProperNames _ = []
52+ imports :: Declaration -> [ModuleName]
53+ imports (ImportDeclaration mn _) = [mn]
54+ imports _ = []
55+
56+getModuleName :: Module -> ModuleName
57+getModuleName (Module mn _) = mn
58+
59+-- |
60+-- Convert a strongly connected component of the module graph to a module
61+--
62+toModule :: SCC Module -> Either String Module
63+toModule (AcyclicSCC m) = return m
64+toModule (CyclicSCC [m]) = return m
65+toModule (CyclicSCC _) = Left "Cycle in module dependencies"
src/Language/PureScript/Names.hsnew file+90
@@ -0,0 +1,90 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Names
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- Data types for names
13+--
14+-----------------------------------------------------------------------------
15+
16+{-# LANGUAGE DeriveDataTypeable #-}
17+
18+module Language.PureScript.Names where
19+
20+import Data.List
21+import Data.Data
22+import Data.Function (on)
23+
24+-- |
25+-- Names for value identifiers
26+--
27+data Ident
28+ -- |
29+ -- An alphanumeric identifier
30+ --
31+ = Ident String
32+ -- |
33+ -- A symbolic name for an infix operator
34+ --
35+ | Op String
36+ -- |
37+ -- An escaped name
38+ --
39+ | Escaped String deriving (Data, Typeable)
40+
41+instance Show Ident where
42+ show (Ident s) = s
43+ show (Op op) = '(':op ++ ")"
44+ show (Escaped s) = s
45+
46+instance Eq Ident where
47+ Ident s1 == Ident s2 = s1 == s2
48+ Op s1 == Op s2 = s1 == s2
49+ Escaped s1 == Escaped s2 = s1 == s2
50+ Ident s1 == Escaped s2 = s1 == s2
51+ Escaped s1 == Ident s2 = s1 == s2
52+ _ == _ = False
53+
54+instance Ord Ident where
55+ compare = compare `on` show
56+
57+-- |
58+-- Proper names, i.e. capitalized names for e.g. module names, type//data constructors.
59+--
60+newtype ProperName = ProperName { runProperName :: String } deriving (Eq, Ord, Data, Typeable)
61+
62+instance Show ProperName where
63+ show = runProperName
64+
65+-- |
66+-- Module names
67+--
68+data ModuleName = ModuleName [ProperName] deriving (Eq, Ord, Data, Typeable)
69+
70+runModuleName :: ModuleName -> String
71+runModuleName (ModuleName pns) = intercalate "." (runProperName `map` pns)
72+
73+instance Show ModuleName where
74+ show = runModuleName
75+
76+-- |
77+-- A qualified name, i.e. a name with an optional module name
78+--
79+data Qualified a = Qualified (Maybe ModuleName) a deriving (Eq, Ord, Data, Typeable)
80+
81+instance (Show a) => Show (Qualified a) where
82+ show (Qualified Nothing a) = show a
83+ show (Qualified (Just name) a) = show name ++ "." ++ show a
84+
85+-- |
86+-- Provide a default module name, if a name is unqualified
87+--
88+qualify :: ModuleName -> Qualified a -> (ModuleName, a)
89+qualify m (Qualified Nothing a) = (m, a)
90+qualify _ (Qualified (Just m) a) = (m, a)
src/Language/PureScript/Options.hsnew file+58
@@ -0,0 +1,58 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Options
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- The data type of compiler options
13+--
14+-----------------------------------------------------------------------------
15+
16+module Language.PureScript.Options where
17+
18+-- |
19+-- The data type of compiler options
20+--
21+data Options = Options {
22+ -- |
23+ -- Perform tail-call elimination
24+ --
25+ optionsTco :: Bool
26+ -- |
27+ -- Perform type checks at runtime
28+ --
29+ , optionsPerformRuntimeTypeChecks :: Bool
30+ -- |
31+ -- Inline calls to ret and bind for the Eff monad
32+ --
33+ , optionsMagicDo :: Bool
34+ -- |
35+ -- When specified, checks the type of `main` in the module, and generate a call to run main
36+ -- after the module definitions.
37+ --
38+ , optionsMain :: Maybe String
39+ -- |
40+ -- Skip all optimizations
41+ --
42+ , optionsNoOptimizations :: Bool
43+ -- |
44+ -- Specify the namespace that PureScript modules will be exported to when running in the
45+ -- browser.
46+ --
47+ , optionsBrowserNamespace :: String
48+ -- |
49+ -- The modules to keep while enabling dead code elimination
50+ --
51+ , optionsModules :: [String]
52+ } deriving Show
53+
54+-- |
55+-- Default compiler options
56+--
57+defaultOptions :: Options
58+defaultOptions = Options False False False Nothing False "PS" []
src/Language/PureScript/Parser.hsnew file+35
@@ -0,0 +1,35 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Parser
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- A collection of parsers for core data types:
13+--
14+-- [@Language.PureScript.Parser.Kinds@] Parser for kinds
15+--
16+-- [@Language.PureScript.Parser.Values@] Parser for values
17+--
18+-- [@Language.PureScript.Parser.Types@] Parser for types
19+--
20+-- [@Language.PureScript.Parser.Declaration@] Parsers for declarations and modules
21+--
22+-- [@Language.PureScript.Parser.State@] Parser state, including indentation
23+--
24+-- [@Language.PureScript.Parser.Common@] Common parsing utility functions
25+--
26+-----------------------------------------------------------------------------
27+
28+module Language.PureScript.Parser (module P) where
29+
30+import Language.PureScript.Parser.Common as P
31+import Language.PureScript.Parser.Types as P
32+import Language.PureScript.Parser.Values as P
33+import Language.PureScript.Parser.State as P
34+import Language.PureScript.Parser.Kinds as P
35+import Language.PureScript.Parser.Declarations as P
src/Language/PureScript/Parser/Common.hsnew file+371
@@ -0,0 +1,371 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Parser.Common
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- Constants, and utility functions to be used when parsing
13+--
14+-----------------------------------------------------------------------------
15+
16+{-# LANGUAGE FlexibleContexts #-}
17+
18+module Language.PureScript.Parser.Common where
19+
20+import Data.Functor.Identity
21+import Control.Applicative
22+import Control.Monad
23+import Language.PureScript.Parser.State
24+import qualified Text.Parsec as P
25+import qualified Text.Parsec.Token as PT
26+
27+import Language.PureScript.Names
28+
29+-- |
30+-- A list of purescript reserved identifiers
31+--
32+reservedPsNames :: [String]
33+reservedPsNames = [ "data"
34+ , "type"
35+ , "foreign"
36+ , "import"
37+ , "infixl"
38+ , "infixr"
39+ , "class"
40+ , "instance"
41+ , "module"
42+ , "case"
43+ , "of"
44+ , "if"
45+ , "then"
46+ , "else"
47+ , "do"
48+ , "let"
49+ , "true"
50+ , "false"
51+ , "until"
52+ , "let"
53+ , "in"
54+ ]
55+
56+-- |
57+-- A list of reserved identifiers for types
58+--
59+reservedTypeNames :: [String]
60+reservedTypeNames = [ "forall"
61+ , "where" ]
62+
63+-- |
64+-- A list of reserved operators
65+--
66+reservedOpNames :: [String]
67+reservedOpNames = [ "=>", "->", "=", ".", "\\" ]
68+
69+-- |
70+-- Valid first characters for an identifier
71+--
72+identStart :: P.Parsec String u Char
73+identStart = P.lower <|> P.oneOf "_"
74+
75+-- |
76+-- Valid identifier characters
77+--
78+identLetter :: P.Parsec String u Char
79+identLetter = P.alphaNum <|> P.oneOf "_'"
80+
81+-- |
82+-- Valid first characters for an operator
83+--
84+opStart :: P.Parsec String u Char
85+opStart = P.oneOf ":!#$%&*+./<=>?@\\^|-~"
86+
87+-- |
88+-- Valid operators characters
89+--
90+opLetter :: P.Parsec String u Char
91+opLetter = P.oneOf ":!#$%&*+./<=>?@\\^|-~"
92+
93+-- |
94+-- The PureScript language definition
95+--
96+langDef :: PT.GenLanguageDef String u Identity
97+langDef = PT.LanguageDef
98+ { PT.reservedNames = reservedPsNames
99+ , PT.reservedOpNames = reservedOpNames
100+ , PT.commentStart = "{-"
101+ , PT.commentEnd = "-}"
102+ , PT.commentLine = "--"
103+ , PT.nestedComments = True
104+ , PT.identStart = identStart
105+ , PT.identLetter = identLetter
106+ , PT.opStart = opStart
107+ , PT.opLetter = opLetter
108+ , PT.caseSensitive = True
109+ }
110+
111+-- |
112+-- A token parser based on the language definition
113+--
114+tokenParser :: PT.GenTokenParser String u Identity
115+tokenParser = PT.makeTokenParser langDef
116+
117+-- |
118+-- Parse a token
119+--
120+lexeme :: P.Parsec String u a -> P.Parsec String u a
121+lexeme = PT.lexeme tokenParser
122+
123+-- |
124+-- Parse an identifier
125+--
126+identifier :: P.Parsec String u String
127+identifier = PT.identifier tokenParser
128+
129+-- |
130+-- Parse a reserved word
131+--
132+reserved :: String -> P.Parsec String u ()
133+reserved = PT.reserved tokenParser
134+
135+-- |
136+-- Parse a reserved operator
137+--
138+reservedOp :: String -> P.Parsec String u ()
139+reservedOp = PT.reservedOp tokenParser
140+
141+-- |
142+-- Parse an operator
143+--
144+operator :: P.Parsec String u String
145+operator = PT.operator tokenParser
146+
147+-- |
148+-- Parse a string literal
149+--
150+stringLiteral :: P.Parsec String u String
151+stringLiteral = PT.stringLiteral tokenParser
152+
153+-- |
154+-- Parse whitespace
155+--
156+whiteSpace :: P.Parsec String u ()
157+whiteSpace = PT.whiteSpace tokenParser
158+
159+-- |
160+-- Semicolon
161+--
162+semi :: P.Parsec String u String
163+semi = PT.semi tokenParser
164+
165+-- |
166+-- Colon
167+--
168+colon :: P.Parsec String u String
169+colon = PT.colon tokenParser
170+
171+-- |
172+-- Period
173+--
174+dot :: P.Parsec String u String
175+dot = PT.dot tokenParser
176+
177+-- |
178+-- Comma
179+--
180+comma :: P.Parsec String u String
181+comma = PT.comma tokenParser
182+
183+-- |
184+-- Backtick
185+--
186+tick :: P.Parsec String u Char
187+tick = lexeme $ P.char '`'
188+
189+-- |
190+-- Pipe character
191+--
192+pipe :: P.Parsec String u Char
193+pipe = lexeme $ P.char '|'
194+
195+-- |
196+-- Natural number
197+--
198+natural :: P.Parsec String u Integer
199+natural = PT.natural tokenParser
200+
201+-- |
202+-- Parse a proper name
203+--
204+properName :: P.Parsec String u ProperName
205+properName = lexeme $ ProperName <$> P.try ((:) <$> P.upper <*> many P.alphaNum P.<?> "name")
206+
207+-- |
208+-- Parse a module name
209+--
210+moduleName :: P.Parsec String ParseState ModuleName
211+moduleName = ModuleName <$> P.try (sepBy properName dot)
212+
213+-- |
214+-- Parse a qualified name, i.e. M.name or just name
215+--
216+parseQualified :: P.Parsec String ParseState a -> P.Parsec String ParseState (Qualified a)
217+parseQualified parser = part []
218+ where
219+ part path = (do name <- P.try (properName <* delimiter)
220+ part (updatePath path name))
221+ <|> (Qualified (qual path) <$> P.try parser)
222+ delimiter = indented *> dot <* P.notFollowedBy dot
223+ updatePath path name = path ++ [name]
224+ qual path = if null path then Nothing else Just $ ModuleName path
225+
226+-- |
227+-- Parse an integer or floating point value
228+--
229+integerOrFloat :: P.Parsec String u (Either Integer Double)
230+integerOrFloat = (Right <$> P.try (PT.float tokenParser) <|>
231+ Left <$> P.try (PT.natural tokenParser)) P.<?> "number"
232+
233+-- |
234+-- Parse an identifier or parenthesized operator
235+--
236+parseIdent :: P.Parsec String ParseState Ident
237+parseIdent = (Ident <$> identifier) <|> (Op <$> parens operator)
238+
239+-- |
240+-- Parse a token inside square brackets
241+--
242+squares :: P.Parsec String ParseState a -> P.Parsec String ParseState a
243+squares = P.between (lexeme $ P.char '[') (lexeme $ indented *> P.char ']') . (indented *>)
244+
245+-- |
246+-- Parse a token inside parentheses
247+--
248+parens :: P.Parsec String ParseState a -> P.Parsec String ParseState a
249+parens = P.between (lexeme $ P.char '(') (lexeme $ indented *> P.char ')') . (indented *>)
250+
251+-- |
252+-- Parse a token inside braces
253+--
254+braces :: P.Parsec String ParseState a -> P.Parsec String ParseState a
255+braces = P.between (lexeme $ P.char '{') (lexeme $ indented *> P.char '}') . (indented *>)
256+
257+-- |
258+-- Parse a token inside angle brackets
259+--
260+angles :: P.Parsec String ParseState a -> P.Parsec String ParseState a
261+angles = P.between (lexeme $ P.char '<') (lexeme $ indented *> P.char '>') . (indented *>)
262+
263+-- |
264+-- Parse zero or more values separated by a separator token
265+--
266+sepBy :: P.Parsec String ParseState a -> P.Parsec String ParseState sep -> P.Parsec String ParseState [a]
267+sepBy p s = P.sepBy (indented *> p) (indented *> s)
268+
269+-- |
270+-- Parse one or more values separated by a separator token
271+--
272+sepBy1 :: P.Parsec String ParseState a -> P.Parsec String ParseState sep -> P.Parsec String ParseState [a]
273+sepBy1 p s = P.sepBy1 (indented *> p) (indented *> s)
274+
275+-- |
276+-- Parse zero or more values separated by semicolons
277+--
278+semiSep :: P.Parsec String ParseState a -> P.Parsec String ParseState [a]
279+semiSep = flip sepBy semi
280+
281+-- |
282+-- Parse one or more values separated by semicolons
283+--
284+semiSep1 :: P.Parsec String ParseState a -> P.Parsec String ParseState [a]
285+semiSep1 = flip sepBy1 semi
286+
287+-- |
288+-- Parse zero or more values separated by commas
289+--
290+commaSep :: P.Parsec String ParseState a -> P.Parsec String ParseState [a]
291+commaSep = flip sepBy comma
292+
293+-- |
294+-- Parse one or more values separated by commas
295+--
296+commaSep1 :: P.Parsec String ParseState a -> P.Parsec String ParseState [a]
297+commaSep1 = flip sepBy1 comma
298+
299+-- |
300+-- Run the first parser, then match the second if possible, applying the specified function on a successful match
301+--
302+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
303+augment p q f = flip (maybe id $ flip f) <$> p <*> P.optionMaybe q
304+
305+-- |
306+-- Run the first parser, then match the second zero or more times, applying the specified function for each match
307+--
308+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
309+fold first more combine = do
310+ a <- first
311+ bs <- P.many more
312+ return $ foldl combine a bs
313+
314+-- |
315+-- Build a parser from a smaller parser and a list of parsers for postfix operators
316+--
317+buildPostfixParser :: P.Stream s m t => [a -> P.ParsecT s u m a] -> P.ParsecT s u m a -> P.ParsecT s u m a
318+buildPostfixParser fs first = do
319+ a <- first
320+ go a
321+ where
322+ go a = do
323+ maybeA <- P.optionMaybe $ P.choice (map ($ a) fs)
324+ case maybeA of
325+ Nothing -> return a
326+ Just a' -> go a'
327+
328+-- |
329+-- Parse an identifier in backticks or an operator
330+--
331+parseIdentInfix :: P.Parsec String ParseState (Qualified Ident)
332+parseIdentInfix = (P.between tick tick (parseQualified (Ident <$> identifier))) <|> Qualified Nothing <$> (Op <$> operator)
333+
334+-- |
335+-- Mark the current indentation level
336+--
337+mark :: P.Parsec String ParseState a -> P.Parsec String ParseState a
338+mark p = do
339+ current <- indentationLevel <$> P.getState
340+ pos <- P.sourceColumn <$> P.getPosition
341+ P.modifyState $ \st -> st { indentationLevel = pos }
342+ a <- p
343+ P.modifyState $ \st -> st { indentationLevel = current }
344+ return a
345+
346+-- |
347+-- Check that the current identation level matches a predicate
348+--
349+checkIndentation :: (P.Column -> P.Column -> Bool) -> P.Parsec String ParseState ()
350+checkIndentation rel = do
351+ col <- P.sourceColumn <$> P.getPosition
352+ current <- indentationLevel <$> P.getState
353+ guard (col `rel` current)
354+
355+-- |
356+-- Check that the current indentation level is past the current mark
357+--
358+indented :: P.Parsec String ParseState ()
359+indented = checkIndentation (>) P.<?> "indentation"
360+
361+-- |
362+-- Check that the current indentation level is at the same indentation as the current mark
363+--
364+same :: P.Parsec String ParseState ()
365+same = checkIndentation (==) P.<?> "no indentation"
366+
367+-- |
368+-- Run a parser which supports indentation
369+--
370+runIndentParser :: FilePath -> P.Parsec String ParseState a -> String -> Either P.ParseError a
371+runIndentParser filePath p = P.runParser p (ParseState 0) filePath
src/Language/PureScript/Parser/Declarations.hsnew file+150
@@ -0,0 +1,150 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Parser.Declarations
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- Parsers for module definitions and declarations
13+--
14+-----------------------------------------------------------------------------
15+
16+module Language.PureScript.Parser.Declarations (
17+ parseDeclaration,
18+ parseModule,
19+ parseModules
20+) where
21+
22+import Data.Maybe (isJust, fromMaybe)
23+import Control.Monad (when)
24+import Control.Applicative
25+import qualified Text.Parsec as P
26+
27+import Language.PureScript.Names
28+import Language.PureScript.Parser.State
29+import Language.PureScript.Parser.Common
30+import Language.PureScript.Declarations
31+import Language.PureScript.Parser.Values
32+import Language.PureScript.Parser.Types
33+import Language.PureScript.Parser.Kinds
34+import Language.PureScript.CodeGen.JS.AST
35+import Language.PureScript.Values
36+
37+parseDataDeclaration :: P.Parsec String ParseState Declaration
38+parseDataDeclaration = do
39+ reserved "data"
40+ name <- indented *> properName
41+ tyArgs <- many (indented *> identifier)
42+ _ <- lexeme $ indented *> P.char '='
43+ ctors <- sepBy1 ((,) <$> properName <*> P.many (indented *> parseTypeAtom)) pipe
44+ return $ DataDeclaration name tyArgs ctors
45+
46+parseTypeDeclaration :: P.Parsec String ParseState Declaration
47+parseTypeDeclaration =
48+ TypeDeclaration <$> P.try (parseIdent <* lexeme (indented *> P.string "::"))
49+ <*> parsePolyType
50+
51+parseTypeSynonymDeclaration :: P.Parsec String ParseState Declaration
52+parseTypeSynonymDeclaration =
53+ TypeSynonymDeclaration <$> (P.try (reserved "type") *> indented *> properName)
54+ <*> many (indented *> identifier)
55+ <*> (lexeme (indented *> P.char '=') *> parsePolyType)
56+
57+parseValueDeclaration :: P.Parsec String ParseState Declaration
58+parseValueDeclaration =
59+ ValueDeclaration <$> parseIdent
60+ <*> P.many parseBinderNoParens
61+ <*> P.optionMaybe parseGuard
62+ <*> ((lexeme (indented *> P.char '=')) *> parseValue)
63+
64+parseExternDeclaration :: P.Parsec String ParseState Declaration
65+parseExternDeclaration = P.try (reserved "foreign") *> indented *> (reserved "import") *> indented *>
66+ (ExternDataDeclaration <$> (P.try (reserved "data") *> indented *> properName)
67+ <*> (lexeme (indented *> P.string "::") *> parseKind)
68+ <|> do ident <- parseIdent
69+ js <- P.optionMaybe (JSRaw <$> stringLiteral)
70+ ty <- (lexeme (indented *> P.string "::") *> parsePolyType)
71+ return $ ExternDeclaration (if isJust js then InlineJavascript else ForeignImport) ident js ty)
72+
73+parseAssociativity :: P.Parsec String ParseState Associativity
74+parseAssociativity =
75+ (P.try (reserved "infixl") >> return Infixl) <|>
76+ (P.try (reserved "infixr") >> return Infixr)
77+
78+parseFixity :: P.Parsec String ParseState Fixity
79+parseFixity = Fixity <$> parseAssociativity <*> (indented *> natural)
80+
81+parseFixityDeclaration :: P.Parsec String ParseState Declaration
82+parseFixityDeclaration = do
83+ fixity <- parseFixity
84+ indented
85+ name <- operator
86+ return $ FixityDeclaration fixity name
87+
88+parseImportDeclaration :: P.Parsec String ParseState Declaration
89+parseImportDeclaration = do
90+ reserved "import"
91+ indented
92+ moduleName <- moduleName
93+ idents <- P.optionMaybe $ parens $ commaSep1 (Left <$> parseIdent <|> Right <$> properName)
94+ return $ ImportDeclaration moduleName idents
95+
96+parseTypeClassDeclaration :: P.Parsec String ParseState Declaration
97+parseTypeClassDeclaration = do
98+ reserved "class"
99+ className <- indented *> properName
100+ ident <- indented *> identifier
101+ indented *> reserved "where"
102+ members <- mark (P.many (same *> parseTypeDeclaration))
103+ return $ TypeClassDeclaration className ident members
104+
105+parseTypeInstanceDeclaration :: P.Parsec String ParseState Declaration
106+parseTypeInstanceDeclaration = do
107+ reserved "instance"
108+ deps <- P.optionMaybe $ do
109+ deps <- parens (commaSep1 ((,) <$> parseQualified properName <*> parseType))
110+ indented
111+ reservedOp "=>"
112+ return deps
113+ className <- indented *> parseQualified properName
114+ ty <- indented *> parseType
115+ indented *> reserved "where"
116+ members <- mark (P.many (same *> parseValueDeclaration))
117+ return $ TypeInstanceDeclaration (fromMaybe [] deps) className ty members
118+
119+-- |
120+-- Parse a single declaration
121+--
122+parseDeclaration :: P.Parsec String ParseState Declaration
123+parseDeclaration = P.choice
124+ [ parseDataDeclaration
125+ , parseTypeDeclaration
126+ , parseTypeSynonymDeclaration
127+ , parseValueDeclaration
128+ , parseExternDeclaration
129+ , parseFixityDeclaration
130+ , parseImportDeclaration
131+ , parseTypeClassDeclaration
132+ , parseTypeInstanceDeclaration ] P.<?> "declaration"
133+
134+-- |
135+-- Parse a module header and a collection of declarations
136+--
137+parseModule :: P.Parsec String ParseState Module
138+parseModule = do
139+ reserved "module"
140+ indented
141+ name <- moduleName
142+ _ <- lexeme $ P.string "where"
143+ decls <- mark (P.many (same *> parseDeclaration))
144+ return $ Module name decls
145+
146+-- |
147+-- Parse a collection of modules
148+--
149+parseModules :: P.Parsec String ParseState [Module]
150+parseModules = whiteSpace *> mark (P.many (same *> parseModule)) <* P.eof
src/Language/PureScript/Parser/Kinds.hsnew file+45
@@ -0,0 +1,45 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Parser.Kinds
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- A parser for kinds
13+--
14+-----------------------------------------------------------------------------
15+
16+module Language.PureScript.Parser.Kinds (
17+ parseKind
18+) where
19+
20+import Language.PureScript.Kinds
21+import Language.PureScript.Parser.State
22+import Language.PureScript.Parser.Common
23+import Control.Applicative
24+import qualified Text.Parsec as P
25+import qualified Text.Parsec.Expr as P
26+
27+parseStar :: P.Parsec String ParseState Kind
28+parseStar = const Star <$> lexeme (P.char '*')
29+
30+parseBang :: P.Parsec String ParseState Kind
31+parseBang = const Bang <$> lexeme (P.char '!')
32+
33+parseTypeAtom :: P.Parsec String ParseState Kind
34+parseTypeAtom = indented *> P.choice (map P.try
35+ [ parseStar
36+ , parseBang
37+ , parens parseKind ])
38+-- |
39+-- Parse a kind
40+--
41+parseKind :: P.Parsec String ParseState Kind
42+parseKind = P.buildExpressionParser operators parseTypeAtom P.<?> "kind"
43+ where
44+ operators = [ [ P.Prefix (lexeme (P.char '#') >> return Row) ]
45+ , [ P.Infix (lexeme (P.try (P.string "->")) >> return FunKind) P.AssocRight ] ]
src/Language/PureScript/Parser/State.hsnew file+30
@@ -0,0 +1,30 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Parser.State
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- State for the parser monad
13+--
14+-----------------------------------------------------------------------------
15+
16+module Language.PureScript.Parser.State where
17+
18+import qualified Text.Parsec as P
19+
20+-- |
21+-- State for the parser monad
22+--
23+data ParseState = ParseState {
24+ -- |
25+ -- The most recently marked indentation level
26+ --
27+ indentationLevel :: P.Column
28+ } deriving Show
29+
30+
src/Language/PureScript/Parser/Types.hsnew file+127
@@ -0,0 +1,127 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Parser.Types
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- Parsers for types
13+--
14+-----------------------------------------------------------------------------
15+
16+module Language.PureScript.Parser.Types (
17+ parseType,
18+ parsePolyType,
19+ parseTypeAtom
20+) where
21+
22+import Language.PureScript.Types
23+import Language.PureScript.Parser.State
24+import Language.PureScript.Parser.Common
25+import Control.Applicative
26+import qualified Text.Parsec as P
27+import qualified Text.Parsec.Expr as P
28+import Control.Monad (when, unless)
29+
30+parseNumber :: P.Parsec String ParseState Type
31+parseNumber = const tyNumber <$> reserved "Number"
32+
33+parseString :: P.Parsec String ParseState Type
34+parseString = const tyString <$> reserved "String"
35+
36+parseBoolean :: P.Parsec String ParseState Type
37+parseBoolean = const tyBoolean <$> reserved "Boolean"
38+
39+parseArray :: P.Parsec String ParseState Type
40+parseArray = squares $ return tyArray
41+
42+parseArrayOf :: P.Parsec String ParseState Type
43+parseArrayOf = squares $ TypeApp tyArray <$> parseType
44+
45+parseFunction :: P.Parsec String ParseState Type
46+parseFunction = parens $ P.try (lexeme (P.string "->")) >> return tyFunction
47+
48+parseObject :: P.Parsec String ParseState Type
49+parseObject = braces $ Object <$> parseRow False
50+
51+parseTypeVariable :: P.Parsec String ParseState Type
52+parseTypeVariable = do
53+ ident <- identifier
54+ when (ident `elem` reservedTypeNames) $ P.unexpected $ ident
55+ return $ TypeVar ident
56+
57+parseTypeConstructor :: P.Parsec String ParseState Type
58+parseTypeConstructor = TypeConstructor <$> parseQualified properName
59+
60+parseForAll :: P.Parsec String ParseState Type
61+parseForAll = (mkForAll <$> (P.try (reserved "forall") *> P.many1 (indented *> identifier) <* indented <* dot)
62+ <*> parseConstrainedType)
63+
64+-- |
65+-- Parse a type as it appears in e.g. a data constructor
66+--
67+parseTypeAtom :: P.Parsec String ParseState Type
68+parseTypeAtom = indented *> P.choice (map P.try
69+ [ parseNumber
70+ , parseString
71+ , parseBoolean
72+ , parseArray
73+ , parseArrayOf
74+ , parseFunction
75+ , parseObject
76+ , parseTypeVariable
77+ , parseTypeConstructor
78+ , parseForAll
79+ , parens (parseRow True)
80+ , parens parsePolyType ])
81+
82+parseConstrainedType :: P.Parsec String ParseState Type
83+parseConstrainedType = do
84+ constraints <- P.optionMaybe . P.try $ do
85+ constraints <- parens . commaSep1 $ do
86+ className <- parseQualified properName
87+ indented
88+ ty <- parseType
89+ return (className, ty)
90+ _ <- lexeme $ P.string "=>"
91+ return constraints
92+ indented
93+ ty <- parseType
94+ return $ maybe ty (flip ConstrainedType ty) constraints
95+
96+parseAnyType :: P.Parsec String ParseState Type
97+parseAnyType = (P.buildExpressionParser operators $ parseTypeAtom) P.<?> "type"
98+ where
99+ operators = [ [ P.Infix (return TypeApp) P.AssocLeft ]
100+ , [ P.Infix (P.try (lexeme (P.string "->")) >> return function) P.AssocRight ] ]
101+
102+-- |
103+-- Parse a monotype
104+--
105+parseType :: P.Parsec String ParseState Type
106+parseType = do
107+ ty <- parseAnyType
108+ unless (isMonoType ty) $ P.unexpected "polymorphic type"
109+ return ty
110+
111+-- |
112+-- Parse a polytype
113+--
114+parsePolyType :: P.Parsec String ParseState Type
115+parsePolyType = do
116+ ty <- parseAnyType
117+ return ty
118+
119+parseNameAndType :: P.Parsec String ParseState t -> P.Parsec String ParseState (String, t)
120+parseNameAndType p = (,) <$> (indented *> identifier <* indented <* lexeme (P.string "::")) <*> p
121+
122+parseRowEnding :: P.Parsec String ParseState Type
123+parseRowEnding = P.option REmpty (TypeVar <$> (lexeme (indented *> P.char '|') *> indented *> identifier))
124+
125+parseRow :: Bool -> P.Parsec String ParseState Type
126+parseRow nonEmpty = (curry rowFromList <$> (many $ parseNameAndType parsePolyType) <*> parseRowEnding) P.<?> "row"
127+ where many = if nonEmpty then commaSep1 else commaSep
src/Language/PureScript/Parser/Values.hsnew file+243
@@ -0,0 +1,243 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Parser.Values
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- Parsers for values, statements, binders and guards
13+--
14+-----------------------------------------------------------------------------
15+
16+module Language.PureScript.Parser.Values (
17+ parseValue,
18+ parseGuard,
19+ parseBinder,
20+ parseBinderNoParens,
21+) where
22+
23+import Language.PureScript.Values
24+import Language.PureScript.Parser.State
25+import qualified Language.PureScript.Parser.Common as C
26+import Control.Applicative
27+import qualified Text.Parsec as P
28+import Text.Parsec.Expr
29+import Language.PureScript.Parser.Types
30+
31+booleanLiteral :: P.Parsec String ParseState Bool
32+booleanLiteral = (C.reserved "true" >> return True) P.<|> (C.reserved "false" >> return False)
33+
34+parseNumericLiteral :: P.Parsec String ParseState Value
35+parseNumericLiteral = NumericLiteral <$> C.integerOrFloat
36+
37+parseStringLiteral :: P.Parsec String ParseState Value
38+parseStringLiteral = StringLiteral <$> C.stringLiteral
39+
40+parseBooleanLiteral :: P.Parsec String ParseState Value
41+parseBooleanLiteral = BooleanLiteral <$> booleanLiteral
42+
43+parseArrayLiteral :: P.Parsec String ParseState Value
44+parseArrayLiteral = ArrayLiteral <$> C.squares (C.commaSep parseValue)
45+
46+parseObjectLiteral :: P.Parsec String ParseState Value
47+parseObjectLiteral = ObjectLiteral <$> C.braces (C.commaSep parseIdentifierAndValue)
48+
49+parseIdentifierAndValue :: P.Parsec String ParseState (String, Value)
50+parseIdentifierAndValue = (,) <$> (C.indented *> C.identifier <* C.indented <* C.colon)
51+ <*> (C.indented *> parseValue)
52+
53+parseAbs :: P.Parsec String ParseState Value
54+parseAbs = do
55+ C.reservedOp "\\"
56+ args <- P.many1 (C.indented *> (Abs <$> C.parseIdent))
57+ C.indented *> C.reservedOp "->"
58+ value <- parseValue
59+ return $ toFunction args value
60+ where
61+ toFunction :: [Value -> Value] -> Value -> Value
62+ toFunction args value = foldr (($)) value args
63+
64+parseVar :: P.Parsec String ParseState Value
65+parseVar = Var <$> C.parseQualified C.parseIdent
66+
67+parseConstructor :: P.Parsec String ParseState Value
68+parseConstructor = Constructor <$> C.parseQualified C.properName
69+
70+parseCase :: P.Parsec String ParseState Value
71+parseCase = Case <$> P.between (P.try (C.reserved "case")) (C.indented *> C.reserved "of") (return <$> parseValue)
72+ <*> (C.indented *> C.mark (P.many (C.same *> C.mark parseCaseAlternative)))
73+
74+parseCaseAlternative :: P.Parsec String ParseState ([Binder], Maybe Guard, Value)
75+parseCaseAlternative = (,,) <$> (return <$> parseBinder)
76+ <*> P.optionMaybe parseGuard
77+ <*> (C.indented *> C.reservedOp "->" *> parseValue)
78+ P.<?> "case alternative"
79+
80+parseIfThenElse :: P.Parsec String ParseState Value
81+parseIfThenElse = IfThenElse <$> (P.try (C.reserved "if") *> C.indented *> parseValue)
82+ <*> (C.indented *> C.reserved "then" *> C.indented *> parseValue)
83+ <*> (C.indented *> C.reserved "else" *> C.indented *> parseValue)
84+
85+parseLet :: P.Parsec String ParseState Value
86+parseLet = do
87+ C.reserved "let"
88+ C.indented
89+ binder <- parseBinder
90+ C.indented
91+ C.reservedOp "="
92+ C.indented
93+ value <- parseValue
94+ C.indented
95+ C.reserved "in"
96+ result <- parseValue
97+ return $ Let binder value result
98+
99+parseValueAtom :: P.Parsec String ParseState Value
100+parseValueAtom = P.choice
101+ [ P.try parseNumericLiteral
102+ , P.try parseStringLiteral
103+ , P.try parseBooleanLiteral
104+ , parseArrayLiteral
105+ , P.try parseObjectLiteral
106+ , parseAbs
107+ , P.try parseConstructor
108+ , P.try parseVar
109+ , parseCase
110+ , parseIfThenElse
111+ , parseDo
112+ , parseLet
113+ , Parens <$> C.parens parseValue ]
114+
115+parsePropertyUpdate :: P.Parsec String ParseState (String, Value)
116+parsePropertyUpdate = do
117+ name <- C.lexeme C.identifier
118+ _ <- C.lexeme $ C.indented *> P.char '='
119+ value <- C.indented *> parseValue
120+ return (name, value)
121+
122+parseAccessor :: Value -> P.Parsec String ParseState Value
123+parseAccessor (Constructor _) = P.unexpected "constructor"
124+parseAccessor obj = P.try $ Accessor <$> (C.indented *> C.dot *> P.notFollowedBy C.opLetter *> C.indented *> C.identifier) <*> pure obj
125+
126+parseDo :: P.Parsec String ParseState Value
127+parseDo = do
128+ C.reserved "do"
129+ C.indented
130+ Do <$> C.mark (P.many (C.same *> C.mark parseDoNotationElement))
131+
132+parseDoNotationLet :: P.Parsec String ParseState DoNotationElement
133+parseDoNotationLet = DoNotationLet <$> (C.reserved "let" *> C.indented *> parseBinder)
134+ <*> (C.indented *> C.reservedOp "=" *> parseValue)
135+
136+parseDoNotationBind :: P.Parsec String ParseState DoNotationElement
137+parseDoNotationBind = DoNotationBind <$> parseBinder <*> (C.indented *> C.reservedOp "<-" *> parseValue)
138+
139+parseDoNotationElement :: P.Parsec String ParseState DoNotationElement
140+parseDoNotationElement = P.choice
141+ [ P.try parseDoNotationBind
142+ , parseDoNotationLet
143+ , P.try (DoNotationValue <$> parseValue) ]
144+
145+-- |
146+-- Parse a value
147+--
148+parseValue :: P.Parsec String ParseState Value
149+parseValue =
150+ (buildExpressionParser operators
151+ . C.buildPostfixParser postfixTable2
152+ $ indexersAndAccessors) P.<?> "expression"
153+ where
154+ indexersAndAccessors = C.buildPostfixParser postfixTable1 parseValueAtom
155+ postfixTable1 = [ parseAccessor
156+ , \v -> P.try $ flip ObjectUpdate <$> (C.indented *> C.braces (C.commaSep1 (C.indented *> parsePropertyUpdate))) <*> pure v ]
157+ postfixTable2 = [ \v -> P.try (C.indented *> indexersAndAccessors >>= return . flip App) <*> pure v
158+ , \v -> flip (TypedValue True) <$> (P.try (C.lexeme (C.indented *> P.string "::")) *> parsePolyType) <*> pure v
159+ ]
160+ operators = [ [ Infix (C.lexeme (P.try (C.indented *> C.parseIdentInfix P.<?> "operator") >>= \ident ->
161+ return (BinaryNoParens ident))) AssocRight ]
162+ ]
163+
164+parseStringBinder :: P.Parsec String ParseState Binder
165+parseStringBinder = StringBinder <$> C.stringLiteral
166+
167+parseBooleanBinder :: P.Parsec String ParseState Binder
168+parseBooleanBinder = BooleanBinder <$> booleanLiteral
169+
170+parseNumberBinder :: P.Parsec String ParseState Binder
171+parseNumberBinder = NumberBinder <$> C.integerOrFloat
172+
173+parseVarBinder :: P.Parsec String ParseState Binder
174+parseVarBinder = VarBinder <$> C.parseIdent
175+
176+parseNullaryConstructorBinder :: P.Parsec String ParseState Binder
177+parseNullaryConstructorBinder = ConstructorBinder <$> C.lexeme (C.parseQualified C.properName) <*> pure []
178+
179+parseConstructorBinder :: P.Parsec String ParseState Binder
180+parseConstructorBinder = ConstructorBinder <$> C.lexeme (C.parseQualified C.properName) <*> (many (C.indented *> parseBinderNoParens))
181+
182+parseObjectBinder :: P.Parsec String ParseState Binder
183+parseObjectBinder = ObjectBinder <$> C.braces (C.commaSep (C.indented *> parseIdentifierAndBinder))
184+
185+parseArrayBinder :: P.Parsec String ParseState Binder
186+parseArrayBinder = C.squares $ ArrayBinder <$> (C.commaSep (C.indented *> parseBinder))
187+
188+parseNamedBinder :: P.Parsec String ParseState Binder
189+parseNamedBinder = NamedBinder <$> (C.parseIdent <* C.indented <* C.lexeme (P.char '@'))
190+ <*> (C.indented *> parseBinder)
191+
192+parseNullBinder :: P.Parsec String ParseState Binder
193+parseNullBinder = C.lexeme (P.char '_') *> P.notFollowedBy C.identLetter *> return NullBinder
194+
195+parseIdentifierAndBinder :: P.Parsec String ParseState (String, Binder)
196+parseIdentifierAndBinder = do
197+ name <- C.lexeme C.identifier
198+ _ <- C.lexeme $ C.indented *> P.char '='
199+ binder <- C.indented *> parseBinder
200+ return (name, binder)
201+
202+parseBinderAtom :: P.Parsec String ParseState Binder
203+parseBinderAtom = P.choice (map P.try
204+ [ parseNullBinder
205+ , parseStringBinder
206+ , parseBooleanBinder
207+ , parseNumberBinder
208+ , parseNamedBinder
209+ , parseVarBinder
210+ , parseConstructorBinder
211+ , parseObjectBinder
212+ , parseArrayBinder
213+ , C.parens parseBinder ]) P.<?> "binder"
214+
215+-- |
216+-- Parse a binder
217+--
218+parseBinder :: P.Parsec String ParseState Binder
219+parseBinder = (buildExpressionParser operators parseBinderAtom) P.<?> "expression"
220+ where
221+ operators = [ [ Infix ( C.lexeme (P.try $ C.indented *> C.reservedOp ":") >> return ConsBinder) AssocRight ] ]
222+
223+-- |
224+-- Parse a binder as it would appear in a top level declaration
225+--
226+parseBinderNoParens :: P.Parsec String ParseState Binder
227+parseBinderNoParens = P.choice (map P.try
228+ [ parseNullBinder
229+ , parseStringBinder
230+ , parseBooleanBinder
231+ , parseNumberBinder
232+ , parseNamedBinder
233+ , parseVarBinder
234+ , parseNullaryConstructorBinder
235+ , parseObjectBinder
236+ , parseArrayBinder
237+ , C.parens parseBinder ]) P.<?> "binder"
238+-- |
239+-- Parse a guard
240+--
241+parseGuard :: P.Parsec String ParseState Guard
242+parseGuard = C.indented *> C.pipe *> C.indented *> parseValue
243+
src/Language/PureScript/Pretty.hsnew file+32
@@ -0,0 +1,32 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Pretty
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- A collection of pretty printers for core data types:
13+--
14+-- [@Language.PureScript.Pretty.Kinds@] Pretty printer for kinds
15+--
16+-- [@Language.PureScript.Pretty.Values@] Pretty printer for values
17+--
18+-- [@Language.PureScript.Pretty.Types@] Pretty printer for types
19+--
20+-- [@Language.PureScript.Pretty.JS@] Pretty printer for values, used for code generation
21+--
22+-----------------------------------------------------------------------------
23+
24+module Language.PureScript.Pretty (module P) where
25+
26+import Language.PureScript.Pretty.Kinds as P
27+import Language.PureScript.Pretty.Values as P
28+import Language.PureScript.Pretty.Types as P
29+import Language.PureScript.Pretty.JS as P
30+
31+
32+
src/Language/PureScript/Pretty/Common.hsnew file+22
@@ -0,0 +1,22 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Pretty.Common
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- Common pretty-printing utility functions
13+--
14+-----------------------------------------------------------------------------
15+
16+module Language.PureScript.Pretty.Common where
17+
18+-- |
19+-- Wrap a string in parentheses
20+--
21+parens :: String -> String
22+parens s = ('(':s) ++ ")"
src/Language/PureScript/Pretty/JS.hsnew file+255
@@ -0,0 +1,255 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Pretty.JS
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- Pretty printer for the Javascript AST
13+--
14+-----------------------------------------------------------------------------
15+
16+module Language.PureScript.Pretty.JS (
17+ prettyPrintJS
18+) where
19+
20+import Language.PureScript.Names
21+import Language.PureScript.Values
22+import Language.PureScript.Pretty.Common
23+import Language.PureScript.CodeGen.JS.AST
24+
25+import Data.List
26+import Data.Maybe (fromMaybe)
27+import qualified Control.Arrow as A
28+import Control.Arrow ((<+>))
29+import Control.PatternArrows
30+import Control.Applicative
31+import Control.Monad.State
32+
33+newtype PrinterState = PrinterState { indent :: Int } deriving (Show, Eq, Ord)
34+
35+-- |
36+-- Number of characters per identation level
37+--
38+blockIndent :: Int
39+blockIndent = 4
40+
41+-- |
42+-- Pretty print with a new indentation level
43+--
44+withIndent :: StateT PrinterState Maybe String -> StateT PrinterState Maybe String
45+withIndent action = do
46+ modify $ \st -> st { indent = indent st + blockIndent }
47+ result <- action
48+ modify $ \st -> st { indent = indent st - blockIndent }
49+ return result
50+
51+-- |
52+-- Get the current indentation level
53+--
54+currentIndent :: StateT PrinterState Maybe String
55+currentIndent = do
56+ current <- get
57+ return $ replicate (indent current) ' '
58+
59+literals :: Pattern PrinterState JS String
60+literals = mkPattern' match
61+ where
62+ match :: JS -> StateT PrinterState Maybe String
63+ match (JSNumericLiteral n) = return $ either show show n
64+ match (JSStringLiteral s) = return $ show s
65+ match (JSBooleanLiteral True) = return "true"
66+ match (JSBooleanLiteral False) = return "false"
67+ match (JSArrayLiteral xs) = fmap concat $ sequence
68+ [ return "[ "
69+ , fmap (intercalate ", ") $ forM xs prettyPrintJS'
70+ , return " ]"
71+ ]
72+ match (JSObjectLiteral []) = return "{}"
73+ match (JSObjectLiteral ps) = fmap concat $ sequence
74+ [ return "{\n"
75+ , withIndent $ do
76+ jss <- forM ps $ \(key, value) -> fmap ((key ++ ": ") ++) . prettyPrintJS' $ value
77+ indentString <- currentIndent
78+ return $ intercalate ", \n" $ map (indentString ++) jss
79+ , return "\n"
80+ , currentIndent
81+ , return "}"
82+ ]
83+ match (JSBlock sts) = fmap concat $ sequence
84+ [ return "{\n"
85+ , withIndent $ do
86+ jss <- forM sts prettyPrintJS'
87+ indentString <- currentIndent
88+ return $ intercalate "\n" $ map (++ ";") $ map (indentString ++) jss
89+ , return "\n"
90+ , currentIndent
91+ , return "}"
92+ ]
93+ match (JSVar ident) = return ident
94+ match (JSVariableIntroduction ident value) = fmap concat $ sequence
95+ [ return "var "
96+ , return ident
97+ , maybe (return "") (fmap (" = " ++) . prettyPrintJS') value
98+ ]
99+ match (JSAssignment target value) = fmap concat $ sequence
100+ [ prettyPrintJS' target
101+ , return " = "
102+ , prettyPrintJS' value
103+ ]
104+ match (JSWhile cond sts) = fmap concat $ sequence
105+ [ return "while ("
106+ , prettyPrintJS' cond
107+ , return ") "
108+ , prettyPrintJS' sts
109+ ]
110+ match (JSFor ident start end sts) = fmap concat $ sequence
111+ [ return $ "for (var " ++ ident ++ " = "
112+ , prettyPrintJS' start
113+ , return $ "; " ++ ident ++ " < "
114+ , prettyPrintJS' end
115+ , return $ "; " ++ ident ++ "++) "
116+ , prettyPrintJS' sts
117+ ]
118+ match (JSIfElse cond thens elses) = fmap concat $ sequence
119+ [ return "if ("
120+ , prettyPrintJS' cond
121+ , return ") "
122+ , prettyPrintJS' thens
123+ , maybe (return "") (fmap (" else " ++) . prettyPrintJS') elses
124+ ]
125+ match (JSReturn value) = fmap concat $ sequence
126+ [ return "return "
127+ , prettyPrintJS' value
128+ ]
129+ match (JSThrow value) = fmap concat $ sequence
130+ [ return "throw "
131+ , prettyPrintJS' value
132+ ]
133+ match (JSBreak lbl) = return $ "break " ++ lbl
134+ match (JSContinue lbl) = return $ "continue " ++ lbl
135+ match (JSLabel lbl js) = fmap concat $ sequence
136+ [ return $ lbl ++ ": "
137+ , prettyPrintJS' js
138+ ]
139+ match (JSRaw js) = return js
140+ match _ = mzero
141+
142+conditional :: Pattern PrinterState JS ((JS, JS), JS)
143+conditional = mkPattern match
144+ where
145+ match (JSConditional cond th el) = Just ((th, el), cond)
146+ match _ = Nothing
147+
148+accessor :: Pattern PrinterState JS (String, JS)
149+accessor = mkPattern match
150+ where
151+ match (JSAccessor prop val) = Just (prop, val)
152+ match _ = Nothing
153+
154+indexer :: Pattern PrinterState JS (String, JS)
155+indexer = mkPattern' match
156+ where
157+ match (JSIndexer index val) = (,) <$> prettyPrintJS' index <*> pure val
158+ match _ = mzero
159+
160+lam :: Pattern PrinterState JS ((Maybe String, [String]), JS)
161+lam = mkPattern match
162+ where
163+ match (JSFunction name args ret) = Just ((name, args), ret)
164+ match _ = Nothing
165+
166+app :: Pattern PrinterState JS (String, JS)
167+app = mkPattern' match
168+ where
169+ match (JSApp val args) = do
170+ jss <- mapM prettyPrintJS' args
171+ return (intercalate ", " jss, val)
172+ match _ = mzero
173+
174+typeOf :: Pattern PrinterState JS ((), JS)
175+typeOf = mkPattern match
176+ where
177+ match (JSTypeOf val) = Just ((), val)
178+ match _ = Nothing
179+
180+unary :: UnaryOperator -> String -> Operator PrinterState JS String
181+unary op str = Wrap match (++)
182+ where
183+ match :: Pattern PrinterState JS (String, JS)
184+ match = mkPattern match'
185+ where
186+ match' (JSUnary op' val) | op' == op = Just (str, val)
187+ match' _ = Nothing
188+
189+binary :: BinaryOperator -> String -> Operator PrinterState JS String
190+binary op str = AssocR match (\v1 v2 -> v1 ++ " " ++ str ++ " " ++ v2)
191+ where
192+ match :: Pattern PrinterState JS (JS, JS)
193+ match = mkPattern match'
194+ where
195+ match' (JSBinary op' v1 v2) | op' == op = Just (v1, v2)
196+ match' _ = Nothing
197+
198+-- |
199+-- Generate a pretty-printed string representing a Javascript expression
200+--
201+prettyPrintJS1 :: JS -> String
202+prettyPrintJS1 = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyPrintJS'
203+
204+-- |
205+-- Generate a pretty-printed string representing a collection of Javascript expressions at the same indentation level
206+--
207+prettyPrintJS :: [JS] -> String
208+prettyPrintJS sts = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) $ do
209+ jss <- forM sts prettyPrintJS'
210+ indentString <- currentIndent
211+ return $ intercalate "\n" $ map (++ ";") $ map (indentString ++) jss
212+
213+-- |
214+-- Generate an indented, pretty-printed string representing a Javascript expression
215+--
216+prettyPrintJS' :: JS -> StateT PrinterState Maybe String
217+prettyPrintJS' = A.runKleisli $ runPattern matchValue
218+ where
219+ matchValue :: Pattern PrinterState JS String
220+ matchValue = buildPrettyPrinter operators (literals <+> fmap parens matchValue)
221+ operators :: OperatorTable PrinterState JS String
222+ operators =
223+ OperatorTable [ [ Wrap accessor $ \prop val -> val ++ "." ++ prop ]
224+ , [ Wrap indexer $ \index val -> val ++ "[" ++ index ++ "]" ]
225+ , [ Wrap app $ \args val -> val ++ "(" ++ args ++ ")" ]
226+ , [ Wrap lam $ \(name, args) ret -> "function "
227+ ++ maybe "" id name
228+ ++ "(" ++ (intercalate ", " args) ++ ") "
229+ ++ ret ]
230+ , [ Wrap conditional $ \(th, el) cond -> cond ++ " ? " ++ prettyPrintJS1 th ++ " : " ++ prettyPrintJS1 el ]
231+ , [ binary LessThan "<" ]
232+ , [ binary LessThanOrEqualTo "<=" ]
233+ , [ binary GreaterThan ">" ]
234+ , [ binary GreaterThanOrEqualTo ">=" ]
235+ , [ Wrap typeOf $ \_ s -> "typeof " ++ s ]
236+ , [ unary Not "!" ]
237+ , [ unary BitwiseNot "~" ]
238+ , [ unary Negate "-" ]
239+ , [ unary Positive "+" ]
240+ , [ binary Multiply "*" ]
241+ , [ binary Divide "/" ]
242+ , [ binary Modulus "%" ]
243+ , [ binary Add "+" ]
244+ , [ binary Subtract "-" ]
245+ , [ binary ShiftLeft "<<" ]
246+ , [ binary ShiftRight ">>" ]
247+ , [ binary ZeroFillShiftRight ">>>" ]
248+ , [ binary EqualTo "===" ]
249+ , [ binary NotEqualTo "!==" ]
250+ , [ binary BitwiseAnd "&" ]
251+ , [ binary BitwiseXor "^" ]
252+ , [ binary BitwiseOr "|" ]
253+ , [ binary And "&&" ]
254+ , [ binary Or "||" ]
255+ ]
src/Language/PureScript/Pretty/Kinds.hsnew file+60
@@ -0,0 +1,60 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Pretty.Kinds
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- Pretty printer for kinds
13+--
14+-----------------------------------------------------------------------------
15+
16+module Language.PureScript.Pretty.Kinds (
17+ prettyPrintKind
18+) where
19+
20+import Data.Maybe (fromMaybe)
21+
22+import Control.Arrow (ArrowPlus(..))
23+import Control.PatternArrows
24+import Control.Monad.Unify
25+
26+import Language.PureScript.Kinds
27+import Language.PureScript.Pretty.Common
28+
29+typeLiterals :: Pattern () Kind String
30+typeLiterals = mkPattern match
31+ where
32+ match Star = Just "*"
33+ match Bang = Just "!"
34+ match (KUnknown (Unknown u)) = Just $ 'u' : show u
35+ match _ = Nothing
36+
37+matchRow :: Pattern () Kind ((), Kind)
38+matchRow = mkPattern match
39+ where
40+ match (Row k) = Just ((), k)
41+ match _ = Nothing
42+
43+funKind :: Pattern () Kind (Kind, Kind)
44+funKind = mkPattern match
45+ where
46+ match (FunKind arg ret) = Just (arg, ret)
47+ match _ = Nothing
48+
49+-- |
50+-- Generate a pretty-printed string representing a Kind
51+--
52+prettyPrintKind :: Kind -> String
53+prettyPrintKind = fromMaybe (error "Incomplete pattern") . pattern matchKind ()
54+ where
55+ matchKind :: Pattern () Kind String
56+ matchKind = buildPrettyPrinter operators (typeLiterals <+> fmap parens matchKind)
57+ operators :: OperatorTable () Kind String
58+ operators =
59+ OperatorTable [ [ Wrap matchRow $ \_ k -> "# " ++ k]
60+ , [ AssocR funKind $ \arg ret -> arg ++ " -> " ++ ret ] ]
src/Language/PureScript/Pretty/Types.hsnew file+98
@@ -0,0 +1,98 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Pretty.Types
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- Pretty printer for Types
13+--
14+-----------------------------------------------------------------------------
15+
16+module Language.PureScript.Pretty.Types (
17+ prettyPrintType,
18+ prettyPrintRow
19+) where
20+
21+import Data.Maybe (fromMaybe)
22+import Data.List (intercalate)
23+import Data.Generics (mkT, everywhere)
24+
25+import Control.Arrow ((<+>))
26+import Control.PatternArrows
27+import Control.Monad.Unify
28+
29+import Language.PureScript.Types
30+import Language.PureScript.Pretty.Common
31+
32+typeLiterals :: Pattern () Type String
33+typeLiterals = mkPattern match
34+ where
35+ match (Object row) = Just $ "{ " ++ prettyPrintRow row ++ " }"
36+ match (TypeVar var) = Just var
37+ match (PrettyPrintArray ty) = Just $ "[" ++ prettyPrintType ty ++ "]"
38+ match ty@(TypeConstructor ctor) = Just $ show ctor
39+ match (TUnknown (Unknown u)) = Just $ 'u' : show u
40+ match (Skolem s _) = Just $ 's' : show s
41+ match (ConstrainedType deps ty) = Just $ "(" ++ intercalate "," (map (\(pn, ty') -> show pn ++ " (" ++ prettyPrintType ty' ++ ")") deps) ++ ") => " ++ prettyPrintType ty
42+ match (SaturatedTypeSynonym name args) = Just $ show name ++ "<" ++ intercalate "," (map prettyPrintType args) ++ ">"
43+ match (ForAll ident ty _) = Just $ "forall " ++ ident ++ ". " ++ prettyPrintType ty
44+ match REmpty = Just "()"
45+ match row@(RCons _ _ _) = Just $ '(' : prettyPrintRow row ++ ")"
46+ match _ = Nothing
47+
48+-- |
49+-- Generate a pretty-printed string representing a Row
50+--
51+prettyPrintRow :: Type -> String
52+prettyPrintRow = (\(tys, rest) -> intercalate ", " (map (uncurry nameAndTypeToPs) tys) ++ tailToPs rest) . toList []
53+ where
54+ nameAndTypeToPs :: String -> Type -> String
55+ nameAndTypeToPs name ty = name ++ " :: " ++ prettyPrintType ty
56+ tailToPs :: Type -> String
57+ tailToPs REmpty = ""
58+ tailToPs (TUnknown (Unknown u)) = " | u" ++ show u
59+ tailToPs (TypeVar var) = " | " ++ var
60+ tailToPs (Skolem s _) = " | s" ++ show s
61+ tailToPs _ = error "Invalid row tail"
62+ toList :: [(String, Type)] -> Type -> ([(String, Type)], Type)
63+ toList tys (RCons name ty row) = toList ((name, ty):tys) row
64+ toList tys r = (tys, r)
65+
66+typeApp :: Pattern () Type (Type, Type)
67+typeApp = mkPattern match
68+ where
69+ match (TypeApp f x) = Just (f, x)
70+ match _ = Nothing
71+
72+appliedFunction :: Pattern () Type (Type, Type)
73+appliedFunction = mkPattern match
74+ where
75+ match (PrettyPrintFunction arg ret) = Just (arg, ret)
76+ match _ = Nothing
77+
78+insertPlaceholders :: Type -> Type
79+insertPlaceholders = everywhere (mkT convert)
80+ where
81+ convert (TypeApp (TypeApp f arg) ret) | f == tyFunction = PrettyPrintFunction arg ret
82+ convert (TypeApp a el) | a == tyArray = PrettyPrintArray el
83+ convert other = other
84+
85+-- |
86+-- Generate a pretty-printed string representing a Type
87+--
88+prettyPrintType :: Type -> String
89+prettyPrintType = fromMaybe (error "Incomplete pattern") . pattern matchType () . insertPlaceholders
90+ where
91+ matchType :: Pattern () Type String
92+ matchType = buildPrettyPrinter operators (typeLiterals <+> fmap parens matchType)
93+ operators :: OperatorTable () Type String
94+ operators =
95+ OperatorTable [ [ AssocL typeApp $ \f x -> f ++ " " ++ x ]
96+ , [ AssocR appliedFunction $ \arg ret -> arg ++ " -> " ++ ret
97+ ]
98+ ]
src/Language/PureScript/Pretty/Values.hsnew file+149
@@ -0,0 +1,149 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Pretty.Values
4+-- Copyright : Kinds.hs(c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- Pretty printer for values
13+--
14+-----------------------------------------------------------------------------
15+
16+module Language.PureScript.Pretty.Values (
17+ prettyPrintValue,
18+ prettyPrintBinder
19+) where
20+
21+import Data.Maybe (fromMaybe)
22+import Data.List (intercalate)
23+import Control.Arrow ((<+>))
24+import Control.PatternArrows
25+
26+import Language.PureScript.Types
27+import Language.PureScript.Values
28+import Language.PureScript.Pretty.Common
29+import Language.PureScript.Pretty.Types
30+
31+literals :: Pattern () Value String
32+literals = mkPattern match
33+ where
34+ match (NumericLiteral n) = Just $ either show show n
35+ match (StringLiteral s) = Just $ show s
36+ match (BooleanLiteral True) = Just "true"
37+ match (BooleanLiteral False) = Just "false"
38+ match (ArrayLiteral xs) = Just $ "[" ++ intercalate ", " (map prettyPrintValue xs) ++ "]"
39+ match (ObjectLiteral ps) = Just $ "{" ++ intercalate ", " (map (uncurry prettyPrintObjectProperty) ps) ++ "}"
40+ match (Constructor name) = Just $ show name
41+ match (Case values binders) = Just $ "case " ++ intercalate " " (map prettyPrintValue values) ++
42+ " of { " ++ intercalate " ; " (map prettyPrintCaseAlternative binders) ++ " }"
43+ match (Var ident) = Just $ show ident
44+ match (Do els) = Just $ " do { " ++ intercalate "; " (map prettyPrintDoNotationElement els) ++ " }"
45+ match (TypeClassDictionary _ _) = error "Type class dictionary was not replaced"
46+ match _ = Nothing
47+
48+prettyPrintCaseAlternative :: ([Binder], Maybe Guard, Value) -> String
49+prettyPrintCaseAlternative (binders, grd, val) = "(" ++ intercalate ", " (map prettyPrintBinder binders) ++ ") " ++
50+ (maybe "" (("| " ++) . prettyPrintValue) grd) ++ " -> " ++ prettyPrintValue val
51+
52+ifThenElse :: Pattern () Value ((Value, Value), Value)
53+ifThenElse = mkPattern match
54+ where
55+ match (IfThenElse cond th el) = Just ((th, el), cond)
56+ match _ = Nothing
57+
58+accessor :: Pattern () Value (String, Value)
59+accessor = mkPattern match
60+ where
61+ match (Accessor prop val) = Just (prop, val)
62+ match _ = Nothing
63+
64+objectUpdate :: Pattern () Value ([String], Value)
65+objectUpdate = mkPattern match
66+ where
67+ match (ObjectUpdate o ps) = Just (flip map ps $ \(key, val) -> key ++ " = " ++ prettyPrintValue val, o)
68+ match _ = Nothing
69+
70+app :: Pattern () Value (String, Value)
71+app = mkPattern match
72+ where
73+ match (App val arg) = Just (prettyPrintValue arg, val)
74+ match _ = Nothing
75+
76+lam :: Pattern () Value (String, Value)
77+lam = mkPattern match
78+ where
79+ match (Abs arg val) = Just (show arg, val)
80+ match _ = Nothing
81+
82+typed :: Pattern () Value (Type, Value)
83+typed = mkPattern match
84+ where
85+ match (TypedValue _ val ty) = Just (ty, val)
86+ match _ = Nothing
87+
88+prettyPrintDoNotationElement :: DoNotationElement -> String
89+prettyPrintDoNotationElement (DoNotationValue val) = prettyPrintValue val
90+prettyPrintDoNotationElement (DoNotationBind binder val) = prettyPrintBinder binder ++ " <- " ++ prettyPrintValue val
91+prettyPrintDoNotationElement (DoNotationLet binder val) = "let " ++ prettyPrintBinder binder ++ " = " ++ prettyPrintValue val
92+
93+-- |
94+-- Generate a pretty-printed string representing a Value
95+--
96+prettyPrintValue :: Value -> String
97+prettyPrintValue = fromMaybe (error "Incomplete pattern") . pattern matchValue ()
98+ where
99+ matchValue :: Pattern () Value String
100+ matchValue = buildPrettyPrinter operators (literals <+> fmap parens matchValue)
101+ operators :: OperatorTable () Value String
102+ operators =
103+ OperatorTable [ [ Wrap accessor $ \prop val -> val ++ "." ++ prop ]
104+ , [ Wrap objectUpdate $ \ps val -> val ++ "{ " ++ intercalate ", " ps ++ " }" ]
105+ , [ Wrap app $ \arg val -> val ++ "(" ++ arg ++ ")" ]
106+ , [ Split lam $ \arg val -> "\\" ++ arg ++ " -> " ++ prettyPrintValue val ]
107+ , [ Wrap ifThenElse $ \(th, el) cond -> cond ++ " ? " ++ prettyPrintValue th ++ " : " ++ prettyPrintValue el ]
108+ , [ Wrap typed $ \ty val -> val ++ " :: " ++ prettyPrintType ty ]
109+ ]
110+
111+prettyPrintBinderAtom :: Pattern () Binder String
112+prettyPrintBinderAtom = mkPattern match
113+ where
114+ match :: Binder -> Maybe String
115+ match NullBinder = Just "_"
116+ match (StringBinder str) = Just $ show str
117+ match (NumberBinder num) = Just $ either show show num
118+ match (BooleanBinder True) = Just "true"
119+ match (BooleanBinder False) = Just "false"
120+ match (VarBinder ident) = Just $ show ident
121+ match (ConstructorBinder ctor args) = Just $ show ctor ++ " " ++ intercalate " " (map (parens . prettyPrintBinder) args)
122+ match (ObjectBinder bs) = Just $ "{ " ++ intercalate ", " (map (uncurry prettyPrintObjectPropertyBinder) bs) ++ " }"
123+ match (ArrayBinder bs) = Just $ "[ " ++ intercalate ", " (map prettyPrintBinder bs) ++ " ]"
124+ match (NamedBinder ident binder) = Just $ show ident ++ "@" ++ prettyPrintBinder binder
125+ match _ = Nothing
126+
127+-- |
128+-- Generate a pretty-printed string representing a Binder
129+--
130+prettyPrintBinder :: Binder -> String
131+prettyPrintBinder = fromMaybe (error "Incomplete pattern") . pattern matchBinder ()
132+ where
133+ matchBinder :: Pattern () Binder String
134+ matchBinder = buildPrettyPrinter operators (prettyPrintBinderAtom <+> fmap parens matchBinder)
135+ operators :: OperatorTable () Binder String
136+ operators =
137+ OperatorTable [ [ AssocR matchConsBinder (\b1 b2 -> b1 ++ " : " ++ b2) ] ]
138+
139+matchConsBinder :: Pattern () Binder (Binder, Binder)
140+matchConsBinder = mkPattern match'
141+ where
142+ match' (ConsBinder b1 b2) = Just (b1, b2)
143+ match' _ = Nothing
144+
145+prettyPrintObjectPropertyBinder :: String -> Binder -> String
146+prettyPrintObjectPropertyBinder key binder = key ++ ": " ++ prettyPrintBinder binder
147+
148+prettyPrintObjectProperty :: String -> Value -> String
149+prettyPrintObjectProperty key value = key ++ ": " ++ prettyPrintValue value
src/Language/PureScript/Scope.hsnew file+59
@@ -0,0 +1,59 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Scope
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- Utility functions for working with names in scope
13+--
14+-----------------------------------------------------------------------------
15+
16+module Language.PureScript.Scope (
17+ usedNames,
18+ unusedNames
19+) where
20+
21+import Data.Data
22+import Data.List ((\\), nub)
23+import Data.Generics (extQ, mkQ, everything)
24+
25+import Language.PureScript.Values
26+import Language.PureScript.Names
27+import Language.PureScript.CodeGen.JS.AST
28+
29+-- |
30+-- Gather all used names appearing inside a value
31+--
32+usedNames :: (Data d) => d -> [Ident]
33+usedNames val = nub $ everything (++) (mkQ [] namesV `extQ` namesB `extQ` namesJS) val
34+ where
35+ namesV :: Value -> [Ident]
36+ namesV (Abs arg _) = [arg]
37+ namesV (Var (Qualified Nothing name)) = [name]
38+ namesV _ = []
39+ namesB :: Binder -> [Ident]
40+ namesB (VarBinder name) = [name]
41+ namesB _ = []
42+ namesJS :: JS -> [Ident]
43+ namesJS (JSVar name) = [Ident name]
44+ namesJS (JSFunction (Just name) args _) = (Ident name) : (Ident `map` args)
45+ namesJS (JSFunction Nothing args _) = (Ident `map` args)
46+ namesJS (JSVariableIntroduction name _) = [Ident name]
47+ namesJS (JSFor name _ _ _) = [Ident name]
48+ namesJS _ = []
49+
50+-- |
51+-- Generate a set of names which are unused inside a value, of the form @_{n}@ for an integer @n@
52+--
53+unusedNames :: (Data d) => d -> [Ident]
54+unusedNames val =
55+ let
56+ allNames = usedNames val
57+ varNames = map (Ident . ('_' :) . show) ([1..] :: [Int])
58+ in
59+ varNames \\ allNames
src/Language/PureScript/Sugar.hsnew file+55
@@ -0,0 +1,55 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Sugar
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- Desugaring passes
13+--
14+-----------------------------------------------------------------------------
15+
16+module Language.PureScript.Sugar (desugar, module S) where
17+
18+import Control.Monad
19+import Control.Arrow ((>>>))
20+
21+import Language.PureScript.Declarations
22+
23+import Language.PureScript.Sugar.Operators as S
24+import Language.PureScript.Sugar.DoNotation as S
25+import Language.PureScript.Sugar.CaseDeclarations as S
26+import Language.PureScript.Sugar.TypeDeclarations as S
27+import Language.PureScript.Sugar.BindingGroups as S
28+import Language.PureScript.Sugar.TypeClasses as S
29+import Language.PureScript.Sugar.Let as S
30+
31+-- |
32+-- The desugaring pipeline proceeds as follows:
33+--
34+-- * Desugar let bindings
35+--
36+-- * Introduce type synonyms for type class dictionaries
37+--
38+-- * Rebracket user-defined binary operators
39+--
40+-- * Desugar do-notation using the @Prelude.Monad@ type class
41+--
42+-- * Desugar top-level case declarations into explicit case expressions
43+--
44+-- * Desugar type declarations into value declarations with explicit type annotations
45+--
46+-- * Group mutually recursive value and data declarations into binding groups.
47+--
48+desugar :: [Module] -> Either String [Module]
49+desugar = desugarTypeClasses
50+ >=> rebracket
51+ >=> desugarDo
52+ >=> desugarLetBindings
53+ >>> desugarCasesModule
54+ >=> desugarTypeDeclarationsModule
55+ >=> createBindingGroupsModule
src/Language/PureScript/Sugar/BindingGroups.hsnew file+121
@@ -0,0 +1,121 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.BindingGroups
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- This module implements the desugaring pass which creates binding groups from sets of
13+-- mutually-recursive value declarations and mutually-recursive type declarations.
14+--
15+-----------------------------------------------------------------------------
16+
17+module Language.PureScript.Sugar.BindingGroups (
18+ createBindingGroups,
19+ createBindingGroupsModule,
20+ collapseBindingGroups,
21+ collapseBindingGroupsModule
22+) where
23+
24+import Data.Data
25+import Data.Graph
26+import Data.Generics
27+import Data.List (nub, intersect)
28+import Control.Applicative ((<$>))
29+
30+import Language.PureScript.Declarations
31+import Language.PureScript.Names
32+import Language.PureScript.Values
33+import Language.PureScript.Types
34+
35+-- |
36+-- Replace all sets of mutually-recursive declarations in a module with binding groups
37+--
38+createBindingGroupsModule :: [Module] -> Either String [Module]
39+createBindingGroupsModule = mapM $ \(Module name ds) -> Module name <$> createBindingGroups name ds
40+
41+-- |
42+-- Collapse all binding groups in a module to individual declarations
43+--
44+collapseBindingGroupsModule :: [Module] -> [Module]
45+collapseBindingGroupsModule = map $ \(Module name ds) -> Module name (collapseBindingGroups ds)
46+
47+-- |
48+-- Replace all sets of mutually-recursive declarations with binding groups
49+--
50+createBindingGroups :: ModuleName -> [Declaration] -> Either String [Declaration]
51+createBindingGroups moduleName ds = do
52+ let values = filter isValueDecl ds
53+ dataDecls = filter isDataDecl ds
54+ allProperNames = map getProperName dataDecls
55+ dataVerts = map (\d -> (d, getProperName d, usedProperNames d `intersect` allProperNames)) dataDecls
56+ dataBindingGroupDecls <- mapM toDataBindingGroup $ stronglyConnComp dataVerts
57+ let allIdents = map getIdent values
58+ valueVerts = map (\d -> (d, getIdent d, usedIdents moduleName d `intersect` allIdents)) values
59+ bindingGroupDecls = map toBindingGroup $ stronglyConnComp valueVerts
60+ return $ filter isImportDecl ds ++
61+ filter isExternDataDecl ds ++
62+ dataBindingGroupDecls ++
63+ filter isTypeClassDeclaration ds ++
64+ filter isFixityDecl ds ++
65+ filter isExternDecl ds ++
66+ bindingGroupDecls
67+
68+-- |
69+-- Collapse all binding groups to individual declarations
70+--
71+collapseBindingGroups :: [Declaration] -> [Declaration]
72+collapseBindingGroups ds = concatMap go ds
73+ where
74+ go (DataBindingGroupDeclaration ds) = ds
75+ go (BindingGroupDeclaration ds) = map (\(ident, val) -> ValueDeclaration ident [] Nothing val) ds
76+ go other = [other]
77+
78+usedIdents :: (Data d) => ModuleName -> d -> [Ident]
79+usedIdents moduleName = nub . everything (++) (mkQ [] names)
80+ where
81+ names :: Value -> [Ident]
82+ names (Var (Qualified Nothing name)) = [name]
83+ names (Var (Qualified (Just moduleName') name)) | moduleName == moduleName' = [name]
84+ names _ = []
85+
86+usedProperNames :: (Data d) => d -> [ProperName]
87+usedProperNames = nub . everything (++) (mkQ [] names)
88+ where
89+ names :: Type -> [ProperName]
90+ names (TypeConstructor (Qualified Nothing name)) = [name]
91+ names _ = []
92+
93+getIdent :: Declaration -> Ident
94+getIdent (ValueDeclaration ident _ _ _) = ident
95+getIdent _ = error "Expected ValueDeclaration"
96+
97+getProperName :: Declaration -> ProperName
98+getProperName (DataDeclaration pn _ _) = pn
99+getProperName (TypeSynonymDeclaration pn _ _) = pn
100+getProperName _ = error "Expected DataDeclaration"
101+
102+toBindingGroup :: SCC Declaration -> Declaration
103+toBindingGroup (AcyclicSCC d) = d
104+toBindingGroup (CyclicSCC [d]) = d
105+toBindingGroup (CyclicSCC ds') = BindingGroupDeclaration $ map fromValueDecl ds'
106+
107+toDataBindingGroup :: SCC Declaration -> Either String Declaration
108+toDataBindingGroup (AcyclicSCC d) = return d
109+toDataBindingGroup (CyclicSCC [TypeSynonymDeclaration pn _ _]) = Left $ "Cycle in type synonym " ++ show pn
110+toDataBindingGroup (CyclicSCC [d]) = return d
111+toDataBindingGroup (CyclicSCC ds')
112+ | all isTypeSynonym ds' = Left "Cycle in type synonyms"
113+ | otherwise = return $ DataBindingGroupDeclaration ds'
114+ where
115+ isTypeSynonym (TypeSynonymDeclaration _ _ _) = True
116+ isTypeSynonym _ = False
117+
118+fromValueDecl :: Declaration -> (Ident, Value)
119+fromValueDecl (ValueDeclaration ident [] Nothing val) = (ident, val)
120+fromValueDecl (ValueDeclaration _ _ _ _) = error "Binders should have been desugared"
121+fromValueDecl _ = error "Expected ValueDeclaration"
src/Language/PureScript/Sugar/CaseDeclarations.hsnew file+70
@@ -0,0 +1,70 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.CaseDeclarations
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- This module implements the desugaring pass which replaces top-level binders with
13+-- case expressions.
14+--
15+-----------------------------------------------------------------------------
16+
17+module Language.PureScript.Sugar.CaseDeclarations (
18+ desugarCases,
19+ desugarCasesModule
20+) where
21+
22+import Data.List (groupBy)
23+import Control.Applicative ((<$>))
24+import Control.Monad (forM, join, unless)
25+import Control.Monad.Error.Class
26+
27+import Language.PureScript.Names
28+import Language.PureScript.Values
29+import Language.PureScript.Declarations
30+import Language.PureScript.Scope
31+
32+-- |
33+-- Replace all top-level binders in a module with case expressions.
34+--
35+desugarCasesModule :: [Module] -> Either String [Module]
36+desugarCasesModule ms = forM ms $ \(Module name ds) -> Module name <$> desugarCases ds
37+-- |
38+-- Replace all top-level binders with case expressions.
39+--
40+desugarCases :: [Declaration] -> Either String [Declaration]
41+desugarCases = fmap join . mapM toDecls . groupBy inSameGroup
42+
43+inSameGroup :: Declaration -> Declaration -> Bool
44+inSameGroup (ValueDeclaration ident1 _ _ _) (ValueDeclaration ident2 _ _ _) = ident1 == ident2
45+inSameGroup _ _ = False
46+
47+toDecls :: [Declaration] -> Either String [Declaration]
48+toDecls d@[ValueDeclaration _ [] Nothing _] = return d
49+toDecls ds@(ValueDeclaration ident bs _ _ : _) = do
50+ let tuples = map toTuple ds
51+ unless (all ((== length bs) . length . fst) tuples) $
52+ throwError $ "Argument list lengths differ in declaration " ++ show ident
53+ return [makeCaseDeclaration ident tuples]
54+toDecls ds = return ds
55+
56+toTuple :: Declaration -> ([Binder], (Maybe Guard, Value))
57+toTuple (ValueDeclaration _ bs g val) = (bs, (g, val))
58+toTuple _ = error "Not a value declaration"
59+
60+makeCaseDeclaration :: Ident -> [([Binder], (Maybe Guard, Value))] -> Declaration
61+makeCaseDeclaration ident alternatives =
62+ let
63+ argPattern = length . fst . head $ alternatives
64+ args = take argPattern $ unusedNames (ident, alternatives)
65+ vars = map (\arg -> Var (Qualified Nothing arg)) args
66+ binders = [ (bs, g, val) | (bs, (g, val)) <- alternatives ]
67+ value = foldr (\args' ret -> Abs args' ret) (Case vars binders) args
68+ in
69+ ValueDeclaration ident [] Nothing value
70+
src/Language/PureScript/Sugar/DoNotation.hsnew file+62
@@ -0,0 +1,62 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Sugar.DoNotation
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- This module implements the desugaring pass which replaces do-notation statements with
13+-- appropriate calls to (>>=) from the Prelude.Monad type class.
14+--
15+-----------------------------------------------------------------------------
16+
17+module Language.PureScript.Sugar.DoNotation (
18+ desugarDo
19+) where
20+
21+import Data.Data
22+import Data.Generics
23+
24+import Language.PureScript.Values
25+import Language.PureScript.Names
26+import Language.PureScript.Scope
27+
28+-- |
29+-- Replace all @DoNotationBind@ and @DoNotationValue@ constructors with applications of the Prelude.(>>=) function,
30+-- and all @DoNotationLet@ constructors with let expressions.
31+--
32+desugarDo :: (Data d) => d -> Either String d
33+desugarDo = everywhereM (mkM replace)
34+ where
35+ prelude :: ModuleName
36+ prelude = ModuleName [ProperName "Prelude"]
37+ ret :: Value
38+ ret = Var (Qualified (Just prelude) (Ident "ret"))
39+ bind :: Value
40+ bind = Var (Qualified (Just prelude) (Op ">>="))
41+ replace :: Value -> Either String Value
42+ replace (Do els) = go els
43+ replace other = return other
44+ go :: [DoNotationElement] -> Either String Value
45+ go [] = error "The impossible happened in desugarDo"
46+ go [DoNotationValue val] = return val
47+ go (DoNotationValue val : rest) = do
48+ rest' <- go rest
49+ return $ App (App bind val) (Abs (Ident "_") rest')
50+ go [DoNotationBind _ _] = Left "Bind statement cannot be the last statement in a do block"
51+ go (DoNotationBind NullBinder val : rest) = go (DoNotationValue val : rest)
52+ go (DoNotationBind (VarBinder ident) val : rest) = do
53+ rest' <- go rest
54+ return $ App (App bind val) (Abs ident rest')
55+ go (DoNotationBind binder val : rest) = do
56+ rest' <- go rest
57+ let ident = head $ unusedNames rest'
58+ return $ App (App bind val) (Abs ident (Case [Var (Qualified Nothing ident)] [([binder], Nothing, rest')]))
59+ go [DoNotationLet _ _] = Left "Let statement cannot be the last statement in a do block"
60+ go (DoNotationLet binder val : rest) = do
61+ rest' <- go rest
62+ return $ Case [val] [([binder], Nothing, rest')]
src/Language/PureScript/Sugar/Let.hsnew file+32
@@ -0,0 +1,32 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Sugar.Let
4+-- Copyright : (c) Phil Freeman 2014
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- This module implements the desugaring pass which turns let bindings into function applications.
13+--
14+-----------------------------------------------------------------------------
15+
16+module Language.PureScript.Sugar.Let (
17+ desugarLetBindings
18+) where
19+
20+import Data.Generics (mkT, everywhere)
21+
22+import Language.PureScript.Values
23+import Language.PureScript.Declarations
24+
25+-- |
26+-- Turn let bindings into function applications
27+--
28+desugarLetBindings :: [Module] -> [Module]
29+desugarLetBindings = everywhere (mkT go)
30+ where
31+ go (Let binder value result) = Case [value] [([binder], Nothing, result)]
32+ go other = other
src/Language/PureScript/Sugar/Operators.hsnew file+114
@@ -0,0 +1,114 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Sugar.Operators
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- This module implements the desugaring pass which reapplies binary operators based
13+-- on their fixity data and removes explicit parentheses.
14+--
15+-- The value parser ignores fixity data when parsing binary operator applications, so
16+-- it is necessary to reorder them here.
17+--
18+-----------------------------------------------------------------------------
19+
20+{-# LANGUAGE Rank2Types #-}
21+
22+module Language.PureScript.Sugar.Operators (
23+ rebracket
24+) where
25+
26+import Language.PureScript.Names
27+import Language.PureScript.Declarations
28+import Language.PureScript.Values
29+
30+import Data.Function (on)
31+import Data.List (groupBy, sortBy)
32+import qualified Data.Map as M
33+import qualified Data.Generics as G
34+import qualified Data.Generics.Extras as G
35+import Control.Monad.State
36+import Control.Applicative
37+import qualified Text.Parsec as P
38+import qualified Text.Parsec.Pos as P
39+import qualified Text.Parsec.Expr as P
40+
41+-- |
42+-- Remove explicit parentheses and reorder binary operator applications
43+--
44+rebracket :: [Module] -> Either String [Module]
45+rebracket = go M.empty []
46+ where
47+ go _ rb [] = return . reverse $ rb
48+ go m rb (Module name ds : ms) = do
49+ m' <- M.union m <$> collectFixities m name ds
50+ let opTable = customOperatorTable m'
51+ ds' <- G.everywhereM' (G.mkM (matchOperators name opTable)) ds
52+ go m' (Module name (G.everywhere (G.mkT removeParens) ds') : rb) ms
53+
54+removeParens :: Value -> Value
55+removeParens (Parens val) = val
56+removeParens val = val
57+
58+customOperatorTable :: M.Map (Qualified Ident) Fixity -> [[(Qualified Ident, Value -> Value -> Value, Associativity)]]
59+customOperatorTable fixities =
60+ let
61+ -- We make the assumption here that infix operators are not qualified. The parser currently enforces this.
62+ -- The fixity map can therefore map from module name/ident pairs to fixities, where the module name is the name
63+ -- of the module imported into, not from. This is useful in matchOp, but here we have to discard the module name to
64+ -- make sure that the generated code is correct.
65+ applyUserOp (Qualified _ name) t1 t2 = App (App (Var (Qualified Nothing name)) t1) t2
66+ userOps = map (\(name, Fixity a p) -> (name, applyUserOp name, p, a)) . M.toList $ fixities
67+ sorted = reverse $ sortBy (compare `on` (\(_, _, p, _) -> p)) userOps
68+ groups = groupBy ((==) `on` (\(_, _, p, _) -> p)) sorted
69+ in
70+ map (map (\(name, f, _, a) -> (name, f, a))) groups
71+
72+type Chain = [Either Value (Qualified Ident)]
73+
74+matchOperators :: ModuleName -> [[(Qualified Ident, Value -> Value -> Value, Associativity)]] -> Value -> Either String Value
75+matchOperators moduleName ops val = G.everywhereM' (G.mkM parseChains) val
76+ where
77+ parseChains :: Value -> Either String Value
78+ parseChains b@(BinaryNoParens _ _ _) = bracketChain (extendChain b)
79+ parseChains other = return other
80+ extendChain :: Value -> Chain
81+ extendChain (BinaryNoParens name l r) = Left l : Right name : extendChain r
82+ extendChain other = [Left other]
83+ bracketChain :: Chain -> Either String Value
84+ bracketChain = either (Left . show) Right . P.parse (P.buildExpressionParser opTable parseValue <* P.eof) "operator expression"
85+ opTable = map (map (\(name, f, a) -> P.Infix (P.try (matchOp moduleName name) >> return f) (toAssoc a))) ops
86+ ++ [[P.Infix (P.try (parseOp >>= \ident -> return (\t1 t2 -> App (App (Var ident) t1) t2))) P.AssocLeft]]
87+
88+toAssoc :: Associativity -> P.Assoc
89+toAssoc Infixl = P.AssocLeft
90+toAssoc Infixr = P.AssocRight
91+
92+parseValue :: P.Parsec Chain () Value
93+parseValue = P.token show (const (P.initialPos "")) (either Just (const Nothing)) P.<?> "expression"
94+
95+parseOp :: P.Parsec Chain () (Qualified Ident)
96+parseOp = P.token show (const (P.initialPos "")) (either (const Nothing) Just) P.<?> "operator"
97+
98+matchOp :: ModuleName -> Qualified Ident -> P.Parsec Chain () ()
99+matchOp moduleName op = do
100+ ident <- parseOp
101+ guard (qualify moduleName ident == qualify moduleName op)
102+
103+collectFixities :: M.Map (Qualified Ident) Fixity -> ModuleName -> [Declaration] -> Either String (M.Map (Qualified Ident) Fixity)
104+collectFixities m _ [] = return m
105+collectFixities m moduleName (FixityDeclaration fixity name : rest) = do
106+ let qual = Qualified (Just moduleName) (Op name)
107+ when (qual `M.member` m) (Left $ "redefined fixity for " ++ show name)
108+ collectFixities (M.insert qual fixity m) moduleName rest
109+collectFixities m moduleName (ImportDeclaration importedModule _ : rest) = do
110+ let fs = [ (i, fixity) | (Qualified mn i, fixity) <- M.toList m, mn == Just importedModule ]
111+ let m' = M.fromList (map (\(i, fixity) -> (Qualified (Just moduleName) i, fixity)) fs)
112+ collectFixities (M.union m' m) moduleName rest
113+collectFixities m moduleName (_:ds) = collectFixities m moduleName ds
114+
src/Language/PureScript/Sugar/TypeClasses.hsnew file+185
@@ -0,0 +1,185 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Sugar.TypeClasses
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- This module implements the desugaring pass which creates type synonyms for type class dictionaries
13+-- and dictionary expressions for type class instances.
14+--
15+-----------------------------------------------------------------------------
16+
17+module Language.PureScript.Sugar.TypeClasses (
18+ desugarTypeClasses,
19+ mkDictionaryValueName,
20+ mkDictionaryEntryName
21+) where
22+
23+import Language.PureScript.Declarations
24+import Language.PureScript.Names
25+import Language.PureScript.Types
26+import Language.PureScript.Values
27+import Language.PureScript.CodeGen.JS.AST
28+import Language.PureScript.Sugar.CaseDeclarations
29+
30+import qualified Data.Map as M
31+
32+import Control.Applicative
33+import Control.Monad.State
34+import Control.Arrow ((***))
35+
36+import Data.Maybe (fromMaybe)
37+import Data.List (nub)
38+import Data.Generics (mkQ, everything)
39+import Language.PureScript.CodeGen.Common (identToJs, moduleNameToJs)
40+
41+type MemberMap = M.Map (ModuleName, ProperName) (String, [(String, Type)])
42+
43+type Desugar = StateT MemberMap (Either String)
44+
45+-- |
46+-- Add type synonym declarations for type class dictionary types, and value declarations for type class
47+-- instance dictionary expressions.
48+--
49+desugarTypeClasses :: [Module] -> Either String [Module]
50+desugarTypeClasses = flip evalStateT M.empty . mapM desugarModule
51+
52+desugarModule :: Module -> Desugar Module
53+desugarModule (Module name decls) = Module name <$> concat <$> mapM (desugarDecl name) decls
54+
55+-- |
56+-- Desugar type class and type class instance declarations
57+--
58+-- Type classes become type synonyms for their dictionaries, and type instances become dictionary declarations.
59+-- Additional values are generated to access individual members of a dictionary, with the appropriate type.
60+--
61+-- E.g. the following
62+--
63+-- module Test where
64+--
65+-- class Foo a where
66+-- foo :: a -> a
67+--
68+-- instance Foo String where
69+-- foo s = s ++ s
70+--
71+-- instance (Foo a) => Foo [a] where
72+-- foo = map foo
73+--
74+-- becomes
75+--
76+-- type Foo a = { foo :: a -> a }
77+--
78+-- foreign import foo "function foo(dict) {\
79+-- \ return dict.foo;\
80+-- \}" :: forall a. (Foo a) => a -> a
81+--
82+-- __Test_Foo_string_foo = (\s -> s ++ s) :: String -> String
83+--
84+-- __Test_Foo_string :: {} -> Foo String
85+-- __Test_Foo_string = { foo: __Test_Foo_string_foo :: String -> String (unchecked) }
86+--
87+-- __Test_Foo_array_foo :: forall a. (Foo a) => [a] -> [a]
88+-- __Test_Foo_array_foo _1 = map (foo _1)
89+--
90+-- __Test_Foo_array :: forall a. Foo a -> Foo [a]
91+-- __Test_Foo_array _1 = { foo: __Test_Foo_array_foo _1 :: [a] -> [a] (unchecked) }
92+--
93+desugarDecl :: ModuleName -> Declaration -> Desugar [Declaration]
94+desugarDecl mn d@(TypeClassDeclaration name arg members) = do
95+ let tys = map memberToNameAndType members
96+ modify (M.insert (mn, name) (arg, tys))
97+ return $ d : typeClassDictionaryDeclaration name arg members : map (typeClassMemberToDictionaryAccessor name arg) members
98+desugarDecl mn d@(TypeInstanceDeclaration deps name ty members) = do
99+ desugared <- lift $ desugarCases members
100+ entries <- mapM (typeInstanceDictionaryEntryDeclaration mn deps name ty) desugared
101+ dictDecl <- typeInstanceDictionaryDeclaration mn deps name ty desugared
102+ return $ d : entries ++ [dictDecl]
103+desugarDecl _ other = return [other]
104+
105+memberToNameAndType :: Declaration -> (String, Type)
106+memberToNameAndType (TypeDeclaration ident ty) = (identToJs ident, ty)
107+memberToNameAndType _ = error "Invalid declaration in type class definition"
108+
109+typeClassDictionaryDeclaration :: ProperName -> String -> [Declaration] -> Declaration
110+typeClassDictionaryDeclaration name arg members =
111+ TypeSynonymDeclaration name [arg] (Object $ rowFromList (map memberToNameAndType members, REmpty))
112+
113+typeClassMemberToDictionaryAccessor :: ProperName -> String -> Declaration -> Declaration
114+typeClassMemberToDictionaryAccessor name arg (TypeDeclaration ident ty) =
115+ ExternDeclaration TypeClassAccessorImport ident
116+ (Just (JSFunction (Just $ identToJs ident) ["dict"] (JSBlock [JSReturn (JSAccessor (identToJs ident) (JSVar "dict"))])))
117+ (ForAll arg (ConstrainedType [(Qualified Nothing name, TypeVar arg)] ty) Nothing)
118+typeClassMemberToDictionaryAccessor _ _ _ = error "Invalid declaration in type class definition"
119+
120+typeInstanceDictionaryDeclaration :: ModuleName -> [(Qualified ProperName, Type)] -> Qualified ProperName -> Type -> [Declaration] -> Desugar Declaration
121+typeInstanceDictionaryDeclaration mn deps name ty decls = do
122+ m <- get
123+ (arg, instanceTys) <- lift $ maybe (Left $ "Type class " ++ show name ++ " is undefined. Type class names must be qualified.") Right
124+ $ M.lookup (qualify mn name) m
125+ let memberTypes = map (id *** replaceTypeVars arg ty) instanceTys
126+ entryName <- lift $ mkDictionaryValueName mn name ty
127+ memberNames <- mapM (memberToNameAndValue memberTypes) decls
128+ return $ ValueDeclaration entryName [] Nothing
129+ (TypedValue True
130+ (foldr Abs (ObjectLiteral memberNames) (map (\n -> Ident ('_' : show n)) [1..max 1 (length deps)]))
131+ (quantify (if null deps then
132+ function unit (TypeApp (TypeConstructor name) ty)
133+ else
134+ foldr function (TypeApp (TypeConstructor name) ty) (map (\(pn, ty') -> TypeApp (TypeConstructor pn) ty') deps)))
135+ )
136+ where
137+ memberToNameAndValue :: [(String, Type)] -> Declaration -> Desugar (String, Value)
138+ memberToNameAndValue tys (ValueDeclaration ident _ _ _) = do
139+ memberType <- lift . maybe (Left "Type class member type not found") Right $ lookup (identToJs ident) tys
140+ memberName <- mkDictionaryEntryName mn name ty ident
141+ return (identToJs ident, TypedValue False
142+ (foldl App (Var (Qualified Nothing memberName)) (map (\n -> Var (Qualified Nothing (Ident ('_' : show n)))) [1..length deps]))
143+ (quantify memberType))
144+ memberToNameAndValue _ _ = error "Invalid declaration in type instance definition"
145+
146+typeInstanceDictionaryEntryDeclaration :: ModuleName -> [(Qualified ProperName, Type)] -> Qualified ProperName -> Type -> Declaration -> Desugar Declaration
147+typeInstanceDictionaryEntryDeclaration mn deps name ty (ValueDeclaration ident [] _ val) = do
148+ m <- get
149+ valTy <- lift $ do (arg, members) <- lookupTypeClass m
150+ ty' <- lookupIdent members
151+ return $ replaceTypeVars arg ty ty'
152+ entryName <- mkDictionaryEntryName mn name ty ident
153+ return $ ValueDeclaration entryName [] Nothing
154+ (TypedValue True val (quantify (if null deps then valTy else ConstrainedType deps valTy)))
155+ where
156+ lookupTypeClass m = maybe (Left $ "Type class " ++ show name ++ " is undefined. Type class names must be qualified.") Right $ M.lookup (qualify mn name) m
157+ lookupIdent members = maybe (Left $ "Type class " ++ show name ++ " does not have method " ++ show ident) Right $ lookup (identToJs ident) members
158+typeInstanceDictionaryEntryDeclaration _ _ _ _ _ = error "Invalid declaration in type instance definition"
159+
160+qualifiedToString :: ModuleName -> Qualified ProperName -> String
161+qualifiedToString mn (Qualified Nothing pn) = qualifiedToString mn (Qualified (Just mn) pn)
162+qualifiedToString _ (Qualified (Just mn) pn) = moduleNameToJs mn ++ "_" ++ runProperName pn
163+
164+-- |
165+-- Generate a name for a type class dictionary, based on the module name, class name and type name
166+--
167+mkDictionaryValueName :: ModuleName -> Qualified ProperName -> Type -> Either String Ident
168+mkDictionaryValueName mn cl ty = do
169+ tyStr <- typeToString mn ty
170+ return $ Ident $ "__" ++ qualifiedToString mn cl ++ "_" ++ tyStr
171+
172+typeToString :: ModuleName -> Type -> Either String String
173+typeToString _ (TypeVar _) = return "var"
174+typeToString mn (TypeConstructor ty') = return $ qualifiedToString mn ty'
175+typeToString mn (TypeApp ty' (TypeVar _)) = typeToString mn ty'
176+typeToString _ _ = Left "Type class instance must be of the form T a1 ... an"
177+
178+-- |
179+-- Generate a name for a type class dictionary member, based on the module name, class name, type name and
180+-- member name
181+--
182+mkDictionaryEntryName :: ModuleName -> Qualified ProperName -> Type -> Ident -> Desugar Ident
183+mkDictionaryEntryName mn name ty ident = do
184+ Ident dictName <- lift $ mkDictionaryValueName mn name ty
185+ return $ Escaped $ dictName ++ "_" ++ identToJs ident
src/Language/PureScript/Sugar/TypeDeclarations.hsnew file+43
@@ -0,0 +1,43 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Sugar.TypeDeclarations
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- This module implements the desugaring pass which replaces top-level type declarations with
13+-- type annotations on the corresponding expression.
14+--
15+-----------------------------------------------------------------------------
16+
17+module Language.PureScript.Sugar.TypeDeclarations (
18+ desugarTypeDeclarations,
19+ desugarTypeDeclarationsModule
20+) where
21+
22+import Control.Applicative
23+import Control.Monad.Error.Class
24+import Control.Monad (forM)
25+
26+import Language.PureScript.Declarations
27+import Language.PureScript.Values
28+
29+-- |
30+-- Replace all top level type declarations in a module with type annotations
31+--
32+desugarTypeDeclarationsModule :: [Module] -> Either String [Module]
33+desugarTypeDeclarationsModule ms = forM ms $ \(Module name ds) -> Module name <$> desugarTypeDeclarations ds
34+
35+-- |
36+-- Replace all top level type declarations with type annotations
37+--
38+desugarTypeDeclarations :: [Declaration] -> Either String [Declaration]
39+desugarTypeDeclarations (TypeDeclaration name ty : ValueDeclaration name' [] Nothing val : rest) | name == name' =
40+ desugarTypeDeclarations (ValueDeclaration name [] Nothing (TypedValue True val ty) : rest)
41+desugarTypeDeclarations (TypeDeclaration name _ : _) = throwError $ "Orphan type declaration for " ++ show name
42+desugarTypeDeclarations (d:ds) = (:) d <$> desugarTypeDeclarations ds
43+desugarTypeDeclarations [] = return []
src/Language/PureScript/TypeChecker.hsnew file+258
@@ -0,0 +1,258 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.TypeChecker
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- The top-level type checker, which checks all declarations in a module.
13+--
14+-----------------------------------------------------------------------------
15+
16+{-# LANGUAGE FlexibleInstances #-}
17+
18+module Language.PureScript.TypeChecker (
19+ module T,
20+ typeCheckAll
21+) where
22+
23+import Language.PureScript.TypeChecker.Monad as T
24+import Language.PureScript.TypeChecker.Kinds as T
25+import Language.PureScript.TypeChecker.Types as T
26+import Language.PureScript.TypeChecker.Synonyms as T
27+
28+import Data.Maybe
29+import qualified Data.Map as M
30+import Control.Monad.State
31+import Control.Monad.Error
32+import Data.Either (rights, lefts)
33+
34+import Language.PureScript.Types
35+import Language.PureScript.Names
36+import Language.PureScript.Values
37+import Language.PureScript.Kinds
38+import Language.PureScript.Declarations
39+import Language.PureScript.Sugar.TypeClasses
40+
41+addDataType :: ModuleName -> ProperName -> [String] -> [(ProperName, [Type])] -> Kind -> Check ()
42+addDataType moduleName name args dctors ctorKind = do
43+ env <- getEnv
44+ putEnv $ env { types = M.insert (moduleName, name) (ctorKind, Data) (types env) }
45+ forM_ dctors $ \(dctor, tys) ->
46+ rethrow (("Error in data constructor " ++ show dctor ++ ":\n") ++) $
47+ addDataConstructor moduleName name args dctor tys
48+
49+addDataConstructor :: ModuleName -> ProperName -> [String] -> ProperName -> [Type] -> Check ()
50+addDataConstructor moduleName name args dctor tys = do
51+ env <- getEnv
52+ dataConstructorIsNotDefined moduleName dctor
53+ let retTy = foldl TypeApp (TypeConstructor (Qualified (Just moduleName) name)) (map TypeVar args)
54+ let dctorTy = foldr function retTy tys
55+ let polyType = mkForAll args dctorTy
56+ putEnv $ env { dataConstructors = M.insert (moduleName, dctor) (qualifyAllUnqualifiedNames moduleName env polyType, DataConstructor) (dataConstructors env) }
57+
58+addTypeSynonym :: ModuleName -> ProperName -> [String] -> Type -> Kind -> Check ()
59+addTypeSynonym moduleName name args ty kind = do
60+ env <- getEnv
61+ putEnv $ env { types = M.insert (moduleName, name) (kind, TypeSynonym) (types env)
62+ , typeSynonyms = M.insert (moduleName, name) (args, qualifyAllUnqualifiedNames moduleName env ty) (typeSynonyms env) }
63+
64+typeIsNotDefined :: ModuleName -> ProperName -> Check ()
65+typeIsNotDefined moduleName name = do
66+ env <- getEnv
67+ guardWith (show name ++ " is already defined") $
68+ not $ M.member (moduleName, name) (types env)
69+
70+dataConstructorIsNotDefined :: ModuleName -> ProperName -> Check ()
71+dataConstructorIsNotDefined moduleName dctor = do
72+ env <- getEnv
73+ guardWith (show dctor ++ " is already defined") $
74+ not $ M.member (moduleName, dctor) (dataConstructors env)
75+
76+valueIsNotDefined :: ModuleName -> Ident -> Check ()
77+valueIsNotDefined moduleName name = do
78+ env <- getEnv
79+ case M.lookup (moduleName, name) (names env) of
80+ Just _ -> throwError $ show name ++ " is already defined"
81+ Nothing -> return ()
82+
83+addValue :: ModuleName -> Ident -> Type -> Check ()
84+addValue moduleName name ty = do
85+ env <- getEnv
86+ putEnv (env { names = M.insert (moduleName, name) (qualifyAllUnqualifiedNames moduleName env ty, Value) (names env) })
87+
88+addTypeClassDictionaries :: [TypeClassDictionaryInScope] -> Check ()
89+addTypeClassDictionaries entries = do
90+ modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = entries ++ (typeClassDictionaries . checkEnv $ st) } }
91+
92+checkTypeClassInstance :: ModuleName -> Type -> Check ()
93+checkTypeClassInstance _ (TypeVar _) = return ()
94+checkTypeClassInstance m (TypeConstructor ctor) = do
95+ env <- getEnv
96+ when (canonicalizeType m env ctor `M.member` typeSynonyms env) $ throwError "Type synonym instances are disallowed"
97+ return ()
98+checkTypeClassInstance m (TypeApp ty (TypeVar _)) = checkTypeClassInstance m ty
99+checkTypeClassInstance _ _ = throwError "Type class instance must be of the form T a1 ... an"
100+
101+-- |
102+-- Type check all declarations in a module
103+--
104+-- At this point, many declarations will have been desugared, but it is still necessary to
105+--
106+-- * Kind-check all types and add them to the @Environment@
107+--
108+-- * Type-check all values and add them to the @Environment@
109+--
110+-- * Bring type class instances into scope
111+--
112+-- * Process module imports
113+--
114+typeCheckAll :: Maybe ModuleName -> ModuleName -> [Declaration] -> Check [Declaration]
115+typeCheckAll _ _ [] = return []
116+typeCheckAll mainModuleName moduleName (d@(DataDeclaration name args dctors) : rest) = do
117+ rethrow (("Error in type constructor " ++ show name ++ ":\n") ++) $ do
118+ typeIsNotDefined moduleName name
119+ ctorKind <- kindsOf moduleName name args (concatMap snd dctors)
120+ addDataType moduleName name args dctors ctorKind
121+ ds <- typeCheckAll mainModuleName moduleName rest
122+ return $ d : ds
123+typeCheckAll mainModuleName moduleName (d@(DataBindingGroupDeclaration tys) : rest) = do
124+ rethrow ("Error in data binding group:\n" ++) $ do
125+ let syns = mapMaybe toTypeSynonym tys
126+ let dataDecls = mapMaybe toDataDecl tys
127+ (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(name, args, dctors) -> (name, args, concatMap snd dctors)) dataDecls)
128+ forM_ (zip dataDecls data_ks) $ \((name, args, dctors), ctorKind) -> do
129+ typeIsNotDefined moduleName name
130+ addDataType moduleName name args dctors ctorKind
131+ forM_ (zip syns syn_ks) $ \((name, args, ty), kind) -> do
132+ typeIsNotDefined moduleName name
133+ addTypeSynonym moduleName name args ty kind
134+ ds <- typeCheckAll mainModuleName moduleName rest
135+ return $ d : ds
136+ where
137+ toTypeSynonym (TypeSynonymDeclaration nm args ty) = Just (nm, args, ty)
138+ toTypeSynonym _ = Nothing
139+ toDataDecl (DataDeclaration nm args dctors) = Just (nm, args, dctors)
140+ toDataDecl _ = Nothing
141+typeCheckAll mainModuleName moduleName (d@(TypeSynonymDeclaration name args ty) : rest) = do
142+ rethrow (("Error in type synonym " ++ show name ++ ":\n") ++) $ do
143+ typeIsNotDefined moduleName name
144+ kind <- kindsOf moduleName name args [ty]
145+ addTypeSynonym moduleName name args ty kind
146+ ds <- typeCheckAll mainModuleName moduleName rest
147+ return $ d : ds
148+typeCheckAll _ _ (TypeDeclaration _ _ : _) = error "Type declarations should have been removed"
149+typeCheckAll mainModuleName moduleName (ValueDeclaration name [] Nothing val : rest) = do
150+ d <- rethrow (("Error in declaration " ++ show name ++ ":\n") ++) $ do
151+ valueIsNotDefined moduleName name
152+ [(_, (val', ty))] <- typesOf mainModuleName moduleName [(name, val)]
153+ addValue moduleName name ty
154+ return $ ValueDeclaration name [] Nothing val'
155+ ds <- typeCheckAll mainModuleName moduleName rest
156+ return $ d : ds
157+typeCheckAll _ _ (ValueDeclaration _ _ _ _ : _) = error "Binders were not desugared"
158+typeCheckAll mainModuleName moduleName (BindingGroupDeclaration vals : rest) = do
159+ d <- rethrow (("Error in binding group " ++ show (map fst vals) ++ ":\n") ++) $ do
160+ forM_ (map fst vals) $ \name ->
161+ valueIsNotDefined moduleName name
162+ tys <- typesOf mainModuleName moduleName vals
163+ vals' <- forM (zip (map fst vals) (map snd tys)) $ \(name, (val, ty)) -> do
164+ addValue moduleName name ty
165+ return (name, val)
166+ return $ BindingGroupDeclaration vals'
167+ ds <- typeCheckAll mainModuleName moduleName rest
168+ return $ d : ds
169+typeCheckAll mainModuleName moduleName (d@(ExternDataDeclaration name kind) : rest) = do
170+ env <- getEnv
171+ guardWith (show name ++ " is already defined") $ not $ M.member (moduleName, name) (types env)
172+ putEnv $ env { types = M.insert (moduleName, name) (kind, TypeSynonym) (types env) }
173+ ds <- typeCheckAll mainModuleName moduleName rest
174+ return $ d : ds
175+typeCheckAll mainModuleName moduleName (d@(ExternDeclaration importTy name _ ty) : rest) = do
176+ rethrow (("Error in foreign import declaration " ++ show name ++ ":\n") ++) $ do
177+ env <- getEnv
178+ kind <- kindOf moduleName ty
179+ guardWith "Expected kind *" $ kind == Star
180+ case M.lookup (moduleName, name) (names env) of
181+ Just _ -> throwError $ show name ++ " is already defined"
182+ Nothing -> putEnv (env { names = M.insert (moduleName, name) (qualifyAllUnqualifiedNames moduleName env ty, Extern importTy) (names env) })
183+ ds <- typeCheckAll mainModuleName moduleName rest
184+ return $ d : ds
185+typeCheckAll mainModuleName moduleName (d@(FixityDeclaration _ name) : rest) = do
186+ ds <- typeCheckAll mainModuleName moduleName rest
187+ env <- getEnv
188+ guardWith ("Fixity declaration with no binding: " ++ name) $ M.member (moduleName, Op name) $ names env
189+ return $ d : ds
190+typeCheckAll mainModuleName currentModule (d@(ImportDeclaration moduleName idents) : rest) = do
191+ env <- getEnv
192+ rethrow errorMessage $ do
193+ guardWith ("Module " ++ show moduleName ++ " does not exist") $ moduleExists env
194+ case idents of
195+ Nothing -> do
196+ shadowIdents (map snd $ filterModule (names env)) env
197+ shadowTypes (map snd $ filterModule (types env)) env
198+ Just idents' -> do
199+ shadowIdents (lefts idents') env
200+ shadowTypes (rights idents') env
201+ shadowTypeClassInstances env
202+ ds <- typeCheckAll mainModuleName currentModule rest
203+ return $ d : ds
204+ where
205+ errorMessage = (("Error in import declaration " ++ show moduleName ++ ":\n") ++)
206+ filterModule = filter ((== moduleName) . fst) . M.keys
207+ moduleExists env = not (null (filterModule (names env))) || not (null (filterModule (types env)))
208+ shadowIdents idents' env =
209+ forM_ idents' $ \ident -> do
210+ case (moduleName, ident) `M.lookup` names env of
211+ Just (_, Alias _ _) -> return ()
212+ Just (pt, _) -> do
213+ guardWith (show currentModule ++ "." ++ show ident ++ " is already defined") $ (currentModule, ident) `M.notMember` names env
214+ modifyEnv (\e -> e { names = M.insert (currentModule, ident) (pt, Alias moduleName ident) (names e) })
215+ Nothing -> throwError (show moduleName ++ "." ++ show ident ++ " is undefined")
216+ shadowTypes pns env =
217+ forM_ pns $ \pn -> do
218+ case (moduleName, pn) `M.lookup` types env of
219+ Nothing -> throwError (show moduleName ++ "." ++ show pn ++ " is undefined")
220+ Just (_, DataAlias _ _) -> return ()
221+ Just (k, _) -> do
222+ guardWith (show currentModule ++ "." ++ show pn ++ " is already defined") $ (currentModule, pn) `M.notMember` types env
223+ modifyEnv (\e -> e { types = M.insert (currentModule, pn) (k, DataAlias moduleName pn) (types e) })
224+ let keys = map (snd . fst) . filter (\(_, (fn, _)) -> fn `constructs` pn) . M.toList . dataConstructors $ env
225+ forM_ keys $ \dctor -> do
226+ case (moduleName, dctor) `M.lookup` dataConstructors env of
227+ Just (_, Alias _ _) -> return ()
228+ Just (ctorTy, _) -> do
229+ guardWith (show currentModule ++ "." ++ show dctor ++ " is already defined") $ (currentModule, dctor) `M.notMember` dataConstructors env
230+ modifyEnv (\e -> e { dataConstructors = M.insert (currentModule, dctor) (ctorTy, Alias moduleName (Ident (runProperName dctor))) (dataConstructors e) })
231+ Nothing -> throwError (show moduleName ++ "." ++ show dctor ++ " is undefined")
232+ shadowTypeClassInstances env = do
233+ let instances = filter (\tcd ->
234+ let Qualified (Just mn) _ = tcdName tcd in
235+ moduleName == mn && tcdType tcd == TCDRegular
236+ ) (typeClassDictionaries env)
237+ forM_ instances $ \tcd -> do
238+ let (Qualified _ ident) = tcdName tcd
239+ addTypeClassDictionaries [tcd { tcdName = (Qualified (Just currentModule) ident), tcdType = TCDAlias (tcdName tcd) }]
240+ constructs (TypeConstructor (Qualified (Just mn) pn')) pn
241+ = mn == moduleName && pn' == pn
242+ constructs (ForAll _ ty _) pn = ty `constructs` pn
243+ constructs (TypeApp (TypeApp t _) ty) pn | t == tyFunction = ty `constructs` pn
244+ constructs (TypeApp ty _) pn = ty `constructs` pn
245+ constructs fn _ = error $ "Invalid arguments to constructs: " ++ show fn
246+typeCheckAll mainModuleName moduleName (d@(TypeClassDeclaration _ _ _) : rest) = do
247+ env <- getEnv
248+ ds <- typeCheckAll mainModuleName moduleName rest
249+ return $ qualifyAllUnqualifiedNames moduleName env d : ds
250+typeCheckAll mainModuleName moduleName (d@(TypeInstanceDeclaration deps className ty _) : rest) = do
251+ env <- getEnv
252+ dictName <- Check . lift $ mkDictionaryValueName moduleName className ty
253+ checkTypeClassInstance moduleName ty
254+ forM_ deps $ checkTypeClassInstance moduleName . snd
255+ addTypeClassDictionaries (qualifyAllUnqualifiedNames moduleName env
256+ [TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) className ty (Just deps) TCDRegular])
257+ ds <- typeCheckAll mainModuleName moduleName rest
258+ return $ qualifyAllUnqualifiedNames moduleName env d : ds
src/Language/PureScript/TypeChecker/Kinds.hsnew file+166
@@ -0,0 +1,166 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.TypeChecker.Kinds
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- This module implements the kind checker
13+--
14+-----------------------------------------------------------------------------
15+
16+{-# OPTIONS_GHC -fno-warn-orphans #-}
17+{-# LANGUAGE DeriveDataTypeable #-}
18+{-# LANGUAGE MultiParamTypeClasses #-}
19+
20+module Language.PureScript.TypeChecker.Kinds (
21+ kindOf,
22+ kindsOf,
23+ kindsOfAll
24+) where
25+
26+import Language.PureScript.Types
27+import Language.PureScript.Kinds
28+import Language.PureScript.Names
29+import Language.PureScript.TypeChecker.Monad
30+import Language.PureScript.Pretty
31+
32+import Control.Monad.State
33+import Control.Monad.Error
34+import Control.Monad.Reader
35+import Control.Monad.Unify
36+
37+import Control.Applicative
38+
39+import qualified Data.Map as M
40+
41+instance Partial Kind where
42+ unknown = KUnknown
43+ isUnknown (KUnknown u) = Just u
44+ isUnknown _ = Nothing
45+
46+instance Unifiable Check Kind where
47+ KUnknown u1 =?= KUnknown u2 | u1 == u2 = return ()
48+ KUnknown u =?= k = u =:= k
49+ k =?= KUnknown u = u =:= k
50+ Star =?= Star = return ()
51+ Bang =?= Bang = return ()
52+ Row k1 =?= Row k2 = k1 =?= k2
53+ FunKind k1 k2 =?= FunKind k3 k4 = do
54+ k1 =?= k3
55+ k2 =?= k4
56+ k1 =?= k2 = UnifyT . lift . throwError $ "Cannot unify " ++ prettyPrintKind k1 ++ " with " ++ prettyPrintKind k2 ++ "."
57+
58+-- |
59+-- Infer the kind of a single type
60+--
61+kindOf :: ModuleName -> Type -> Check Kind
62+kindOf moduleName ty =
63+ rethrow (("Error checking kind of " ++ prettyPrintType ty ++ ":\n") ++) $
64+ fmap tidyUp . liftUnify $ starIfUnknown <$> infer ty
65+ where
66+ tidyUp (k, sub) = sub $? k
67+
68+-- |
69+-- Infer the kind of a type constructor with a collection of arguments and a collection of associated data constructors
70+--
71+kindsOf :: ModuleName -> ProperName -> [String] -> [Type] -> Check Kind
72+kindsOf moduleName name args ts = fmap tidyUp . liftUnify $ do
73+ tyCon <- fresh
74+ kargs <- replicateM (length args) fresh
75+ let dict = (name, tyCon) : zip (map ProperName args) kargs
76+ bindLocalTypeVariables moduleName dict $
77+ solveTypes ts kargs tyCon
78+ where
79+ tidyUp (k, sub) = sub $? k
80+
81+-- |
82+-- Simultaneously infer the kinds of several mutually recursive type constructors
83+--
84+kindsOfAll :: ModuleName -> [(ProperName, [String], Type)] -> [(ProperName, [String], [Type])] -> Check ([Kind], [Kind])
85+kindsOfAll moduleName syns tys = fmap tidyUp . liftUnify $ do
86+ synVars <- replicateM (length syns) fresh
87+ let dict = zipWith (\(name, _, _) var -> (name, var)) syns synVars
88+ bindLocalTypeVariables moduleName dict $ do
89+ tyCons <- replicateM (length tys) fresh
90+ let dict = zipWith (\(name, _, _) tyCon -> (name, tyCon)) tys tyCons
91+ bindLocalTypeVariables moduleName dict $ do
92+ data_ks <- zipWithM (\tyCon (_, args, ts) -> do
93+ kargs <- replicateM (length args) fresh
94+ let argDict = zip (map ProperName args) kargs
95+ bindLocalTypeVariables moduleName argDict $
96+ solveTypes ts kargs tyCon) tyCons tys
97+ syn_ks <- zipWithM (\synVar (_, args, ty) -> do
98+ kargs <- replicateM (length args) fresh
99+ let argDict = zip (map ProperName args) kargs
100+ bindLocalTypeVariables moduleName argDict $
101+ solveTypes [ty] kargs synVar) synVars syns
102+ return (syn_ks, data_ks)
103+ where
104+ tidyUp ((ks1, ks2), sub) = (map (starIfUnknown . (sub $?)) ks1, map (starIfUnknown . (sub $?)) ks2)
105+
106+-- |
107+-- Solve the set of kind constraints associated with the data constructors for a type constructor
108+--
109+solveTypes :: [Type] -> [Kind] -> Kind -> UnifyT Kind Check Kind
110+solveTypes ts kargs tyCon = do
111+ ks <- mapM infer ts
112+ tyCon =?= foldr FunKind Star kargs
113+ forM_ ks $ \k -> k =?= Star
114+ return tyCon
115+
116+-- |
117+-- Default all unknown kinds to the Star kind of types
118+--
119+starIfUnknown :: Kind -> Kind
120+starIfUnknown (KUnknown _) = Star
121+starIfUnknown (FunKind k1 k2) = FunKind (starIfUnknown k1) (starIfUnknown k2)
122+starIfUnknown k = k
123+
124+-- |
125+-- Infer a kind for a type
126+--
127+infer :: Type -> UnifyT Kind Check Kind
128+infer (Object row) = do
129+ k <- infer row
130+ k =?= Row Star
131+ return Star
132+infer (TypeVar v) = do
133+ Just moduleName <- checkCurrentModule <$> get
134+ UnifyT . lift $ lookupTypeVariable moduleName (Qualified Nothing (ProperName v))
135+infer (TypeConstructor v) = do
136+ env <- liftCheck getEnv
137+ Just moduleName <- checkCurrentModule <$> get
138+ case M.lookup (qualify moduleName v) (types env) of
139+ Nothing -> UnifyT . lift . throwError $ "Unknown type constructor '" ++ show v ++ "'"
140+ Just (kind, _) -> return kind
141+infer (TypeApp t1 t2) = do
142+ k0 <- fresh
143+ k1 <- infer t1
144+ k2 <- infer t2
145+ k1 =?= FunKind k2 k0
146+ return k0
147+infer (ForAll ident ty _) = do
148+ k1 <- fresh
149+ Just moduleName <- checkCurrentModule <$> get
150+ k2 <- bindLocalTypeVariables moduleName [(ProperName ident, k1)] $ infer ty
151+ k2 =?= Star
152+ return Star
153+infer REmpty = do
154+ k <- fresh
155+ return $ Row k
156+infer (RCons _ ty row) = do
157+ k1 <- infer ty
158+ k2 <- infer row
159+ k2 =?= Row k1
160+ return $ Row k1
161+infer (ConstrainedType deps ty) = do
162+ mapM_ (infer . snd) deps
163+ k <- infer ty
164+ k =?= Star
165+ return Star
166+infer _ = error "Invalid argument to infer"
src/Language/PureScript/TypeChecker/Monad.hsnew file+340
@@ -0,0 +1,340 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.TypeChecker.Monad
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- Monads for type checking and type inference and associated data types
13+--
14+-----------------------------------------------------------------------------
15+
16+{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances, RankNTypes, DeriveDataTypeable,
17+ GADTs, StandaloneDeriving, MultiParamTypeClasses, FlexibleContexts #-}
18+
19+module Language.PureScript.TypeChecker.Monad where
20+
21+import Language.PureScript.Types
22+import Language.PureScript.Kinds
23+import Language.PureScript.Values
24+import Language.PureScript.Names
25+import Language.PureScript.Declarations
26+
27+import Data.Data
28+import Data.Maybe
29+import Data.Monoid
30+import Data.Generics (mkT, everywhere)
31+
32+import Control.Applicative
33+import Control.Monad.State
34+import Control.Monad.Error
35+import Control.Monad.Reader
36+import Control.Monad.Unify
37+import Control.Arrow ((***))
38+
39+import qualified Data.Map as M
40+
41+-- |
42+-- The type of a name in the @Environment@
43+--
44+data NameKind
45+ -- |
46+ -- A value introduced as a binding in a module
47+ --
48+ = Value
49+ -- |
50+ -- A foreign import
51+ --
52+ | Extern ForeignImportType
53+ -- |
54+ -- An alias for a value in another module, introduced using an import declaration
55+ --
56+ | Alias ModuleName Ident
57+ -- |
58+ -- A local name introduced using a lambda abstraction, variable introduction or binder
59+ --
60+ | LocalVariable
61+ -- |
62+ -- A data constructor
63+ --
64+ | DataConstructor deriving Show
65+
66+-- |
67+-- The type of a type declaration
68+--
69+data TypeDeclarationKind
70+ -- |
71+ -- A data constructor
72+ --
73+ = Data
74+ -- |
75+ -- A data type foreign import
76+ --
77+ | ExternData
78+ -- |
79+ -- A type synonym
80+ --
81+ | TypeSynonym
82+ -- |
83+ -- An alias for a type in another module, introduced using an import declaration
84+ --
85+ | DataAlias ModuleName ProperName
86+ -- |
87+ -- A local type name introduced using a forall quantifier
88+ --
89+ | LocalTypeVariable deriving Show
90+
91+-- |
92+-- The @Environment@ defines all values and types which are currently in scope:
93+--
94+data Environment = Environment {
95+ -- |
96+ -- Value names currently in scope
97+ --
98+ names :: M.Map (ModuleName, Ident) (Type, NameKind)
99+ -- |
100+ -- Type names currently in scope
101+ --
102+ , types :: M.Map (ModuleName, ProperName) (Kind, TypeDeclarationKind)
103+ -- |
104+ -- Data constructors currently in scope, along with their associated data type constructors
105+ --
106+ , dataConstructors :: M.Map (ModuleName, ProperName) (Type, NameKind)
107+ -- |
108+ -- Type synonyms currently in scope
109+ --
110+ , typeSynonyms :: M.Map (ModuleName, ProperName) ([String], Type)
111+ -- |
112+ -- Available type class dictionaries
113+ --
114+ , typeClassDictionaries :: [TypeClassDictionaryInScope]
115+ } deriving (Show)
116+
117+-- |
118+-- The basic types existing in the external javascript environment
119+--
120+jsTypes ::M.Map (ModuleName, ProperName) (Kind, TypeDeclarationKind)
121+jsTypes = M.fromList [ ((ModuleName [ProperName "Prim"], ProperName "Function"), (FunKind Star $ FunKind Star Star, ExternData))
122+ , ((ModuleName [ProperName "Prim"], ProperName "Array"), (FunKind Star Star, ExternData))
123+ , ((ModuleName [ProperName "Prim"], ProperName "String"), (Star, ExternData))
124+ , ((ModuleName [ProperName "Prim"], ProperName "Number"), (Star, ExternData))
125+ , ((ModuleName [ProperName "Prim"], ProperName "Boolean"), (Star, ExternData)) ]
126+
127+-- |
128+-- The initial environment with no values and only the default javascript types defined
129+--
130+initEnvironment :: Environment
131+initEnvironment = Environment M.empty jsTypes M.empty M.empty []
132+
133+-- |
134+-- Temporarily bind a collection of names to values
135+--
136+bindNames :: (MonadState CheckState m) => M.Map (ModuleName, Ident) (Type, NameKind) -> m a -> m a
137+bindNames newNames action = do
138+ orig <- get
139+ modify $ \st -> st { checkEnv = (checkEnv st) { names = newNames `M.union` (names . checkEnv $ st) } }
140+ a <- action
141+ modify $ \st -> st { checkEnv = (checkEnv st) { names = names . checkEnv $ orig } }
142+ return a
143+
144+-- |
145+-- Temporarily bind a collection of names to types
146+--
147+bindTypes :: (MonadState CheckState m) => M.Map (ModuleName, ProperName) (Kind, TypeDeclarationKind) -> m a -> m a
148+bindTypes newNames action = do
149+ orig <- get
150+ modify $ \st -> st { checkEnv = (checkEnv st) { types = newNames `M.union` (types . checkEnv $ st) } }
151+ a <- action
152+ modify $ \st -> st { checkEnv = (checkEnv st) { types = types . checkEnv $ orig } }
153+ return a
154+
155+-- |
156+-- Temporarily make a collection of type class dictionaries available
157+--
158+withTypeClassDictionaries :: (MonadState CheckState m) => [TypeClassDictionaryInScope] -> m a -> m a
159+withTypeClassDictionaries entries action = do
160+ orig <- get
161+ modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = entries ++ (typeClassDictionaries . checkEnv $ st) } }
162+ a <- action
163+ modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = typeClassDictionaries . checkEnv $ orig } }
164+ return a
165+
166+-- |
167+-- Get the currently available list of type class dictionaries
168+--
169+getTypeClassDictionaries :: (Functor m, MonadState CheckState m) => m [TypeClassDictionaryInScope]
170+getTypeClassDictionaries = typeClassDictionaries . checkEnv <$> get
171+
172+-- |
173+-- Temporarily bind a collection of names to local variables
174+--
175+bindLocalVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(Ident, Type)] -> m a -> m a
176+bindLocalVariables moduleName bindings action =
177+ bindNames (M.fromList $ flip map bindings $ \(name, ty) -> ((moduleName, name), (ty, LocalVariable))) action
178+
179+-- |
180+-- Temporarily bind a collection of names to local type variables
181+--
182+bindLocalTypeVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(ProperName, Kind)] -> m a -> m a
183+bindLocalTypeVariables moduleName bindings action =
184+ bindTypes (M.fromList $ flip map bindings $ \(name, k) -> ((moduleName, name), (k, LocalTypeVariable))) action
185+
186+-- |
187+-- Lookup the type of a value by name in the @Environment@
188+--
189+lookupVariable :: (Functor m, MonadState CheckState m, MonadError String m) => ModuleName -> Qualified Ident -> m Type
190+lookupVariable currentModule (Qualified moduleName var) = do
191+ env <- getEnv
192+ case M.lookup (fromMaybe currentModule moduleName, var) (names env) of
193+ Nothing -> throwError $ show var ++ " is undefined"
194+ Just (ty, _) -> return ty
195+
196+-- |
197+-- Lookup the kind of a type by name in the @Environment@
198+--
199+lookupTypeVariable :: (Functor m, MonadState CheckState m, MonadError String m) => ModuleName -> Qualified ProperName -> m Kind
200+lookupTypeVariable currentModule (Qualified moduleName name) = do
201+ env <- getEnv
202+ case M.lookup (fromMaybe currentModule moduleName, name) (types env) of
203+ Nothing -> throwError $ "Type variable " ++ show name ++ " is undefined"
204+ Just (k, _) -> return k
205+
206+-- |
207+-- Canonicalize an identifier by resolving any aliases introduced by module imports
208+--
209+canonicalize :: ModuleName -> Environment -> Qualified Ident -> (ModuleName, Ident)
210+canonicalize _ _ (Qualified (Just mn) i) = (mn, i)
211+canonicalize mn env (Qualified Nothing i) = case (mn, i) `M.lookup` names env of
212+ Just (_, Alias mn' i') -> (mn', i')
213+ _ -> (mn, i)
214+
215+-- |
216+-- Canonicalize a type variable by resolving any aliases introduced by module imports
217+--
218+canonicalizeType :: ModuleName -> Environment -> Qualified ProperName -> (ModuleName, ProperName)
219+canonicalizeType _ _ (Qualified (Just mn) nm) = (mn, nm)
220+canonicalizeType mn env (Qualified Nothing nm) = case (mn, nm) `M.lookup` types env of
221+ Just (_, DataAlias mn' pn') -> (mn', pn')
222+ _ -> (mn, nm)
223+
224+-- |
225+-- Canonicalize a data constructor by resolving any aliases introduced by module imports
226+--
227+canonicalizeDataConstructor :: ModuleName -> Environment -> Qualified ProperName -> (ModuleName, ProperName)
228+canonicalizeDataConstructor _ _ (Qualified (Just mn) pn) = (mn, pn)
229+canonicalizeDataConstructor mn env (Qualified Nothing pn) = case (mn, pn) `M.lookup` dataConstructors env of
230+ Just (_, Alias mn' (Ident pn')) -> (mn', ProperName pn')
231+ _ -> (mn, pn)
232+
233+-- |
234+-- State required for type checking:
235+--
236+data CheckState = CheckState {
237+ -- |
238+ -- The current @Environment@
239+ --
240+ checkEnv :: Environment
241+ -- |
242+ -- The next fresh unification variable name
243+ --
244+ , checkNextVar :: Int
245+ -- |
246+ -- The next type class dictionary name
247+ --
248+ , checkNextDictName :: Int
249+ -- |
250+ -- The current module
251+ --
252+ , checkCurrentModule :: Maybe ModuleName
253+ }
254+
255+-- |
256+-- The type checking monad, which provides the state of the type checker, and error reporting capabilities
257+--
258+newtype Check a = Check { unCheck :: StateT CheckState (Either String) a }
259+ deriving (Functor, Monad, Applicative, MonadPlus, MonadState CheckState, MonadError String)
260+
261+-- |
262+-- Get the current @Environment@
263+--
264+getEnv :: (Functor m, MonadState CheckState m) => m Environment
265+getEnv = checkEnv <$> get
266+
267+-- |
268+-- Update the @Environment#
269+--
270+putEnv :: (MonadState CheckState m) => Environment -> m ()
271+putEnv env = modify (\s -> s { checkEnv = env })
272+
273+-- |
274+-- Modify the @Environment@
275+--
276+modifyEnv :: (MonadState CheckState m) => (Environment -> Environment) -> m ()
277+modifyEnv f = modify (\s -> s { checkEnv = f (checkEnv s) })
278+
279+-- |
280+-- Run a computation in the Check monad, failing with an error, or succeeding with a return value and the final @Environment@.
281+--
282+runCheck :: Check a -> Either String (a, Environment)
283+runCheck c = do
284+ (a, s) <- flip runStateT (CheckState initEnvironment 0 0 Nothing) $ unCheck c
285+ return (a, checkEnv s)
286+
287+-- |
288+-- Make an assertion, failing with an error message
289+--
290+guardWith :: (MonadError e m) => e -> Bool -> m ()
291+guardWith _ True = return ()
292+guardWith e False = throwError e
293+
294+-- |
295+-- Rethrow an error with a more detailed error message in the case of failure
296+--
297+rethrow :: (MonadError e m) => (e -> e) -> m a -> m a
298+rethrow f = flip catchError $ \e -> throwError (f e)
299+
300+-- |
301+-- Generate new type class dictionary name
302+--
303+freshDictionaryName :: Check Int
304+freshDictionaryName = do
305+ n <- checkNextDictName <$> get
306+ modify $ \s -> s { checkNextDictName = succ (checkNextDictName s) }
307+ return n
308+
309+-- |
310+-- Lift a computation in the @Check@ monad into the substitution monad.
311+--
312+liftCheck :: Check a -> UnifyT t Check a
313+liftCheck = UnifyT . lift . lift
314+
315+-- |
316+-- Run a computation in the substitution monad, generating a return value and the final substitution.
317+--
318+liftUnify :: (Partial t) => UnifyT t Check a -> Check (a, Substitution t)
319+liftUnify unify = do
320+ st <- get
321+ e <- runUnify (defaultUnifyState { unifyNextVar = checkNextVar st }) unify
322+ case e of
323+ Left err -> throwError err
324+ Right (a, ust) -> do
325+ modify $ \st -> st { checkNextVar = unifyNextVar ust }
326+ return (a, unifyCurrentSubstitution ust)
327+
328+-- |
329+-- Replace any unqualified names in a type wit their qualified versionss
330+--
331+qualifyAllUnqualifiedNames :: (Data d) => ModuleName -> Environment -> d -> d
332+qualifyAllUnqualifiedNames mn env = everywhere (mkT go)
333+ where
334+ go :: Type -> Type
335+ go (TypeConstructor nm) = TypeConstructor $ qualify' nm
336+ go (SaturatedTypeSynonym nm args) = SaturatedTypeSynonym (qualify' nm) args
337+ go (ConstrainedType constraints ty) = ConstrainedType (map (qualify' *** id) constraints) ty
338+ go other = other
339+ qualify' qual = let (mn', pn') = canonicalizeType mn env qual
340+ in Qualified (Just mn') pn'
src/Language/PureScript/TypeChecker/Synonyms.hsnew file+59
@@ -0,0 +1,59 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.TypeChecker.Synonyms
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- Functions for replacing fully applied type synonyms with the @SaturatedTypeSynonym@ data constructor
13+--
14+-----------------------------------------------------------------------------
15+
16+module Language.PureScript.TypeChecker.Synonyms (
17+ saturateTypeSynonym,
18+ saturateAllTypeSynonyms
19+) where
20+
21+import Language.PureScript.Types
22+import Language.PureScript.Names
23+import Language.PureScript.TypeChecker.Monad (Environment(..), canonicalizeType)
24+
25+import Data.Maybe (fromMaybe)
26+import Data.Data
27+import Data.Generics
28+import Data.Generics.Extras
29+import Control.Monad.Writer
30+import Control.Monad.Error
31+
32+-- |
33+-- Build a type substitution for a type synonym
34+--
35+buildTypeSubstitution :: Environment -> ModuleName -> (ModuleName, ProperName) -> Int -> Type -> Either String (Maybe Type)
36+buildTypeSubstitution env moduleName name n = go n []
37+ where
38+ go :: Int -> [Type] -> Type -> Either String (Maybe Type)
39+ go 0 args (TypeConstructor ctor) | name == canonicalizeType moduleName env ctor = return (Just $ SaturatedTypeSynonym ctor args)
40+ go m _ (TypeConstructor ctor) | m > 0 && name == qualify moduleName ctor = throwError $ "Partially applied type synonym " ++ show name
41+ go m args (TypeApp f arg) = go (m - 1) (arg:args) f
42+ go _ _ _ = return Nothing
43+
44+-- |
45+-- Replace all instances of a specific type synonym with the @SaturatedTypeSynonym@ data constructor
46+--
47+saturateTypeSynonym :: (Data d) => Environment -> ModuleName -> (ModuleName, ProperName) -> Int -> d -> Either String d
48+saturateTypeSynonym env moduleName name n = everywhereM' (mkM replace)
49+ where
50+ replace t = fmap (fromMaybe t) $ buildTypeSubstitution env moduleName name n t
51+
52+-- |
53+-- Replace all type synonyms with the @SaturatedTypeSynonym@ data constructor
54+--
55+saturateAllTypeSynonyms :: (Data d) => Environment -> ModuleName -> [((ModuleName, ProperName), Int)] -> d -> Either String d
56+saturateAllTypeSynonyms env moduleName syns d = foldM (\result (name, n) -> saturateTypeSynonym env moduleName name n result) d syns
57+
58+
59+
src/Language/PureScript/TypeChecker/Types.hsnew file+960
@@ -0,0 +1,960 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.TypeChecker.Types
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- This module implements the type checker
13+--
14+-----------------------------------------------------------------------------
15+
16+{-# OPTIONS_GHC -fno-warn-orphans #-}
17+{-# LANGUAGE DeriveDataTypeable #-}
18+{-# LANGUAGE FlexibleContexts #-}
19+{-# LANGUAGE MultiParamTypeClasses #-}
20+
21+module Language.PureScript.TypeChecker.Types (
22+ typesOf
23+) where
24+
25+{-
26+ The following functions represent the corresponding type checking judgements:
27+
28+ infer
29+ Synthesize a type for a value
30+
31+ check
32+ Check a value has a given type
33+
34+ checkProperties
35+ Check an object with a given type contains specified properties
36+
37+ checkFunctionApplication
38+ Check a function of a given type returns a value of another type when applied to its arguments
39+
40+ subsumes
41+ Check a type subsumes another type
42+-}
43+
44+import Data.List
45+import Data.Maybe (maybeToList, isNothing, isJust, fromMaybe)
46+import qualified Data.Data as D
47+import Data.Generics
48+ (everythingWithContext, mkM, everywhereM, everything, mkT,
49+ something, everywhere, mkQ)
50+import Data.Generics.Extras
51+
52+import Language.PureScript.Values
53+import Language.PureScript.Types
54+import Language.PureScript.Kinds
55+import Language.PureScript.Names
56+import Language.PureScript.TypeChecker.Monad
57+import Language.PureScript.TypeChecker.Kinds
58+import Language.PureScript.TypeChecker.Synonyms
59+import Language.PureScript.Pretty
60+
61+import Control.Monad.State
62+import Control.Monad.Error
63+import Control.Monad.Reader
64+import Control.Monad.Unify
65+
66+import Control.Applicative
67+import Control.Arrow (Arrow(..))
68+
69+import qualified Data.Map as M
70+import Data.Function (on)
71+import Data.Ord (comparing)
72+
73+instance Partial Type where
74+ unknown = TUnknown
75+ isUnknown (TUnknown u) = Just u
76+ isUnknown _ = Nothing
77+
78+instance Unifiable Check Type where
79+ (=?=) = unifyTypes
80+
81+-- |
82+-- Unify two types, updating the current substitution
83+--
84+unifyTypes :: Type -> Type -> UnifyT Type Check ()
85+unifyTypes t1 t2 = rethrow (\e -> "Error unifying type " ++ prettyPrintType t1 ++ " with type " ++ prettyPrintType t2 ++ ":\n" ++ e) $ do
86+ unifyTypes' t1 t2
87+ where
88+ unifyTypes' (TUnknown u1) (TUnknown u2) | u1 == u2 = return ()
89+ unifyTypes' (TUnknown u) t = u =:= t
90+ unifyTypes' t (TUnknown u) = u =:= t
91+ unifyTypes' (SaturatedTypeSynonym name args) ty = do
92+ ty1 <- introduceSkolemScope <=< expandTypeSynonym name $ args
93+ ty1 `unifyTypes` ty
94+ unifyTypes' ty s@(SaturatedTypeSynonym _ _) = s `unifyTypes` ty
95+ unifyTypes' (ForAll ident1 ty1 sc1) (ForAll ident2 ty2 sc2) =
96+ case (sc1, sc2) of
97+ (Just sc1', Just sc2') -> do
98+ sko <- newSkolemConstant
99+ let sk1 = skolemize ident1 sko sc1' ty1
100+ let sk2 = skolemize ident2 sko sc2' ty2
101+ sk1 `unifyTypes` sk2
102+ _ -> throwError (prettyPrintType ty1)
103+ unifyTypes' (ForAll ident ty1 (Just sc)) ty2 = do
104+ sko <- newSkolemConstant
105+ let sk = skolemize ident sko sc ty1
106+ sk `unifyTypes` ty2
107+ unifyTypes' (ForAll _ _ _) _ = throwError "Skolem variable scope is unspecified"
108+ unifyTypes' ty f@(ForAll _ _ _) = f `unifyTypes` ty
109+ unifyTypes' (Object row1) (Object row2) = row1 =?= row2
110+ unifyTypes' (TypeVar v1) (TypeVar v2) | v1 == v2 = return ()
111+ unifyTypes' (TypeConstructor c1) (TypeConstructor c2) = do
112+ env <- getEnv
113+ Just moduleName <- checkCurrentModule <$> get
114+ guardWith ("Cannot unify " ++ show c1 ++ " with " ++ show c2 ++ ".") (typeConstructorsAreEqual env moduleName c1 c2)
115+ unifyTypes' (TypeApp t3 t4) (TypeApp t5 t6) = do
116+ t3 `unifyTypes` t5
117+ t4 `unifyTypes` t6
118+ unifyTypes' (Skolem s1 _) (Skolem s2 _) | s1 == s2 = return ()
119+ unifyTypes' r1@(RCons _ _ _) r2 = unifyRows r1 r2
120+ unifyTypes' r1 r2@(RCons _ _ _) = unifyRows r1 r2
121+ unifyTypes' r1@REmpty r2 = unifyRows r1 r2
122+ unifyTypes' r1 r2@REmpty = unifyRows r1 r2
123+ unifyTypes' t3 t4 = throwError $ "Cannot unify " ++ prettyPrintType t3 ++ " with " ++ prettyPrintType t4 ++ "."
124+
125+-- |
126+-- Unify two rows, updating the current substitution
127+--
128+-- Common labels are first identified, and unified. Remaining labels and types are unified with a
129+-- trailing row unification variable, if appropriate, otherwise leftover labels result in a unification
130+-- error.
131+--
132+unifyRows :: Type -> Type -> UnifyT Type Check ()
133+unifyRows r1 r2 =
134+ let
135+ (s1, r1') = rowToList r1
136+ (s2, r2') = rowToList r2
137+ int = [ (t1, t2) | (name, t1) <- s1, (name', t2) <- s2, name == name' ]
138+ sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ]
139+ sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ]
140+ in do
141+ forM_ int (uncurry (=?=))
142+ unifyRows' sd1 r1' sd2 r2'
143+ where
144+ unifyRows' :: [(String, Type)] -> Type -> [(String, Type)] -> Type -> UnifyT Type Check ()
145+ unifyRows' [] (TUnknown u) sd r = u =:= rowFromList (sd, r)
146+ unifyRows' sd r [] (TUnknown u) = u =:= rowFromList (sd, r)
147+ unifyRows' ((name, ty):row) r others u@(TUnknown un) = do
148+ occursCheck un ty
149+ forM_ row $ \(_, t) -> occursCheck un t
150+ u' <- fresh
151+ u =?= RCons name ty u'
152+ unifyRows' row r others u'
153+ unifyRows' [] REmpty [] REmpty = return ()
154+ unifyRows' [] (TypeVar v1) [] (TypeVar v2) | v1 == v2 = return ()
155+ unifyRows' [] (Skolem s1 _) [] (Skolem s2 _) | s1 == s2 = return ()
156+ unifyRows' sd3 r3 sd4 r4 = throwError $ "Cannot unify (" ++ prettyPrintRow (rowFromList (sd3, r3)) ++ ") with (" ++ prettyPrintRow (rowFromList (sd4, r4)) ++ ")."
157+
158+-- |
159+-- Ensure type constructors are equal after canonicalization
160+--
161+typeConstructorsAreEqual :: Environment -> ModuleName -> Qualified ProperName -> Qualified ProperName -> Bool
162+typeConstructorsAreEqual env moduleName = (==) `on` canonicalizeType moduleName env
163+
164+-- |
165+-- Infer the types of multiple mutually-recursive values, and return elaborated values including
166+-- type class dictionaries and type annotations.
167+--
168+typesOf :: Maybe ModuleName -> ModuleName -> [(Ident, Value)] -> Check [(Ident, (Value, Type))]
169+typesOf mainModuleName moduleName vals = do
170+ tys <- fmap tidyUp . liftUnify $ do
171+ let
172+ -- Map each declaration to a name/value pair, with an optional type, if the declaration is typed
173+ es = map isTyped vals
174+ -- Filter the typed and untyped declarations
175+ typed = filter (isJust . snd . snd) es
176+ untyped = filter (isNothing . snd . snd) es
177+ -- Make a map of names to typed declarations
178+ typedDict = map (\(ident, (_, Just (ty, _))) -> (ident, ty)) typed
179+ -- Create fresh unification variables for the types of untyped declarations
180+ untypedNames <- replicateM (length untyped) fresh
181+ let
182+ -- Make a map of names to the unification variables of untyped declarations
183+ untypedDict = zip (map fst untyped) untypedNames
184+ -- Create the dictionary of all name/type pairs, which will be added to the environment during type checking
185+ dict = M.fromList (map (\(ident, ty) -> ((moduleName, ident), (ty, LocalVariable))) $ typedDict ++ untypedDict)
186+ forM es $ \e@(_, (val, _)) -> do
187+ -- If the declaration is a function, it has access to other values in the binding group.
188+ -- If not, the generated code might fail at runtime since those values might be undefined.
189+ let dict' = if isFunction val then dict else M.empty
190+ triple@(_, (val, ty)) <- case e of
191+ -- Typed declarations
192+ (ident, (val, Just (ty, checkType))) -> do
193+ -- Kind check
194+ kind <- liftCheck $ kindOf moduleName ty
195+ guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
196+ -- Check the type with the new names in scope
197+ ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty
198+ val' <- bindNames dict' $ if checkType
199+ then TypedValue True <$> check val ty' <*> pure ty'
200+ else return (TypedValue False val ty')
201+ return (ident, (val', ty'))
202+ -- Untyped declarations
203+ (ident, (val, Nothing)) -> do
204+ -- Infer the type with the new names in scope
205+ TypedValue _ val' ty <- bindNames dict' $ infer val
206+ ty =?= fromMaybe (error "name not found in dictionary") (lookup ident untypedDict)
207+ return (ident, (TypedValue True val' ty, ty))
208+ -- If --main is enabled, need to check that `main` has type Eff eff a for some eff, a
209+ when (Just moduleName == mainModuleName && fst e == Ident "main") $ do
210+ [eff, a] <- replicateM 2 fresh
211+ ty =?= TypeApp (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Eff"])) (ProperName "Eff"))) eff) a
212+ -- Make sure unification variables do not escape
213+ escapeCheck val ty
214+ return triple
215+ forM tys $ \(ident, (val, ty)) -> do
216+ -- Replace type class dictionary placeholders with actual dictionaries
217+ val' <- replaceTypeClassDictionaries moduleName val
218+ -- Check skolem variables did not escape their scope
219+ skolemEscapeCheck val'
220+ -- Remove type synonyms placeholders, remove duplicate row fields, and replace
221+ -- top-level unification variables with named type variables.
222+ let val'' = overTypes (desaturateAllTypeSynonyms . setifyAll) val'
223+ ty' = varIfUnknown . desaturateAllTypeSynonyms . setifyAll $ ty
224+ return $ (ident, (val'', ty'))
225+ where
226+ -- Apply the substitution that was returned from runUnify to both types and (type-annotated) values
227+ tidyUp (ts, sub) = map (\(i, (val, ty)) -> (i, (overTypes (sub $?) val, sub $? ty))) ts
228+
229+-- |
230+-- Check if a value introduces a function
231+--
232+isFunction :: Value -> Bool
233+isFunction (Abs _ _) = True
234+isFunction (TypedValue _ val _) = isFunction val
235+isFunction _ = False
236+
237+-- |
238+-- Check if a value contains a type annotation
239+--
240+isTyped :: (Ident, Value) -> (Ident, (Value, Maybe (Type, Bool)))
241+isTyped (name, TypedValue checkType value ty) = (name, (value, Just (ty, checkType)))
242+isTyped (name, value) = (name, (value, Nothing))
243+
244+-- |
245+-- Map a function over type annotations appearing inside a value
246+--
247+overTypes :: (Type -> Type) -> Value -> Value
248+overTypes f = everywhere (mkT f)
249+
250+-- |
251+-- Replace type class dictionary placeholders with inferred type class dictionaries
252+--
253+replaceTypeClassDictionaries :: ModuleName -> Value -> Check Value
254+replaceTypeClassDictionaries mn = everywhereM' (mkM go)
255+ where
256+ go (TypeClassDictionary constraint dicts) = entails mn dicts constraint
257+ go other = return other
258+
259+-- |
260+-- Check that the current set of type class dictionaries entail the specified type class goal, and, if so,
261+-- return a type class dictionary reference.
262+--
263+entails :: ModuleName -> [TypeClassDictionaryInScope] -> (Qualified ProperName, Type) -> Check Value
264+entails moduleName context goal@(className, ty) = do
265+ env <- getEnv
266+ case go env goal of
267+ [] -> throwError $ "No " ++ show className ++ " instance found for " ++ prettyPrintType ty
268+ (dict : _) -> return dict
269+ where
270+ go env (className', ty') =
271+ [ mkDictionary (canonicalizeDictionary tcd) args
272+ | tcd <- context
273+ -- Choose type class dictionaries in scope in the current module
274+ , filterModule tcd
275+ -- Make sure the type class name matches the one we are trying to satisfy
276+ , typeConstructorsAreEqual env moduleName className' (tcdClassName tcd)
277+ -- Make sure the type unifies with the type in the type instance definition
278+ , subst <- maybeToList $ typeHeadsAreEqual moduleName env ty' (tcdInstanceType tcd)
279+ -- Solve any necessary subgoals
280+ , args <- solveSubgoals env subst (tcdDependencies tcd) ]
281+ -- Create dictionaries for subgoals which still need to be solved by calling go recursively
282+ -- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type
283+ -- unifies with Either a b, and we can satisfy the subgoals Show a and Show b recursively.
284+ solveSubgoals :: Environment -> [(String, Type)] -> Maybe [(Qualified ProperName, Type)] -> [Maybe [Value]]
285+ solveSubgoals _ _ Nothing = return Nothing
286+ solveSubgoals env subst (Just subgoals) = do
287+ dict <- mapM (go env) (map (id *** replaceAllTypeVars subst) subgoals)
288+ return $ Just dict
289+ -- Make a dictionary from subgoal dictionaries by applying the correct function
290+ mkDictionary :: Qualified Ident -> Maybe [Value] -> Value
291+ mkDictionary fnName Nothing = Var fnName
292+ mkDictionary fnName (Just []) = App (Var fnName) (ObjectLiteral [])
293+ mkDictionary fnName (Just dicts) = foldl App (Var fnName) dicts
294+ -- Filter out type dictionaries which are in scope in the current module
295+ filterModule :: TypeClassDictionaryInScope -> Bool
296+ filterModule (TypeClassDictionaryInScope { tcdName = Qualified (Just mn) _ }) | mn == moduleName = True
297+ filterModule (TypeClassDictionaryInScope { tcdName = Qualified Nothing _ }) = True
298+ filterModule _ = False
299+ -- Resolve a type class dictionary in scope to an actual value by following any (TCDAlias) pointers
300+ -- which originated from module imports
301+ canonicalizeDictionary :: TypeClassDictionaryInScope -> Qualified Ident
302+ canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDRegular, tcdName = nm }) = nm
303+ canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDAlias nm }) = nm
304+
305+-- |
306+-- Check whether the type heads of two types are equal (for the purposes of type class dictionary lookup),
307+-- and return a substitution from type variables to types which makes the type heads unify.
308+--
309+typeHeadsAreEqual :: ModuleName -> Environment -> Type -> Type -> Maybe [(String, Type)]
310+typeHeadsAreEqual _ _ (Skolem s1 _) (Skolem s2 _) | s1 == s2 = Just []
311+typeHeadsAreEqual _ _ (TypeVar v) t = Just [(v, t)]
312+typeHeadsAreEqual _ _ t (TypeVar v) = Just [(v, t)]
313+typeHeadsAreEqual m e (TypeConstructor c1) (TypeConstructor c2) | typeConstructorsAreEqual e m c1 c2 = Just []
314+typeHeadsAreEqual m e (TypeApp h1 (TypeVar v)) (TypeApp h2 arg) = (:) (v, arg) <$> typeHeadsAreEqual m e h1 h2
315+typeHeadsAreEqual m e t1@(TypeApp _ _) t2@(TypeApp _ (TypeVar _)) = typeHeadsAreEqual m e t2 t1
316+typeHeadsAreEqual m e (SaturatedTypeSynonym name args) t2 = case expandTypeSynonym' e m name args of
317+ Left err -> Nothing
318+ Right t1 -> typeHeadsAreEqual m e t1 t2
319+typeHeadsAreEqual _ _ _ _ = Nothing
320+
321+-- |
322+-- Ensure unsolved unification variables do not escape
323+--
324+escapeCheck :: Value -> Type -> UnifyT Type Check ()
325+escapeCheck value ty = do
326+ subst <- unifyCurrentSubstitution <$> UnifyT get
327+ let visibleUnknowns = nub $ unknowns $ subst $? ty
328+ let allUnknowns = findAllTypes value
329+ forM_ allUnknowns $ \t -> do
330+ let unsolvedUnknowns = nub . unknowns $ subst $? t
331+ guardWith "Escape check fails" $ null $ unsolvedUnknowns \\ visibleUnknowns
332+
333+-- |
334+-- Find all type annotations occuring inside a value
335+--
336+findAllTypes :: Value -> [Type]
337+findAllTypes = everything (++) (mkQ [] go)
338+ where
339+ go (TypedValue _ _ ty) = [ty]
340+ go _ = []
341+
342+-- |
343+-- Ensure skolem variables do not escape their scope
344+--
345+skolemEscapeCheck :: Value -> Check ()
346+skolemEscapeCheck (TypedValue False _ _) = return ()
347+skolemEscapeCheck root@(TypedValue _ _ _) =
348+ -- Every skolem variable is created when a ForAll type is skolemized.
349+ -- This determines the scope of that skolem variable, which is copied from the SkolemScope
350+ -- field of the ForAll constructor.
351+ -- We traverse the tree top-down, and collect any SkolemScopes introduced by ForAlls.
352+ -- If a Skolem is encountered whose SkolemScope is not in the current list, we have found
353+ -- an escaped skolem variable.
354+ case everythingWithContext [] (++) (mkQ ((,) []) go) root of
355+ [] -> return ()
356+ ((binding, val) : _) -> throwError $ "Rigid/skolem type variable bound by " ++ maybe "<unknown>" prettyPrintValue binding ++ " has escaped at " ++ prettyPrintValue val
357+ where
358+ go :: Value -> [(SkolemScope, Value)] -> ([(Maybe Value, Value)], [(SkolemScope, Value)])
359+ go val@(TypedValue _ _ (ForAll _ _ (Just sco))) scos = ([], (sco, val) : scos)
360+ go val@(TypedValue _ _ ty) scos = case collectSkolems ty \\ map fst scos of
361+ (sco : _) -> ([(findBindingScope sco, val)], scos)
362+ _ -> ([], scos)
363+ where
364+ collectSkolems :: Type -> [SkolemScope]
365+ collectSkolems = nub . everything (++) (mkQ [] collect)
366+ where
367+ collect (Skolem _ scope) = [scope]
368+ collect _ = []
369+ go _ scos = ([], scos)
370+ findBindingScope :: SkolemScope -> Maybe Value
371+ findBindingScope sco = something (mkQ Nothing go) root
372+ where
373+ go val@(TypedValue _ _ (ForAll _ _ (Just sco'))) | sco == sco' = Just val
374+ go _ = Nothing
375+skolemEscapeCheck val = throwError $ "Untyped value passed to skolemEscapeCheck: " ++ prettyPrintValue val
376+
377+-- |
378+-- Ensure a row contains no duplicate labels
379+--
380+setify :: Type -> Type
381+setify = rowFromList . first (M.toList . M.fromList) . rowToList
382+
383+-- |
384+-- \"Setify\" all rows occuring inside a value
385+--
386+setifyAll :: (D.Data d) => d -> d
387+setifyAll = everywhere (mkT setify)
388+
389+-- |
390+-- Replace outermost unsolved unification variables with named type variables
391+--
392+varIfUnknown :: Type -> Type
393+varIfUnknown ty =
394+ let unks = nub $ unknowns ty
395+ toName = (:) 't' . show
396+ ty' = everywhere (mkT typeToVar) $ ty
397+ typeToVar :: Type -> Type
398+ typeToVar (TUnknown (Unknown u)) = TypeVar (toName u)
399+ typeToVar t = t
400+ in mkForAll (sort . map (toName . runUnknown) $ unks) ty'
401+
402+-- |
403+-- Replace named type variables with types
404+--
405+replaceAllTypeVars :: [(String, Type)] -> Type -> Type
406+replaceAllTypeVars = foldl' (\f (name, ty) -> replaceTypeVars name ty . f) id
407+
408+-- |
409+-- Remove any ForAlls and ConstrainedType constructors in a type by introducing new unknowns
410+-- or TypeClassDictionary values.
411+--
412+-- This is necessary during type checking to avoid unifying a polymorphic type with a
413+-- unification variable.
414+--
415+instantiatePolyTypeWithUnknowns :: Value -> Type -> UnifyT Type Check (Value, Type)
416+instantiatePolyTypeWithUnknowns val (ForAll ident ty _) = do
417+ ty' <- replaceVarWithUnknown ident ty
418+ instantiatePolyTypeWithUnknowns val ty'
419+instantiatePolyTypeWithUnknowns val (ConstrainedType constraints ty) = do
420+ env <- getEnv
421+ Just moduleName <- checkCurrentModule <$> get
422+ dicts <- getTypeClassDictionaries
423+ (_, ty') <- instantiatePolyTypeWithUnknowns (error "Types under a constraint cannot themselves be constrained") ty
424+ return (foldl App val (map (flip TypeClassDictionary dicts) (qualifyAllUnqualifiedNames moduleName env constraints)), ty')
425+instantiatePolyTypeWithUnknowns val ty = return (val, ty)
426+
427+-- |
428+-- Replace a single type variable with a new unification variable
429+--
430+replaceVarWithUnknown :: String -> Type -> UnifyT Type Check Type
431+replaceVarWithUnknown ident ty = do
432+ tu <- fresh
433+ return $ replaceTypeVars ident tu $ ty
434+
435+-- |
436+-- Replace fully applied type synonyms with the @SaturatedTypeSynonym@ data constructor, which helps generate
437+-- better error messages during unification.
438+--
439+replaceAllTypeSynonyms' :: (D.Data d) => Environment -> ModuleName -> d -> Either String d
440+replaceAllTypeSynonyms' env moduleName d =
441+ let
442+ syns = map (\((path, name), (args, _)) -> ((path, name), length args)) . M.toList $ typeSynonyms env
443+ in
444+ saturateAllTypeSynonyms env moduleName syns d
445+
446+replaceAllTypeSynonyms :: (Functor m, Monad m, MonadState CheckState m, MonadError String m) => (D.Data d) => d -> m d
447+replaceAllTypeSynonyms d = do
448+ env <- getEnv
449+ Just moduleName <- checkCurrentModule <$> get
450+ either throwError return $ replaceAllTypeSynonyms' env moduleName d
451+
452+-- |
453+-- \"Desaturate\" @SaturatedTypeSynonym@s
454+--
455+desaturateAllTypeSynonyms :: (D.Data d) => d -> d
456+desaturateAllTypeSynonyms = everywhere (mkT replaceSaturatedTypeSynonym)
457+ where
458+ replaceSaturatedTypeSynonym (SaturatedTypeSynonym name args) = foldl TypeApp (TypeConstructor name) args
459+ replaceSaturatedTypeSynonym t = t
460+
461+-- |
462+-- Replace a type synonym and its arguments with the aliased type
463+--
464+expandTypeSynonym' :: Environment -> ModuleName -> Qualified ProperName -> [Type] -> Either String Type
465+expandTypeSynonym' env moduleName name args =
466+ case M.lookup (canonicalizeType moduleName env name) (typeSynonyms env) of
467+ Just (synArgs, body) -> do
468+ let repl = replaceAllTypeVars (zip synArgs args) body
469+ replaceAllTypeSynonyms' env moduleName repl
470+ Nothing -> error "Type synonym was not defined"
471+
472+expandTypeSynonym :: (Functor m, Monad m, MonadState CheckState m, MonadError String m) => Qualified ProperName -> [Type] -> m Type
473+expandTypeSynonym name args = do
474+ env <- getEnv
475+ Just moduleName <- checkCurrentModule <$> get
476+ either throwError return $ expandTypeSynonym' env moduleName name args
477+
478+-- |
479+-- Ensure a set of property names and value does not contain duplicate labels
480+--
481+ensureNoDuplicateProperties :: (MonadError String m) => [(String, Value)] -> m ()
482+ensureNoDuplicateProperties ps = guardWith "Duplicate property names" $ length (nub . map fst $ ps) == length ps
483+
484+-- |
485+-- Infer a type for a value, rethrowing any error to provide a more useful error message
486+--
487+infer :: Value -> UnifyT Type Check Value
488+infer val = rethrow (\e -> "Error inferring type of term " ++ prettyPrintValue val ++ ":\n" ++ e) $ infer' val
489+
490+-- |
491+-- Infer a type for a value
492+--
493+infer' :: Value -> UnifyT Type Check Value
494+infer' v@(NumericLiteral _) = return $ TypedValue True v tyNumber
495+infer' v@(StringLiteral _) = return $ TypedValue True v tyString
496+infer' v@(BooleanLiteral _) = return $ TypedValue True v tyBoolean
497+infer' (ArrayLiteral vals) = do
498+ ts <- mapM infer vals
499+ els <- fresh
500+ forM_ ts $ \(TypedValue _ _ t) -> els =?= TypeApp tyArray t
501+ return $ TypedValue True (ArrayLiteral ts) els
502+infer' (ObjectLiteral ps) = do
503+ ensureNoDuplicateProperties ps
504+ ts <- mapM (infer . snd) ps
505+ let fields = zipWith (\name (TypedValue _ _ t) -> (name, t)) (map fst ps) ts
506+ ty = Object $ rowFromList (fields, REmpty)
507+ return $ TypedValue True (ObjectLiteral (zip (map fst ps) ts)) ty
508+infer' (ObjectUpdate o ps) = do
509+ ensureNoDuplicateProperties ps
510+ row <- fresh
511+ newVals <- zipWith (\(name, _) t -> (name, t)) ps <$> mapM (infer . snd) ps
512+ let newTys = map (\(name, TypedValue _ _ ty) -> (name, ty)) newVals
513+ oldTys <- zip (map fst ps) <$> replicateM (length ps) fresh
514+ let oldTy = Object $ rowFromList (oldTys, row)
515+ o' <- TypedValue True <$> check o oldTy <*> pure oldTy
516+ return $ TypedValue True (ObjectUpdate o' newVals) $ Object $ rowFromList (newTys, row)
517+infer' (Accessor prop val) = do
518+ typed@(TypedValue _ _ objTy) <- infer val
519+ propTy <- inferProperty objTy prop
520+ case propTy of
521+ Nothing -> do
522+ field <- fresh
523+ rest <- fresh
524+ _ <- subsumes Nothing objTy (Object (RCons prop field rest))
525+ return $ TypedValue True (Accessor prop typed) field
526+ Just ty -> return $ TypedValue True (Accessor prop typed) ty
527+infer' (Abs arg ret) = do
528+ ty <- fresh
529+ Just moduleName <- checkCurrentModule <$> get
530+ bindLocalVariables moduleName [(arg, ty)] $ do
531+ body@(TypedValue _ _ bodyTy) <- infer' ret
532+ return $ TypedValue True (Abs arg body) $ function ty bodyTy
533+infer' (App f arg) = do
534+ f'@(TypedValue _ _ ft) <- infer f
535+ (ret, app) <- checkFunctionApplication f' ft arg
536+ return $ TypedValue True app ret
537+infer' (Var var) = do
538+ Just moduleName <- checkCurrentModule <$> get
539+ ty <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< lookupVariable moduleName $ var
540+ case ty of
541+ ConstrainedType constraints ty' -> do
542+ env <- getEnv
543+ dicts <- getTypeClassDictionaries
544+ return $ TypedValue True (foldl App (Var var) (map (flip TypeClassDictionary dicts) (qualifyAllUnqualifiedNames moduleName env constraints))) ty'
545+ _ -> return $ TypedValue True (Var var) ty
546+infer' v@(Constructor c) = do
547+ env <- getEnv
548+ Just moduleName <- checkCurrentModule <$> get
549+ case M.lookup (qualify moduleName c) (dataConstructors env) of
550+ Nothing -> throwError $ "Constructor " ++ show c ++ " is undefined"
551+ Just (ty, _) -> do ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty
552+ return $ TypedValue True v ty'
553+infer' (Case vals binders) = do
554+ ts <- mapM infer vals
555+ ret <- fresh
556+ binders' <- checkBinders (map (\(TypedValue _ _ t) -> t) ts) ret binders
557+ return $ TypedValue True (Case ts binders') ret
558+infer' (IfThenElse cond th el) = do
559+ cond' <- check cond tyBoolean
560+ v2@(TypedValue _ _ t2) <- infer th
561+ v3@(TypedValue _ _ t3) <- infer el
562+ t2 =?= t3
563+ return $ TypedValue True (IfThenElse cond' v2 v3) t2
564+infer' (TypedValue checkType val ty) = do
565+ Just moduleName <- checkCurrentModule <$> get
566+ kind <- liftCheck $ kindOf moduleName ty
567+ guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
568+ ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty
569+ val' <- if checkType then check val ty' else return val
570+ return $ TypedValue True val' ty'
571+infer' _ = error "Invalid argument to infer"
572+
573+-- |
574+-- Infer the type of a property inside a record with a given type
575+--
576+inferProperty :: Type -> String -> UnifyT Type Check (Maybe Type)
577+inferProperty (Object row) prop = do
578+ let (props, _) = rowToList row
579+ return $ lookup prop props
580+inferProperty (SaturatedTypeSynonym name args) prop = do
581+ replaced <- introduceSkolemScope <=< expandTypeSynonym name $ args
582+ inferProperty replaced prop
583+inferProperty (ForAll ident ty _) prop = do
584+ replaced <- replaceVarWithUnknown ident ty
585+ inferProperty replaced prop
586+inferProperty _ _ = return Nothing
587+
588+-- |
589+-- Infer the types of variables brought into scope by a binder
590+--
591+inferBinder :: Type -> Binder -> UnifyT Type Check (M.Map Ident Type)
592+inferBinder _ NullBinder = return M.empty
593+inferBinder val (StringBinder _) = val =?= tyString >> return M.empty
594+inferBinder val (NumberBinder _) = val =?= tyNumber >> return M.empty
595+inferBinder val (BooleanBinder _) = val =?= tyBoolean >> return M.empty
596+inferBinder val (VarBinder name) = return $ M.singleton name val
597+inferBinder val (ConstructorBinder ctor binders) = do
598+ env <- getEnv
599+ Just moduleName <- checkCurrentModule <$> get
600+ case M.lookup (qualify moduleName ctor) (dataConstructors env) of
601+ Just (ty, _) -> do
602+ (_, fn) <- instantiatePolyTypeWithUnknowns (error "Data constructor types cannot contains constraints") ty
603+ go binders fn
604+ where
605+ go [] ty = do
606+ subsumes Nothing val ty
607+ return M.empty
608+ go (binder : binders) (TypeApp (TypeApp t obj) ret) | t == tyFunction =
609+ M.union <$> inferBinder obj binder <*> go binders ret
610+ go _ _ = throwError $ "Wrong number of arguments to constructor " ++ show ctor
611+ _ -> throwError $ "Constructor " ++ show ctor ++ " is not defined"
612+inferBinder val (ObjectBinder props) = do
613+ row <- fresh
614+ rest <- fresh
615+ m1 <- inferRowProperties row rest props
616+ val =?= Object row
617+ return m1
618+ where
619+ inferRowProperties :: Type -> Type -> [(String, Binder)] -> UnifyT Type Check (M.Map Ident Type)
620+ inferRowProperties nrow row [] = nrow =?= row >> return M.empty
621+ inferRowProperties nrow row ((name, binder):binders) = do
622+ propTy <- fresh
623+ m1 <- inferBinder propTy binder
624+ m2 <- inferRowProperties nrow (RCons name propTy row) binders
625+ return $ m1 `M.union` m2
626+inferBinder val (ArrayBinder binders) = do
627+ el <- fresh
628+ m1 <- M.unions <$> mapM (inferBinder el) binders
629+ val =?= TypeApp tyArray el
630+ return m1
631+inferBinder val (ConsBinder headBinder tailBinder) = do
632+ el <- fresh
633+ m1 <- inferBinder el headBinder
634+ m2 <- inferBinder val tailBinder
635+ val =?= TypeApp tyArray el
636+ return $ m1 `M.union` m2
637+inferBinder val (NamedBinder name binder) = do
638+ m <- inferBinder val binder
639+ return $ M.insert name val m
640+
641+-- |
642+-- Check the types of the return values in a set of binders in a case statement
643+--
644+checkBinders :: [Type] -> Type -> [([Binder], Maybe Guard, Value)] -> UnifyT Type Check [([Binder], Maybe Guard, Value)]
645+checkBinders _ _ [] = return []
646+checkBinders nvals ret ((binders, grd, val):bs) = do
647+ Just moduleName <- checkCurrentModule <$> get
648+ m1 <- M.unions <$> zipWithM inferBinder nvals binders
649+ r <- bindLocalVariables moduleName (M.toList m1) $ do
650+ val' <- TypedValue True <$> check val ret <*> pure ret
651+ case grd of
652+ Nothing -> return (binders, Nothing, val')
653+ Just g -> do
654+ g' <- check g tyBoolean
655+ return (binders, Just g', val')
656+ rs <- checkBinders nvals ret bs
657+ return $ r : rs
658+
659+-- |
660+-- Check that a local variable name is not already used
661+--
662+assignVariable :: Ident -> UnifyT Type Check ()
663+assignVariable name = do
664+ env <- checkEnv <$> get
665+ Just moduleName <- checkCurrentModule <$> get
666+ case M.lookup (moduleName, name) (names env) of
667+ Just _ -> UnifyT . lift . throwError $ "Variable with name " ++ show name ++ " already exists."
668+ _ -> return ()
669+
670+-- |
671+-- Generate a new skolem constant
672+--
673+newSkolemConstant :: UnifyT Type Check Int
674+newSkolemConstant = runUnknown <$> fresh'
675+
676+-- |
677+-- Generate a new skolem scope
678+--
679+newSkolemScope :: UnifyT Type Check SkolemScope
680+newSkolemScope = SkolemScope . runUnknown <$> fresh'
681+
682+-- |
683+-- Skolemize a type variable by replacing its instances with fresh skolem constants
684+--
685+skolemize :: String -> Int -> SkolemScope -> Type -> Type
686+skolemize ident sko scope = replaceTypeVars ident (Skolem sko scope)
687+
688+-- |
689+-- Introduce skolem scope at every occurence of a ForAll
690+--
691+introduceSkolemScope :: Type -> UnifyT Type Check Type
692+introduceSkolemScope = everywhereM (mkM go)
693+ where
694+ go (ForAll ident ty Nothing) = ForAll ident ty <$> (Just <$> newSkolemScope)
695+ go other = return other
696+
697+-- |
698+-- Check the type of a value, rethrowing errors to provide a better error message
699+--
700+check :: Value -> Type -> UnifyT Type Check Value
701+check val ty = rethrow errorMessage $ check' val ty
702+ where
703+ errorMessage msg =
704+ "Error checking type of term " ++
705+ prettyPrintValue val ++
706+ " against type " ++
707+ prettyPrintType ty ++
708+ ":\n" ++
709+ msg
710+
711+-- |
712+-- Check the type of a value
713+--
714+check' :: Value -> Type -> UnifyT Type Check Value
715+check' val t@(ForAll ident ty _) = do
716+ scope <- newSkolemScope
717+ sko <- newSkolemConstant
718+ let sk = skolemize ident sko scope ty
719+ val' <- check val sk
720+ return $ TypedValue True val' (ForAll ident ty (Just scope))
721+check' val t@(ConstrainedType constraints ty) = do
722+ env <- getEnv
723+ Just moduleName <- checkCurrentModule <$> get
724+ dictNames <- flip mapM constraints $ \(Qualified _ (ProperName className), _) -> do
725+ n <- liftCheck freshDictionaryName
726+ return $ Ident $ "__dict_" ++ className ++ "_" ++ show n
727+ val' <- withTypeClassDictionaries (zipWith (\name (className, instanceTy) ->
728+ TypeClassDictionaryInScope name className instanceTy Nothing TCDRegular) (map (Qualified Nothing) dictNames)
729+ (qualifyAllUnqualifiedNames moduleName env constraints)) $
730+ check val ty
731+ return $ TypedValue True (foldr Abs val' dictNames) t
732+check' val t@(SaturatedTypeSynonym name args) = do
733+ ty <- introduceSkolemScope <=< expandTypeSynonym name $ args
734+ val' <- check val ty
735+ return $ TypedValue True val' ty
736+check' val u@(TUnknown _) = do
737+ val'@(TypedValue _ _ ty) <- infer val
738+ -- Don't unify an unknown with an inferred polytype
739+ (val'', ty') <- instantiatePolyTypeWithUnknowns val' ty
740+ ty' =?= u
741+ return $ TypedValue True val'' ty'
742+check' v@(NumericLiteral _) t | t == tyNumber =
743+ return $ TypedValue True v t
744+check' v@(StringLiteral _) t | t == tyString =
745+ return $ TypedValue True v t
746+check' v@(BooleanLiteral _) t | t == tyBoolean =
747+ return $ TypedValue True v t
748+check' (ArrayLiteral vals) t@(TypeApp a ty) | a == tyArray = do
749+ arr <- ArrayLiteral <$> forM vals (\val -> check val ty)
750+ return $ TypedValue True arr t
751+check' (Abs arg ret) ty@(TypeApp (TypeApp t argTy) retTy) | t == tyFunction = do
752+ Just moduleName <- checkCurrentModule <$> get
753+ ret' <- bindLocalVariables moduleName [(arg, argTy)] $ check ret retTy
754+ return $ TypedValue True (Abs arg ret') ty
755+check' (App f arg) ret = do
756+ f'@(TypedValue _ _ ft) <- infer f
757+ (ret', app) <- checkFunctionApplication f' ft arg
758+ subsumes Nothing ret' ret
759+ return $ TypedValue True app ret
760+check' v@(Var var) ty = do
761+ Just moduleName <- checkCurrentModule <$> get
762+ repl <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< lookupVariable moduleName $ var
763+ ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty
764+ v' <- subsumes (Just v) repl ty'
765+ case v' of
766+ Nothing -> throwError "Unable to check type subsumption"
767+ Just v'' -> return $ TypedValue True v'' ty'
768+check' (TypedValue checkType val ty1) ty2 = do
769+ Just moduleName <- checkCurrentModule <$> get
770+ kind <- liftCheck $ kindOf moduleName ty1
771+ guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
772+ ty1' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1
773+ val' <- subsumes (Just val) ty1' ty2
774+ case val' of
775+ Nothing -> throwError "Unable to check type subsumption"
776+ Just val'' -> do
777+ val''' <- if checkType then check val'' ty1 else return val''
778+ return $ TypedValue checkType (TypedValue True val''' ty1) ty2
779+check' (Case vals binders) ret = do
780+ vals' <- mapM infer vals
781+ let ts = map (\(TypedValue _ _ t) -> t) vals'
782+ binders' <- checkBinders ts ret binders
783+ return $ TypedValue True (Case vals' binders') ret
784+check' (IfThenElse cond th el) ty = do
785+ cond' <- check cond tyBoolean
786+ th' <- check th ty
787+ el' <- check el ty
788+ return $ TypedValue True (IfThenElse cond' th' el') ty
789+check' (ObjectLiteral ps) t@(Object row) = do
790+ ensureNoDuplicateProperties ps
791+ ps' <- checkProperties ps row False
792+ return $ TypedValue True (ObjectLiteral ps') t
793+check' (ObjectUpdate obj ps) t@(Object row) = do
794+ ensureNoDuplicateProperties ps
795+ us <- zip (map fst ps) <$> replicateM (length ps) fresh
796+ let (propsToCheck, rest) = rowToList row
797+ propsToRemove = map fst ps
798+ remainingProps = filter (\(p, _) -> p `notElem` propsToRemove) propsToCheck
799+ obj' <- check obj (Object (rowFromList (us ++ remainingProps, rest)))
800+ ps' <- checkProperties ps row True
801+ return $ TypedValue True (ObjectUpdate obj' ps') t
802+check' (Accessor prop val) ty = do
803+ rest <- fresh
804+ val' <- check val (Object (RCons prop ty rest))
805+ return $ TypedValue True (Accessor prop val') ty
806+check' (Constructor c) ty = do
807+ env <- getEnv
808+ Just moduleName <- checkCurrentModule <$> get
809+ case M.lookup (qualify moduleName c) (dataConstructors env) of
810+ Nothing -> throwError $ "Constructor " ++ show c ++ " is undefined"
811+ Just (ty1, _) -> do
812+ repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1
813+ _ <- subsumes Nothing repl ty
814+ return $ TypedValue True (Constructor c) ty
815+check' val ty = throwError $ prettyPrintValue val ++ " does not have type " ++ prettyPrintType ty
816+
817+-- |
818+-- Check the type of a collection of named record fields
819+--
820+-- The @lax@ parameter controls whether or not every record member has to be provided. For object updates, this is not the case.
821+--
822+checkProperties :: [(String, Value)] -> Type -> Bool -> UnifyT Type Check [(String, Value)]
823+checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where
824+ go [] [] REmpty = return []
825+ go [] [] u@(TUnknown _) = do u =?= REmpty
826+ return []
827+ go [] [] (Skolem _ _) | lax = return []
828+ go [] ((p, _): _) _ | lax = return []
829+ | otherwise = throwError $ prettyPrintValue (ObjectLiteral ps) ++ " does not have property " ++ p
830+ go ((p,_):_) [] REmpty = throwError $ "Property " ++ p ++ " is not present in closed object type " ++ prettyPrintRow row
831+ go ((p,v):ps') [] u@(TUnknown _) = do
832+ v'@(TypedValue _ _ ty) <- infer v
833+ rest <- fresh
834+ u =?= RCons p ty rest
835+ ps'' <- go ps' [] rest
836+ return $ (p, v') : ps''
837+ go ((p,v):ps') ts r =
838+ case lookup p ts of
839+ Nothing -> do
840+ v'@(TypedValue _ _ ty) <- infer v
841+ rest <- fresh
842+ r =?= RCons p ty rest
843+ ps'' <- go ps' ts rest
844+ return $ (p, v') : ps''
845+ Just ty -> do
846+ v' <- check v ty
847+ ps'' <- go ps' (delete (p, ty) ts) r
848+ return $ (p, v') : ps''
849+ go _ _ _ = throwError $ prettyPrintValue (ObjectLiteral ps) ++ " does not have type " ++ prettyPrintType (Object row)
850+
851+-- |
852+-- Check the type of a function application, rethrowing errors to provide a better error message
853+--
854+checkFunctionApplication :: Value -> Type -> Value -> UnifyT Type Check (Type, Value)
855+checkFunctionApplication fn fnTy arg = rethrow errorMessage $ checkFunctionApplication' fn fnTy arg
856+ where
857+ errorMessage msg = "Error applying function of type "
858+ ++ prettyPrintType fnTy
859+ ++ " to argument " ++ prettyPrintValue arg
860+ ++ ":\n" ++ msg
861+
862+-- |
863+-- Check the type of a function application
864+--
865+checkFunctionApplication' :: Value -> Type -> Value -> UnifyT Type Check (Type, Value)
866+checkFunctionApplication' fn (TypeApp (TypeApp tyFunction' argTy) retTy) arg = do
867+ tyFunction' =?= tyFunction
868+ arg' <- check arg argTy
869+ return (retTy, App fn arg')
870+checkFunctionApplication' fn (ForAll ident ty _) arg = do
871+ replaced <- replaceVarWithUnknown ident ty
872+ checkFunctionApplication fn replaced arg
873+checkFunctionApplication' fn u@(TUnknown _) arg = do
874+ arg' <- do
875+ TypedValue _ arg' t <- infer arg
876+ (arg'', t') <- instantiatePolyTypeWithUnknowns arg' t
877+ return $ TypedValue True arg'' t'
878+ let ty = (\(TypedValue _ _ t) -> t) arg'
879+ ret <- fresh
880+ u =?= function ty ret
881+ return (ret, App fn arg')
882+checkFunctionApplication' fn (SaturatedTypeSynonym name tyArgs) arg = do
883+ ty <- introduceSkolemScope <=< expandTypeSynonym name $ tyArgs
884+ checkFunctionApplication fn ty arg
885+checkFunctionApplication' fn (ConstrainedType constraints fnTy) arg = do
886+ env <- getEnv
887+ dicts <- getTypeClassDictionaries
888+ Just moduleName <- checkCurrentModule <$> get
889+ checkFunctionApplication' (foldl App fn (map (flip TypeClassDictionary dicts) (qualifyAllUnqualifiedNames moduleName env constraints))) fnTy arg
890+checkFunctionApplication' _ fnTy arg = throwError $ "Cannot apply a function of type "
891+ ++ prettyPrintType fnTy
892+ ++ " to argument " ++ prettyPrintValue arg
893+
894+-- |
895+-- Check whether one type subsumes another, rethrowing errors to provide a better error message
896+--
897+subsumes :: Maybe Value -> Type -> Type -> UnifyT Type Check (Maybe Value)
898+subsumes val ty1 ty2 = rethrow errorMessage $ subsumes' val ty1 ty2
899+ where
900+ errorMessage msg = "Error checking that type "
901+ ++ prettyPrintType ty1
902+ ++ " subsumes type "
903+ ++ prettyPrintType ty2
904+ ++ ":\n" ++ msg
905+
906+-- |
907+-- Check whether one type subsumes another
908+--
909+subsumes' :: Maybe Value -> Type -> Type -> UnifyT Type Check (Maybe Value)
910+subsumes' val (ForAll ident ty1 _) ty2 = do
911+ replaced <- replaceVarWithUnknown ident ty1
912+ subsumes val replaced ty2
913+subsumes' val ty1 (ForAll ident ty2 sco) =
914+ case sco of
915+ Just sco' -> do
916+ sko <- newSkolemConstant
917+ let sk = skolemize ident sko sco' ty2
918+ subsumes val ty1 sk
919+ Nothing -> throwError "Skolem variable scope is unspecified"
920+subsumes' val (TypeApp (TypeApp f1 arg1) ret1) (TypeApp (TypeApp f2 arg2) ret2) | f1 == tyFunction && f2 == tyFunction = do
921+ subsumes Nothing arg2 arg1
922+ subsumes Nothing ret1 ret2
923+ return val
924+subsumes' val (SaturatedTypeSynonym name tyArgs) ty2 = do
925+ ty1 <- introduceSkolemScope <=< expandTypeSynonym name $ tyArgs
926+ subsumes val ty1 ty2
927+subsumes' val ty1 (SaturatedTypeSynonym name tyArgs) = do
928+ ty2 <- introduceSkolemScope <=< expandTypeSynonym name $ tyArgs
929+ subsumes val ty1 ty2
930+subsumes' (Just val) (ConstrainedType constraints ty1) ty2 = do
931+ env <- getEnv
932+ dicts <- getTypeClassDictionaries
933+ Just moduleName <- checkCurrentModule <$> get
934+ _ <- subsumes' Nothing ty1 ty2
935+ return . Just $ foldl App val (map (flip TypeClassDictionary dicts) (qualifyAllUnqualifiedNames moduleName env constraints))
936+subsumes' val (Object r1) (Object r2) = do
937+ let
938+ (ts1, r1') = rowToList r1
939+ (ts2, r2') = rowToList r2
940+ ts1' = sortBy (comparing fst) ts1
941+ ts2' = sortBy (comparing fst) ts2
942+ go ts1' ts2' r1' r2'
943+ return val
944+ where
945+ go [] ts2 r1 r2 = r1 =?= rowFromList (ts2, r2)
946+ go ts1 [] r1 r2 = r2 =?= rowFromList (ts1, r1)
947+ go ((p1, ty1) : ts1) ((p2, ty2) : ts2) r1 r2
948+ | p1 == p2 = do subsumes Nothing ty1 ty2
949+ go ts1 ts2 r1 r2
950+ | p1 < p2 = do rest <- fresh
951+ r2 =?= RCons p1 ty1 rest
952+ go ts1 ((p2, ty2) : ts2) r1 rest
953+ | p1 > p2 = do rest <- fresh
954+ r1 =?= RCons p2 ty2 rest
955+ go ((p1, ty1) : ts1) ts2 rest r2
956+subsumes' val ty1 ty2@(Object _) = subsumes val ty2 ty1
957+subsumes' val ty1 ty2 = do
958+ ty1 =?= ty2
959+ return val
960+
src/Language/PureScript/Types.hsnew file+217
@@ -0,0 +1,217 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Types
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- Data types for types
13+--
14+-----------------------------------------------------------------------------
15+
16+{-# LANGUAGE DeriveDataTypeable #-}
17+
18+module Language.PureScript.Types where
19+
20+import Data.Data
21+import Data.List (nub)
22+import Data.Generics (everything, mkT, mkQ, everywhereBut)
23+
24+import Control.Monad.Unify
25+import Control.Arrow ((***))
26+
27+import Language.PureScript.Names
28+
29+-- |
30+-- An identifier for the scope of a skolem variable
31+--
32+newtype SkolemScope = SkolemScope { runSkolemScope :: Int } deriving (Show, Eq, Ord, Data, Typeable)
33+
34+-- |
35+-- The type of types
36+--
37+data Type
38+ -- |
39+ -- A unification variable of type Type
40+ --
41+ = TUnknown Unknown
42+ -- |
43+ -- Javascript numbers
44+ --
45+ | Object Type
46+ -- |
47+ -- A named type variable
48+ --
49+ | TypeVar String
50+ -- |
51+ -- A type constructor
52+ --
53+ | TypeConstructor (Qualified ProperName)
54+ -- |
55+ -- A type application
56+ --
57+ | TypeApp Type Type
58+ -- |
59+ -- A type synonym which is \"saturated\", i.e. fully applied
60+ --
61+ | SaturatedTypeSynonym (Qualified ProperName) [Type]
62+ -- |
63+ -- Forall quantifier
64+ --
65+ | ForAll String Type (Maybe SkolemScope)
66+ -- |
67+ -- A type with a set of type class constraints
68+ --
69+ | ConstrainedType [(Qualified ProperName, Type)] Type
70+ -- |
71+ -- A skolem constant
72+ --
73+ | Skolem Int SkolemScope
74+ -- |
75+ -- An empty row
76+ --
77+ | REmpty
78+ -- |
79+ -- A non-empty row
80+ --
81+ | RCons String Type Type
82+ -- |
83+ -- A placeholder used in pretty printing
84+ --
85+ | PrettyPrintFunction Type Type
86+ -- |
87+ -- A placeholder used in pretty printing
88+ --
89+ | PrettyPrintArray Type deriving (Show, Eq, Data, Typeable)
90+
91+-- |
92+-- Type constructor for functions
93+--
94+tyFunction :: Type
95+tyFunction = TypeConstructor $ (Qualified $ Just $ ModuleName [ProperName "Prim"]) (ProperName "Function")
96+
97+-- |
98+-- Type constructor for strings
99+--
100+tyString :: Type
101+tyString = TypeConstructor $ (Qualified $ Just $ ModuleName [ProperName "Prim"]) (ProperName "String")
102+
103+-- |
104+-- Type constructor for numbers
105+--
106+tyNumber :: Type
107+tyNumber = TypeConstructor $ (Qualified $ Just $ ModuleName [ProperName "Prim"]) (ProperName "Number")
108+
109+-- |
110+-- Type constructor for booleans
111+--
112+tyBoolean :: Type
113+tyBoolean = TypeConstructor $ (Qualified $ Just $ ModuleName [ProperName "Prim"]) (ProperName "Boolean")
114+
115+-- |
116+-- Type constructor for arrays
117+--
118+tyArray :: Type
119+tyArray = TypeConstructor $ (Qualified $ Just $ ModuleName [ProperName "Prim"]) (ProperName "Array")
120+
121+-- |
122+-- Smart constructor for function types
123+--
124+function :: Type -> Type -> Type
125+function t1 t2 = TypeApp (TypeApp tyFunction t1) t2
126+
127+-- |
128+-- Convert a row to a list of pairs of labels and types
129+--
130+rowToList :: Type -> ([(String, Type)], Type)
131+rowToList (RCons name ty row) = let (tys, rest) = rowToList row
132+ in ((name, ty):tys, rest)
133+rowToList r = ([], r)
134+
135+-- |
136+-- Convert a list of labels and types to a row
137+--
138+rowFromList :: ([(String, Type)], Type) -> Type
139+rowFromList ([], r) = r
140+rowFromList ((name, t):ts, r) = RCons name t (rowFromList (ts, r))
141+
142+-- |
143+-- Check whether a type is a monotype
144+--
145+isMonoType :: Type -> Bool
146+isMonoType (ForAll _ _ _) = False
147+isMonoType ty = True
148+
149+-- |
150+-- Universally quantify a type
151+--
152+mkForAll :: [String] -> Type -> Type
153+mkForAll args ty = foldl (\t arg -> ForAll arg t Nothing) ty args
154+
155+-- |
156+-- The empty record type
157+--
158+unit :: Type
159+unit = Object REmpty
160+
161+-- |
162+-- Replace a type variable, taking into account variable shadowing
163+--
164+replaceTypeVars :: String -> Type -> Type -> Type
165+replaceTypeVars = replaceTypeVars' []
166+ where
167+ replaceTypeVars' bound name replacement = go bound
168+ where
169+ go :: [String] -> Type -> Type
170+ go bs (Object r) = Object $ go bs r
171+ go bs (TypeVar v) | v == name = replacement
172+ go bs (TypeApp t1 t2) = TypeApp (go bs t1) (go bs t2)
173+ go bs (SaturatedTypeSynonym name ts) = SaturatedTypeSynonym name $ map (go bs) ts
174+ go bs f@(ForAll v t sco) | v == name = f
175+ | v `elem` usedTypeVariables replacement =
176+ let v' = genName v (name : bs ++ usedTypeVariables replacement)
177+ t' = replaceTypeVars' bs v (TypeVar v') t
178+ in ForAll v' (go (v' : bs) t') sco
179+ | otherwise = ForAll v (go (v : bs) t) sco
180+ go bs (ConstrainedType cs t) = ConstrainedType (map (id *** go bs) cs) (go bs t)
181+ go bs (RCons name t r) = RCons name (go bs t) (go bs r)
182+ go _ ty = ty
183+ genName orig inUse = try 0
184+ where
185+ try n | (orig ++ show n) `elem` inUse = try (n + 1)
186+ | otherwise = orig ++ show n
187+
188+-- |
189+-- Collect all type variables appearing in a type
190+--
191+usedTypeVariables :: Type -> [String]
192+usedTypeVariables = nub . everything (++) (mkQ [] go)
193+ where
194+ go (TypeVar v) = [v]
195+ go _ = []
196+
197+-- |
198+-- Collect all free type variables appearing in a type
199+--
200+freeTypeVariables :: Type -> [String]
201+freeTypeVariables = nub . go []
202+ where
203+ go :: [String] -> Type -> [String]
204+ go bound (Object r) = go bound r
205+ go bound (TypeVar v) | v `notElem` bound = [v]
206+ go bound (TypeApp t1 t2) = go bound t1 ++ go bound t2
207+ go bound (SaturatedTypeSynonym _ ts) = concatMap (go bound) ts
208+ go bound (ForAll v t _) = go (v : bound) t
209+ go bound (ConstrainedType cs t) = concatMap (go bound . snd) cs ++ go bound t
210+ go bound (RCons _ t r) = go bound t ++ go bound r
211+ go _ _ = []
212+
213+-- |
214+-- Universally quantify over all type variables appearing free in a type
215+--
216+quantify :: Type -> Type
217+quantify ty = foldr (\arg t -> ForAll arg t Nothing) ty $ freeTypeVariables ty
src/Language/PureScript/Values.hsnew file+217
@@ -0,0 +1,217 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Values
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- Data types for values, statements, binders and do notation
13+--
14+-----------------------------------------------------------------------------
15+
16+{-# LANGUAGE DeriveDataTypeable #-}
17+
18+module Language.PureScript.Values where
19+
20+import Language.PureScript.Types
21+import Language.PureScript.Names
22+
23+import Data.Data
24+
25+-- |
26+-- A guard is just a boolean-valued expression that appears alongside a set of binders
27+--
28+type Guard = Value
29+
30+-- |
31+-- Data type for values
32+--
33+data Value
34+ -- |
35+ -- A numeric literal
36+ --
37+ = NumericLiteral (Either Integer Double)
38+ -- |
39+ -- A string literal
40+ --
41+ | StringLiteral String
42+ -- |
43+ -- A boolean literal
44+ --
45+ | BooleanLiteral Bool
46+ -- |
47+ -- Binary operator application. During the rebracketing phase of desugaring, this data constructor
48+ -- will be removed.
49+ --
50+ | BinaryNoParens (Qualified Ident) Value Value
51+ -- |
52+ -- Explicit parentheses. During the rebracketing phase of desugaring, this data constructor
53+ -- will be removed.
54+ --
55+ | Parens Value
56+ -- |
57+ -- An array literal
58+ --
59+ | ArrayLiteral [Value]
60+ -- |
61+ -- An object literal
62+ --
63+ | ObjectLiteral [(String, Value)]
64+ -- |
65+ -- An record property accessor expression
66+ --
67+ | Accessor String Value
68+ -- |
69+ -- Partial record update
70+ --
71+ | ObjectUpdate Value [(String, Value)]
72+ -- |
73+ -- Function introduction
74+ --
75+ | Abs Ident Value
76+ -- |
77+ -- Function application
78+ --
79+ | App Value Value
80+ -- |
81+ -- Variable
82+ --
83+ | Var (Qualified Ident)
84+ -- |
85+ -- Conditional (if-then-else expression)
86+ --
87+ | IfThenElse Value Value Value
88+ -- |
89+ -- A data constructor
90+ --
91+ | Constructor (Qualified ProperName)
92+ -- |
93+ -- A case expression. During the case expansion phase of desugaring, top-level binders will get
94+ -- desugared into case expressions, hence the need for guards and multiple binders per branch here.
95+ --
96+ | Case [Value] [([Binder], Maybe Guard, Value)]
97+ -- |
98+ -- A value with a type annotation
99+ --
100+ | TypedValue Bool Value Type
101+ -- |
102+ -- A let binding
103+ --
104+ | Let Binder Value Value
105+ -- |
106+ -- A do-notation block
107+ --
108+ | Do [DoNotationElement]
109+ -- |
110+ -- A placeholder for a type class dictionary to be inserted later. At the end of type checking, these
111+ -- placeholders will be replaced with actual expressions representing type classes dictionaries which
112+ -- can be evaluated at runtime. The constructor arguments represent (in order): the type class name and
113+ -- instance type, and the type class dictionaries in scope.
114+ --
115+ | TypeClassDictionary (Qualified ProperName, Type) [TypeClassDictionaryInScope] deriving (Show, Data, Typeable)
116+
117+-- |
118+-- The type of a type class dictionary
119+--
120+data TypeClassDictionaryType
121+ -- |
122+ -- A regular type class dictionary
123+ --
124+ = TCDRegular
125+ -- |
126+ -- A type class dictionary which is an alias for an imported dictionary from another module
127+ --
128+ | TCDAlias (Qualified Ident) deriving (Show, Eq, Data, Typeable)
129+
130+-- |
131+-- Data representing a type class dictionary which is in scope
132+--
133+data TypeClassDictionaryInScope
134+ = TypeClassDictionaryInScope {
135+ -- |
136+ -- The identifier with which the dictionary can be accessed at runtime
137+ --
138+ tcdName :: Qualified Ident
139+ -- |
140+ -- The name of the type class to which this type class instance applies
141+ --
142+ , tcdClassName :: Qualified ProperName
143+ -- |
144+ -- The type to which this type class instance applies
145+ --
146+ , tcdInstanceType :: Type
147+ -- |
148+ -- Type class dependencies which must be satisfied to construct this dictionary
149+ --
150+ , tcdDependencies :: Maybe [(Qualified ProperName, Type)]
151+ -- |
152+ -- The type of this dictionary
153+ --
154+ , tcdType :: TypeClassDictionaryType
155+ } deriving (Show, Data, Typeable)
156+
157+-- |
158+-- A statement in a do-notation block
159+--
160+data DoNotationElement
161+ -- |
162+ -- A monadic value without a binder
163+ --
164+ = DoNotationValue Value
165+ -- |
166+ -- A monadic value with a binder
167+ --
168+ | DoNotationBind Binder Value
169+ -- |
170+ -- A let statement, i.e. a pure value with a binder
171+ --
172+ | DoNotationLet Binder Value deriving (Show, Data, Typeable)
173+
174+-- |
175+-- Data type for binders
176+--
177+data Binder
178+ -- |
179+ -- Wildcard binder
180+ --
181+ = NullBinder
182+ -- |
183+ -- A binder which matches a boolean literal
184+ --
185+ | BooleanBinder Bool
186+ -- |
187+ -- A binder which matches a string literal
188+ --
189+ | StringBinder String
190+ -- |
191+ -- A binder which matches a numeric literal
192+ --
193+ | NumberBinder (Either Integer Double)
194+ -- |
195+ -- A binder which binds an identifier
196+ --
197+ | VarBinder Ident
198+ -- |
199+ -- A binder which matches a data constructor
200+ --
201+ | ConstructorBinder (Qualified ProperName) [Binder]
202+ -- |
203+ -- A binder which matches a record and binds its properties
204+ --
205+ | ObjectBinder [(String, Binder)]
206+ -- |
207+ -- A binder which matches an array and binds its elements
208+ --
209+ | ArrayBinder [Binder]
210+ -- |
211+ -- A binder which matches an array and binds its head and tail
212+ --
213+ | ConsBinder Binder Binder
214+ -- |
215+ -- A binder which binds its input to an identifier
216+ --
217+ | NamedBinder Ident Binder deriving (Show, Data, Typeable)
src/Tests.hsdeleted−141
@@ -1,141 +0,0 @@
1−module Tests (runTests) where
2−
3−import Prelude.Compat
4−import Data.List
5−import Control.Applicative
6−import Control.Monad
7−
8−import System.Process
9−import System.FilePath
10−import System.IO
11−import System.Directory
12−
13−-------------------------------------------------------------------------------
14−testsDir :: IO (FilePath, FilePath)
15−-------------------------------------------------------------------------------
16−testsDir = do
17− baseDir <- getCurrentDirectory
18− return (baseDir </> "purescript-tests", baseDir)
19−
20−-------------------------------------------------------------------------------
21−runTests :: IO ()
22−-------------------------------------------------------------------------------
23−runTests = do
24−
25− (outputDir, baseDir) <- testsDir
26−
27− outputDirExists <- doesDirectoryExist outputDir
28− when outputDirExists $ removeDirectoryRecursive outputDir
29− createDirectory outputDir
30−
31− let srcDir = outputDir </> "src"
32− createDirectory srcDir
33−
34− callProcess "git" ["clone", "--branch", "v0.13.8", "--depth", "1", "https://github.com/purescript/purescript.git"]
35− let passingDir = baseDir </> "purescript" </> "tests" </> "purs" </> "passing"
36− passingTestCases <- sort . filter (".purs" `isSuffixOf`) <$> getDirectoryContents passingDir
37−
38− setCurrentDirectory outputDir
39−
40− fetchPackages
41−
42− let tests = filter (`notElem` skipped) passingTestCases
43−
44− tmp <- getTemporaryDirectory
45− createDirectoryIfMissing False (tmp </> logpath)
46− outputFile <- openFile (tmp </> logpath </> logfile) WriteMode
47− hClose outputFile
48−
49− -- Run the tests
50− --
51− forM_ tests $ \inputFile -> do
52− --
53− -- Compile/build
54− --
55− putStrLn $ "Compiling test " ++ inputFile ++ " ..."
56− setCurrentDirectory outputDir
57− copyFile (passingDir </> inputFile) (srcDir </> inputFile)
58−
59− let testCaseDir = passingDir </> (takeWhile (/='.') inputFile)
60− testCaseDirExists <- doesDirectoryExist testCaseDir
61− when testCaseDirExists $ callProcess "cp" ["-R", testCaseDir, srcDir]
62−
63− callProcess "rm" ["-rf", "output"]
64− callProcess "rm" ["-rf", "Main"]
65− callProcess "spago" ["build"]
66− --
67− -- Run executable file
68− --
69− outputFile <- openFile (tmp </> logpath </> logfile) AppendMode
70− hPutStrLn outputFile ("\n" ++ inputFile ++ ":")
71− proc <- runProcess ("./" </> "Main") [] Nothing Nothing Nothing (Just outputFile) Nothing
72−
73− removeFile (srcDir </> inputFile)
74− when testCaseDirExists $ callProcess "rm" ["-rf", srcDir </> (takeWhile (/='.') inputFile)]
75−
76− -- TODO: support failing test cases
77− --
78− -- let failing = baseDir </> "examples" </> "failing"
79− -- failingTestCases <- sort . filter (".purs" `isSuffixOf`) <$> getDirectoryContents failing
80− --
81−
82− setCurrentDirectory baseDir
83− putStrLn "PureScript tests finished"
84− putStrLn $ "Total tests available: " ++ show (length passingTestCases)
85− putStrLn $ "Tests run: " ++ show (length tests)
86− putStrLn $ "Tests skipped: " ++ show (length skipped)
87−
88−-------------------------------------------------------------------------------
89−packages :: [String]
90−-------------------------------------------------------------------------------
91−packages =
92− [ "arrays"
93− , "assert"
94− , "console"
95− , "control"
96− , "effect"
97− , "foldable-traversable"
98− , "functions"
99− , "generics-rep"
100− , "invariant"
101− , "newtype"
102− , "partial"
103− , "prelude"
104− , "proxy"
105− , "refs"
106− , "st"
107− , "type-equality"
108− , "typelevel-prelude"
109− ]
110−
111−-------------------------------------------------------------------------------
112−fetchPackages :: IO ()
113−-------------------------------------------------------------------------------
114−fetchPackages = do
115− callProcess "spago" ["init"]
116− callCommand "sed '$s/\\(}\\)/, backend = \"psgo\"\\1/' < spago.dhall | dhall format > spago.tmp"
117− callCommand "mv spago.tmp spago.dhall"
118−
119− mapM (callProcess "spago" . (\p -> ["install", p])) packages
120− return ()
121−
122−-------------------------------------------------------------------------------
123−skipped :: [String]
124−-------------------------------------------------------------------------------
125−skipped =
126− [ "2172.purs" -- foreign in Main needed (test manually)
127− , "EffFn.purs" -- foreign in Main needed (test manually)
128− , "FunWithFunDeps.purs" -- foreign in Main needed (test manually)
129− , "NumberLiterals.purs" -- unreliable float string comparison (test manually)
130− , "PolyLabels.purs" -- foreign in Main needed (test manually)
131− , "RowUnion.purs" -- foreign in Main needed (test manually)
132− , "ShadowedModuleName.purs" -- ?
133− , "StringEdgeCases.purs" -- javascript char encoding specific
134− , "StringEscapes.purs" -- Partially javascript-char-encoding-specific (test manually)
135− ]
136−
137−logpath :: FilePath
138−logpath = "purescript-output"
139−
140−logfile :: FilePath
141−logfile = "purescript-tests.out"
stack.nixdeleted−23
@@ -1,23 +0,0 @@
1−#
2−# You may need to manually run `unset STACK_IN_NIX_SHELL`
3−# (doesn't work from a `shellHook`; see: https://github.com/commercialhaskell/stack/issues/5000
4−#
5−#
6−# You may need to set LC_ALL when building, e.g.
7−# LC_ALL=en_US.iso88591 stack --nix build; see e.g. https://github.com/koalaman/shellcheck/issues/324
8−#
9−#
10−{ pkgs ?
11− import (builtins.fetchTarball {
12− name = "nixos-release-19.03";
13− url = https://github.com/nixos/nixpkgs/archive/34c7eb7545d155cc5b6f499b23a7cb1c96ab4d59.tar.gz;
14− sha256 = "11z6ajj108fy2q5g8y4higlcaqncrbjm3dnv17pvif6avagw4mcb";
15− }) {}
16−}:
17−
18−pkgs.haskell.lib.buildStackProject {
19− name = "default-stack-shell";
20− ghc = pkgs.haskell.compiler.ghc865;
21− buildInputs = with pkgs; [git git-lfs gmp ncurses zlib];
22− LANG = "en_US.UTF-8";
23−}
stack.yamldeleted−24
@@ -1,24 +0,0 @@
1−resolver: lts-13.26
2−
3−packages:
4−- .
5−
6−extra-deps:
7−- git: https://github.com/purescript/purescript
8− commit: 9cad73ed8ea7df3011032ddbd2f3de5a0c08629c
9−- happy-1.19.9
10−- language-javascript-0.7.0.0
11−- network-3.0.1.1
12−- these-1.0.1
13−- semialign-1
14−
15−nix:
16− enable: false
17− shell-file: stack.nix
18−
19−flags:
20− aeson-pretty:
21− lib-only: true
22− these:
23− assoc: false
24− quickcheck: false
support/ffi-loader.godeleted−30
@@ -1,30 +0,0 @@
1−package ffi_loader
2−
3−// Load PureScript standard library FFI packages. Comment out the ones you don't need for
4−// faster/smaller builds.
5−
6−import (
7− _ "github.com/purescript-native/go-ffi/purescript-arrays"
8− _ "github.com/purescript-native/go-ffi/purescript-assert"
9− _ "github.com/purescript-native/go-ffi/purescript-console"
10− _ "github.com/purescript-native/go-ffi/purescript-effect"
11− _ "github.com/purescript-native/go-ffi/purescript-enums"
12− _ "github.com/purescript-native/go-ffi/purescript-exceptions"
13− _ "github.com/purescript-native/go-ffi/purescript-foldable-traversable"
14− _ "github.com/purescript-native/go-ffi/purescript-functions"
15− _ "github.com/purescript-native/go-ffi/purescript-globals"
16− _ "github.com/purescript-native/go-ffi/purescript-integers"
17− _ "github.com/purescript-native/go-ffi/purescript-lazy"
18− _ "github.com/purescript-native/go-ffi/purescript-math"
19− _ "github.com/purescript-native/go-ffi/purescript-partial"
20− _ "github.com/purescript-native/go-ffi/purescript-prelude"
21− _ "github.com/purescript-native/go-ffi/purescript-random"
22− _ "github.com/purescript-native/go-ffi/purescript-refs"
23− _ "github.com/purescript-native/go-ffi/purescript-st"
24− _ "github.com/purescript-native/go-ffi/purescript-strings"
25− _ "github.com/purescript-native/go-ffi/purescript-unfoldable"
26−)
27−
28−// Add your own FFI packages here.
29−
30−import ()
support/go.mod.ffi-loaderdeleted−2
@@ -1,2 +0,0 @@
1−module $PROJECT/purescript-native/ffi-loader
2−
support/go.mod.outputdeleted−2
@@ -1,2 +0,0 @@
1−module $PROJECT/purescript-native/output
2−
support/go.mod.workingdeleted−1
@@ -1 +0,0 @@
1−module $PROJECT/example
test/Spec.hsdeleted−2
@@ -1,2 +0,0 @@
1−main :: IO ()
2−main = putStrLn "Test suite not yet implemented"
tests/Main.hsnew file+106
@@ -0,0 +1,106 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Main
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+{-# LANGUAGE DoAndIfThenElse #-}
16+
17+module Main (main) where
18+
19+import qualified Language.PureScript as P
20+
21+import Data.List (isSuffixOf)
22+import Data.Traversable (traverse)
23+import Control.Applicative
24+import Control.Monad
25+import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
26+import System.Exit
27+import System.Process
28+import System.FilePath (pathSeparator)
29+import System.Directory (getCurrentDirectory, getDirectoryContents, findExecutable)
30+import System.Environment (getArgs)
31+import Text.Parsec (ParseError)
32+import qualified Paths_purescript as Paths
33+import qualified System.IO.UTF8 as U
34+import qualified Data.Map as M
35+
36+preludeFilename :: IO FilePath
37+preludeFilename = Paths.getDataFileName "prelude/prelude.purs"
38+
39+readInput :: [FilePath] -> IO (Either ParseError [P.Module])
40+readInput inputFiles = fmap (fmap concat . sequence) $ forM inputFiles $ \inputFile -> do
41+ text <- U.readFile inputFile
42+ return $ P.runIndentParser inputFile P.parseModules text
43+
44+compile :: P.Options -> [FilePath] -> IO (Either String String)
45+compile opts inputFiles = do
46+ modules <- readInput inputFiles
47+ case modules of
48+ Left parseError -> do
49+ return (Left $ show parseError)
50+ Right ms -> do
51+ case P.compile opts ms of
52+ Left typeError -> do
53+ return (Left typeError)
54+ Right (js, _, _) -> do
55+ return (Right js)
56+
57+assert :: P.Options -> [FilePath] -> (Either String String -> IO (Maybe String)) -> IO ()
58+assert opts inputFiles f = do
59+ e <- compile opts inputFiles
60+ maybeErr <- f e
61+ case maybeErr of
62+ Just err -> putStrLn err >> exitFailure
63+ Nothing -> return ()
64+
65+assertCompiles :: FilePath -> IO ()
66+assertCompiles inputFile = do
67+ putStrLn $ "assert " ++ inputFile ++ " compiles successfully"
68+ prelude <- preludeFilename
69+ assert (P.defaultOptions { P.optionsMain = Just "Main", P.optionsNoOptimizations = True, P.optionsModules = ["Main"] }) [prelude, inputFile] $ either (return . Just) $ \js -> do
70+ args <- getArgs
71+ if "--run-js" `elem` args
72+ then do
73+ process <- findNodeProcess
74+ result <- traverse (\node -> readProcessWithExitCode node [] js) process
75+ case result of
76+ Just (ExitSuccess, out, _) -> putStrLn out >> return Nothing
77+ Just (ExitFailure _, _, err) -> return $ Just err
78+ Nothing -> return $ Just "Couldn't find node.js executable"
79+ else return Nothing
80+
81+findNodeProcess :: IO (Maybe String)
82+findNodeProcess = runMaybeT . msum $ map (MaybeT . findExecutable) names
83+ where names = ["nodejs", "node"]
84+
85+assertDoesNotCompile :: FilePath -> IO ()
86+assertDoesNotCompile inputFile = do
87+ putStrLn $ "assert " ++ inputFile ++ " does not compile"
88+ assert P.defaultOptions [inputFile] $ \e ->
89+ case e of
90+ Left _ -> return Nothing
91+ Right _ -> return $ Just "Should not have compiled"
92+
93+main :: IO ()
94+main = do
95+ cd <- getCurrentDirectory
96+ putStrLn $ cd
97+ let examples = cd ++ pathSeparator : "examples"
98+ let passing = examples ++ pathSeparator : "passing"
99+ passingTestCases <- getDirectoryContents passing
100+ forM_ passingTestCases $ \inputFile -> when (".purs" `isSuffixOf` inputFile) $
101+ assertCompiles (passing ++ pathSeparator : inputFile)
102+ let failing = examples ++ pathSeparator : "failing"
103+ failingTestCases <- getDirectoryContents failing
104+ forM_ failingTestCases $ \inputFile -> when (".purs" `isSuffixOf` inputFile) $
105+ assertDoesNotCompile (failing ++ pathSeparator : inputFile)
106+ exitSuccess