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