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