├── .gitignore ├── Gruntfile.js ├── LICENSE ├── README.md ├── bower.json ├── js ├── psc-docs.js ├── psc-make.js ├── psc.js └── psci.js ├── package.json ├── prelude ├── Control │ └── Monad │ │ ├── Eff.purs │ │ ├── Eff │ │ └── Unsafe.purs │ │ └── ST.purs ├── Data │ ├── Eq.purs │ └── Function.purs ├── Debug │ └── Trace.purs ├── Prelude.purs └── Prelude │ └── Unsafe.purs ├── runtime └── REPL.purs ├── src ├── Compiler.purs ├── Control │ └── Monad │ │ ├── Application.purs │ │ ├── Eff │ │ ├── FS.purs │ │ └── Process.purs │ │ ├── Error │ │ └── Proxy.purs │ │ └── Unify.purs ├── Data │ ├── List.purs │ └── Tuple3.purs ├── DocGen.purs ├── Interactive.purs ├── Language │ ├── PureScript.purs │ └── PureScript │ │ ├── CodeGen │ │ ├── Common.purs │ │ ├── Externs.purs │ │ ├── JS.purs │ │ └── JS │ │ │ └── AST.purs │ │ ├── Constants.purs │ │ ├── Declarations.purs │ │ ├── Environment.purs │ │ ├── Errors.purs │ │ ├── Keywords.purs │ │ ├── Kinds.purs │ │ ├── ModuleDependencies.purs │ │ ├── Names.purs │ │ ├── Optimizer.purs │ │ ├── Optimizer │ │ ├── Blocks.purs │ │ ├── Common.purs │ │ ├── Inliner.purs │ │ ├── MagicDo.purs │ │ ├── TCO.purs │ │ └── Unused.purs │ │ ├── Options.purs │ │ ├── Parser │ │ ├── Common.purs │ │ ├── Declarations.purs │ │ ├── Kinds.purs │ │ ├── Lexer.purs │ │ └── Types.purs │ │ ├── Pos.purs │ │ ├── Prelude.purs │ │ ├── Pretty │ │ ├── Common.purs │ │ ├── JS.purs │ │ ├── Kinds.purs │ │ ├── Types.purs │ │ └── Values.purs │ │ ├── Sugar.purs │ │ ├── Sugar │ │ ├── BindingGroups.purs │ │ ├── CaseDeclarations.purs │ │ ├── DoNotation.purs │ │ ├── Names.purs │ │ ├── Operators.purs │ │ ├── TypeClasses.purs │ │ └── TypeDeclarations.purs │ │ ├── Supply.purs │ │ ├── Traversals.purs │ │ ├── TypeChecker.purs │ │ ├── TypeChecker │ │ ├── Kinds.purs │ │ ├── Monad.purs │ │ ├── Synonyms.purs │ │ └── Types.purs │ │ ├── TypeClassDictionaries.purs │ │ └── Types.purs └── Make.purs └── tests ├── Numbers.purs └── TestSimple.purs /.gitignore: -------------------------------------------------------------------------------- 1 | /.* 2 | !/.gitignore 3 | /bower_components/ 4 | /node_modules/ 5 | /output/ 6 | /dist/ 7 | -------------------------------------------------------------------------------- /Gruntfile.js: -------------------------------------------------------------------------------- 1 | module.exports = function(grunt) { 2 | 3 | "use strict"; 4 | 5 | grunt.initConfig({ 6 | 7 | libFiles: [ 8 | "src/**/*.purs", 9 | "bower_components/purescript-*/src/**/*.purs*" 10 | ], 11 | 12 | watch: { 13 | lib: { 14 | files: ["<%=libFiles%>"], 15 | tasks: ["pscMake"] 16 | } 17 | }, 18 | 19 | clean: ["output", "dist"], 20 | 21 | pscMake: ["<%=libFiles%>"], 22 | dotPsci: ["<%=libFiles%>"], 23 | 24 | copy: [ 25 | { 26 | expand: true, 27 | cwd: "output", 28 | src: "**", 29 | dest: "dist/node_modules/" 30 | }, 31 | { 32 | expand: true, 33 | cwd: "js", 34 | src: "**", 35 | dest: "dist/" 36 | } 37 | ], 38 | 39 | execute: { 40 | psc: { 41 | src: "dist/psc.js" 42 | } 43 | } 44 | 45 | }); 46 | 47 | grunt.loadNpmTasks("grunt-contrib-clean"); 48 | grunt.loadNpmTasks("grunt-contrib-copy"); 49 | grunt.loadNpmTasks('grunt-contrib-watch'); 50 | grunt.loadNpmTasks('grunt-execute'); 51 | grunt.loadNpmTasks("grunt-purescript"); 52 | 53 | grunt.registerTask("make", ["pscMake", "dotPsci", "copy"]); 54 | grunt.registerTask("psc", ["make", "execute:psc"]); 55 | grunt.registerTask("default", ["make"]); 56 | }; 57 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2014 PureScript 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 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, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | purescript-in-purescript 2 | ======================== 3 | 4 | PureScript compiler written in PureScript 5 | -------------------------------------------------------------------------------- /bower.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "purescript-in-purescript", 3 | "dependencies": { 4 | "purescript-arrows": "~0.1.1", 5 | "purescript-node-readline": "~0.1.1", 6 | "purescript-refs": "~0.1.1", 7 | "purescript-node-args": "~0.2.0", 8 | "purescript-maps": "~0.0.7", 9 | "purescript-transformers": "~0.2.1", 10 | "purescript-pattern-arrows": "~0.1.0", 11 | "purescript-parsing": "~0.1.1", 12 | "purescript-globals": "~0.1.5", 13 | "purescript-node-path": "~0.2.0", 14 | "purescript-node-fs": "~0.1.2", 15 | "purescript-control": "~0.2.1", 16 | "purescript-strings": "~0.4.0" 17 | } 18 | } 19 | -------------------------------------------------------------------------------- /js/psc-docs.js: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env node 2 | require("DocGen").main(); 3 | -------------------------------------------------------------------------------- /js/psc-make.js: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env node 2 | require("Make").main(); 3 | -------------------------------------------------------------------------------- /js/psc.js: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env node 2 | require("Compiler").main(); 3 | -------------------------------------------------------------------------------- /js/psci.js: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env node 2 | require("Interactive").main(); 3 | -------------------------------------------------------------------------------- /package.json: -------------------------------------------------------------------------------- 1 | { 2 | "private": true, 3 | "name": "purescript", 4 | "version": "0.0.0", 5 | "files": [ 6 | "dist", 7 | "prelude", 8 | "runtime" 9 | ], 10 | "bin": { 11 | "psc2": "dist/psc.js", 12 | "psci2": "dist/psci.js", 13 | "psc-make2": "dist/psc-make.js", 14 | "psc-docs": "dist/psc-docs.js" 15 | }, 16 | "preferGlobal": true, 17 | "devDependencies": { 18 | "grunt": "~0.4.4", 19 | "grunt-contrib-clean": "~0.5.0", 20 | "grunt-contrib-copy": "~0.5.0", 21 | "grunt-contrib-watch": "~0.6.1", 22 | "grunt-execute": "~0.2.1", 23 | "grunt-purescript": "~0.5.1" 24 | }, 25 | "dependencies": { 26 | "mkdirp": "^0.5.0" 27 | } 28 | } 29 | -------------------------------------------------------------------------------- /prelude/Control/Monad/Eff.purs: -------------------------------------------------------------------------------- 1 | module Control.Monad.Eff where 2 | 3 | foreign import data Eff :: # ! -> * -> * 4 | 5 | foreign import returnE "function returnE(a) {\ 6 | \ return function() {\ 7 | \ return a;\ 8 | \ };\ 9 | \}" :: forall e a. a -> Eff e a 10 | 11 | foreign import bindE "function bindE(a) {\ 12 | \ return function(f) {\ 13 | \ return function() {\ 14 | \ return f(a())();\ 15 | \ };\ 16 | \ };\ 17 | \}" :: forall e a b. Eff e a -> (a -> Eff e b) -> Eff e b 18 | 19 | type Pure a = forall e. Eff e a 20 | 21 | foreign import runPure "function runPure(f) {\ 22 | \ return f();\ 23 | \}" :: forall a. Pure a -> a 24 | 25 | instance functorEff :: Functor (Eff e) where 26 | (<$>) = liftA1 27 | 28 | instance applyEff :: Apply (Eff e) where 29 | (<*>) = ap 30 | 31 | instance applicativeEff :: Applicative (Eff e) where 32 | pure = returnE 33 | 34 | instance bindEff :: Bind (Eff e) where 35 | (>>=) = bindE 36 | 37 | instance monadEff :: Monad (Eff e) 38 | 39 | foreign import untilE "function untilE(f) {\ 40 | \ return function() {\ 41 | \ while (!f()) { }\ 42 | \ return {};\ 43 | \ };\ 44 | \}" :: forall e. Eff e Boolean -> Eff e Unit 45 | 46 | foreign import whileE "function whileE(f) {\ 47 | \ return function(a) {\ 48 | \ return function() {\ 49 | \ while (f()) {\ 50 | \ a();\ 51 | \ }\ 52 | \ return {};\ 53 | \ };\ 54 | \ };\ 55 | \}" :: forall e a. Eff e Boolean -> Eff e a -> Eff e Unit 56 | 57 | foreign import forE "function forE(lo) {\ 58 | \ return function(hi) {\ 59 | \ return function(f) {\ 60 | \ return function() {\ 61 | \ for (var i = lo; i < hi; i++) {\ 62 | \ f(i)();\ 63 | \ }\ 64 | \ };\ 65 | \ };\ 66 | \ };\ 67 | \}" :: forall e. Number -> Number -> (Number -> Eff e Unit) -> Eff e Unit 68 | 69 | 70 | foreign import foreachE "function foreachE(as) {\ 71 | \ return function(f) {\ 72 | \ for (var i = 0; i < as.length; i++) {\ 73 | \ f(as[i])();\ 74 | \ }\ 75 | \ };\ 76 | \}" :: forall e a. [a] -> (a -> Eff e Unit) -> Eff e Unit 77 | -------------------------------------------------------------------------------- /prelude/Control/Monad/Eff/Unsafe.purs: -------------------------------------------------------------------------------- 1 | module Control.Monad.Eff.Unsafe where 2 | 3 | import Control.Monad.Eff 4 | 5 | foreign import unsafeInterleaveEff 6 | "function unsafeInterleaveEff(f) {\ 7 | \ return f;\ 8 | \}" :: forall eff1 eff2 a. Eff eff1 a -> Eff eff2 a 9 | -------------------------------------------------------------------------------- /prelude/Control/Monad/ST.purs: -------------------------------------------------------------------------------- 1 | module Control.Monad.ST where 2 | 3 | import Control.Monad.Eff 4 | 5 | foreign import data ST :: * -> ! 6 | 7 | foreign import data STRef :: * -> * -> * 8 | 9 | foreign import data STArray :: * -> * -> * 10 | 11 | foreign import newSTRef "function newSTRef(val) {\ 12 | \ return function () {\ 13 | \ return { value: val };\ 14 | \ };\ 15 | \}" :: forall a h r. a -> Eff (st :: ST h | r) (STRef h a) 16 | 17 | foreign import readSTRef "function readSTRef(ref) {\ 18 | \ return function() {\ 19 | \ return ref.value;\ 20 | \ };\ 21 | \}" :: forall a h r. STRef h a -> Eff (st :: ST h | r) a 22 | 23 | foreign import modifySTRef "function modifySTRef(ref) {\ 24 | \ return function(f) {\ 25 | \ return function() {\ 26 | \ return ref.value = f(ref.value);\ 27 | \ };\ 28 | \ };\ 29 | \}" :: forall a h r. STRef h a -> (a -> a) -> Eff (st :: ST h | r) a 30 | 31 | foreign import writeSTRef "function writeSTRef(ref) {\ 32 | \ return function(a) {\ 33 | \ return function() {\ 34 | \ return ref.value = a;\ 35 | \ };\ 36 | \ };\ 37 | \}" :: forall a h r. STRef h a -> a -> Eff (st :: ST h | r) a 38 | 39 | foreign import newSTArray "function newSTArray(len) {\ 40 | \ return function(a) {\ 41 | \ return function() {\ 42 | \ var arr = [];\ 43 | \ for (var i = 0; i < len; i++) {\ 44 | \ arr[i] = a;\ 45 | \ };\ 46 | \ return arr;\ 47 | \ };\ 48 | \ };\ 49 | \}" :: forall a h r. Number -> a -> Eff (st :: ST h | r) (STArray h a) 50 | 51 | foreign import peekSTArray "function peekSTArray(arr) {\ 52 | \ return function(i) {\ 53 | \ return function() {\ 54 | \ return arr[i];\ 55 | \ };\ 56 | \ };\ 57 | \}" :: forall a h r. STArray h a -> Eff (st :: ST h | r) a 58 | 59 | foreign import pokeSTArray "function pokeSTArray(arr) {\ 60 | \ return function(i) {\ 61 | \ return function(a) {\ 62 | \ return function() {\ 63 | \ return arr[i] = a;\ 64 | \ };\ 65 | \ };\ 66 | \ };\ 67 | \}" :: forall a h r. STArray h a -> Number -> a -> Eff (st :: ST h | r) a 68 | 69 | foreign import runST "function runST(f) {\ 70 | \ return f;\ 71 | \}" :: forall a r. (forall h. Eff (st :: ST h | r) a) -> Eff r a 72 | 73 | foreign import runSTArray "function runSTArray(f) {\ 74 | \ return f;\ 75 | \}" :: forall a r. (forall h. Eff (st :: ST h | r) (STArray h a)) -> Eff r [a] 76 | -------------------------------------------------------------------------------- /prelude/Data/Eq.purs: -------------------------------------------------------------------------------- 1 | module Data.Eq where 2 | 3 | data Ref a = Ref a 4 | 5 | liftRef :: forall a b. (a -> a -> b) -> Ref a -> Ref a -> b 6 | liftRef f (Ref x) (Ref y) = f x y 7 | 8 | instance eqRef :: Eq (Ref a) where 9 | (==) = liftRef refEq 10 | (/=) = liftRef refIneq 11 | -------------------------------------------------------------------------------- /prelude/Data/Function.purs: -------------------------------------------------------------------------------- 1 | module Data.Function where 2 | 3 | on :: forall a b c. (b -> b -> c) -> (a -> b) -> a -> a -> c 4 | on f g x y = g x `f` g y 5 | 6 | foreign import data Fn0 :: * -> * 7 | foreign import data Fn1 :: * -> * -> * 8 | foreign import data Fn2 :: * -> * -> * -> * 9 | foreign import data Fn3 :: * -> * -> * -> * -> * 10 | foreign import data Fn4 :: * -> * -> * -> * -> * -> * 11 | foreign import data Fn5 :: * -> * -> * -> * -> * -> * -> * 12 | 13 | foreign import mkFn0 14 | "function mkFn0(f) {\ 15 | \ return function() {\ 16 | \ return f({});\ 17 | \ };\ 18 | \}" :: forall a. (Unit -> a) -> Fn0 a 19 | 20 | foreign import mkFn1 21 | "function mkFn1(f) {\ 22 | \ return function(a) {\ 23 | \ return f(a);\ 24 | \ };\ 25 | \}" :: forall a b. (a -> b) -> Fn1 a b 26 | 27 | foreign import mkFn2 28 | "function mkFn2(f) {\ 29 | \ return function(a, b) {\ 30 | \ return f(a)(b);\ 31 | \ };\ 32 | \}" :: forall a b c. (a -> b -> c) -> Fn2 a b c 33 | 34 | foreign import mkFn3 35 | "function mkFn3(f) {\ 36 | \ return function(a, b, c) {\ 37 | \ return f(a)(b)(c);\ 38 | \ };\ 39 | \}" :: forall a b c d. (a -> b -> c -> d) -> Fn3 a b c d 40 | 41 | foreign import mkFn4 42 | "function mkFn4(f) {\ 43 | \ return function(a, b, c, d) {\ 44 | \ return f(a)(b)(c)(d);\ 45 | \ };\ 46 | \}" :: forall a b c d e. (a -> b -> c -> d -> e) -> Fn4 a b c d e 47 | 48 | foreign import mkFn5 49 | "function mkFn5(f) {\ 50 | \ return function(a, b, c, d, e) {\ 51 | \ return f(a)(b)(c)(d)(e);\ 52 | \ };\ 53 | \}" :: forall a b c d e f. (a -> b -> c -> d -> e -> f) -> Fn5 a b c d e f 54 | 55 | foreign import runFn0 56 | "function runFn0(f) {\ 57 | \ return f();\ 58 | \}" :: forall a. Fn0 a -> a 59 | 60 | foreign import runFn1 61 | "function runFn1(f) {\ 62 | \ return function(a) {\ 63 | \ return f(a);\ 64 | \ };\ 65 | \}" :: forall a b. Fn1 a b -> a -> b 66 | 67 | foreign import runFn2 68 | "function runFn2(f) {\ 69 | \ return function(a) {\ 70 | \ return function(b) {\ 71 | \ return f(a, b);\ 72 | \ };\ 73 | \ };\ 74 | \}" :: forall a b c. Fn2 a b c -> a -> b -> c 75 | 76 | foreign import runFn3 77 | "function runFn3(f) {\ 78 | \ return function(a) {\ 79 | \ return function(b) {\ 80 | \ return function(c) {\ 81 | \ return f(a, b, c);\ 82 | \ };\ 83 | \ };\ 84 | \ };\ 85 | \}" :: forall a b c d. Fn3 a b c d -> a -> b -> c -> d 86 | 87 | foreign import runFn4 88 | "function runFn4(f) {\ 89 | \ return function(a) {\ 90 | \ return function(b) {\ 91 | \ return function(c) {\ 92 | \ return function(d) {\ 93 | \ return f(a, b, c, d);\ 94 | \ };\ 95 | \ };\ 96 | \ };\ 97 | \ };\ 98 | \}" :: forall a b c d e. Fn4 a b c d e -> a -> b -> c -> d -> e 99 | 100 | foreign import runFn5 101 | "function runFn5(f) {\ 102 | \ return function(a) {\ 103 | \ return function(b) {\ 104 | \ return function(c) {\ 105 | \ return function(d) {\ 106 | \ return function(e) {\ 107 | \ return f(a, b, c, d, e);\ 108 | \ };\ 109 | \ };\ 110 | \ };\ 111 | \ };\ 112 | \ };\ 113 | \}" :: forall a b c d e f. Fn5 a b c d e f -> a -> b -> c -> d -> e -> f 114 | -------------------------------------------------------------------------------- /prelude/Debug/Trace.purs: -------------------------------------------------------------------------------- 1 | module Debug.Trace where 2 | 3 | import Control.Monad.Eff 4 | 5 | foreign import data Trace :: ! 6 | 7 | foreign import trace "function trace(s) {\ 8 | \ return function() {\ 9 | \ console.log(s);\ 10 | \ return {};\ 11 | \ };\ 12 | \}" :: forall r. String -> Eff (trace :: Trace | r) Unit 13 | 14 | print :: forall a r. (Show a) => a -> Eff (trace :: Trace | r) Unit 15 | print o = trace (show o) 16 | -------------------------------------------------------------------------------- /prelude/Prelude/Unsafe.purs: -------------------------------------------------------------------------------- 1 | module Prelude.Unsafe where 2 | 3 | foreign import unsafeIndex 4 | "function unsafeIndex(xs) {\ 5 | \ return function(n) {\ 6 | \ return xs[n];\ 7 | \ };\ 8 | \}" :: forall a. [a] -> Number -> a 9 | -------------------------------------------------------------------------------- /runtime/REPL.purs: -------------------------------------------------------------------------------- 1 | module REPL where 2 | 3 | import Debug.Trace 4 | 5 | import Control.Monad.Eff 6 | import Control.Monad.Eff.Unsafe 7 | 8 | class EvalPrint a where 9 | evalPrint :: a -> Eff (trace :: Trace) Unit 10 | 11 | instance evalPrintEff :: (Show a) => EvalPrint (Eff eff a) where 12 | evalPrint e = do 13 | a <- unsafeInterleaveEff e 14 | print a 15 | 16 | instance evalPrintOther :: (Show a) => EvalPrint a where 17 | evalPrint = print 18 | -------------------------------------------------------------------------------- /src/Compiler.purs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- 3 | -- Module : Compiler 4 | -- Copyright : (c) Phil Freeman 2013-14 5 | -- License : MIT 6 | -- 7 | -- Maintainer : Phil Freeman 8 | -- Stability : experimental 9 | -- Portability : 10 | -- 11 | -- | psc frontend to the PureScript library 12 | -- 13 | ----------------------------------------------------------------------------- 14 | 15 | module Compiler where 16 | 17 | import Debug.Trace 18 | 19 | import Data.Maybe 20 | import Data.Tuple 21 | import Data.Tuple3 22 | import Data.Array (concat, map) 23 | import Data.Either 24 | 25 | import Data.Traversable (for) 26 | 27 | import Control.Monad.Eff 28 | import Control.Monad.Eff.Unsafe 29 | import Control.Monad.Eff.Process 30 | import Control.Monad.Eff.FS 31 | 32 | import Control.Alt 33 | import Control.Alternative 34 | import Control.Apply 35 | import Control.Monad.Application 36 | import Control.Monad.Trans 37 | import Control.Monad.Identity 38 | import Control.Monad.State.Class 39 | import Control.Monad.Error.Trans 40 | import Control.Monad.Error.Class 41 | import Control.Monad.Cont.Trans 42 | 43 | import Node.Args 44 | import Node.FS 45 | import Node.Path 46 | 47 | import Language.PureScript 48 | import Language.PureScript.Declarations 49 | import Language.PureScript.Options 50 | import Language.PureScript.Prelude 51 | 52 | import qualified Language.PureScript.Parser.Lexer as P 53 | import qualified Language.PureScript.Parser.Common as P 54 | import qualified Language.PureScript.Parser.Declarations as P 55 | 56 | moduleFromText :: String -> Either String Module 57 | moduleFromText text = do 58 | tokens <- P.lex text 59 | P.runTokenParser P.parseModule tokens 60 | 61 | readInput :: forall eff. [String] -> Application [Module] 62 | readInput input = 63 | for input (\inputFile -> do 64 | text <- readFileApplication inputFile 65 | case moduleFromText text of 66 | Left err -> throwError err 67 | Right m -> return m) 68 | 69 | runCompiler :: forall eff. Options -> [String] -> Maybe String -> Maybe String -> Eff (fs :: FS, trace :: Trace, process :: Process | eff) Unit 70 | runCompiler opts@(Options optso) input output externs = runApplication do 71 | modules <- readInput allInputFiles 72 | Tuple3 js exts _ <- eitherApplication $ compile opts modules 73 | case output of 74 | Nothing -> effApplication (trace js) 75 | Just path -> do 76 | mkdirpApplication (dirname path) 77 | writeFileApplication path js 78 | for externs $ \path -> writeFileApplication path exts 79 | return unit 80 | where 81 | allInputFiles :: [String] 82 | allInputFiles | optso.noPrelude = input 83 | allInputFiles = preludeFiles ++ input 84 | 85 | flag :: String -> String -> Args Boolean 86 | flag shortForm longForm = maybe false (const true) <$> opt (flagOnly shortForm <|> flagOnly longForm) 87 | 88 | inputFiles :: Args [String] 89 | inputFiles = many argOnly 90 | 91 | outputFile :: Args (Maybe String) 92 | outputFile = opt (flagArg "o" <|> flagArg "output") 93 | 94 | externsFile :: Args (Maybe String) 95 | externsFile = opt (flagArg "e" <|> flagArg "externs") 96 | 97 | noTco :: Args Boolean 98 | noTco = flagOpt "no-tco" 99 | 100 | performRuntimeTypeChecks :: Args Boolean 101 | performRuntimeTypeChecks = flagOpt "runtime-type-checks" 102 | 103 | noPrelude :: Args Boolean 104 | noPrelude = flagOpt "no-prelude" 105 | 106 | noMagicDo :: Args Boolean 107 | noMagicDo = flagOpt "no-magic-do" 108 | 109 | runMain :: Args (Maybe String) 110 | runMain = opt (flagArg "main") 111 | 112 | noOpts :: Args Boolean 113 | noOpts = flagOpt "no-opts" 114 | 115 | browserNamespace :: Args String 116 | browserNamespace = flagArg "browser-namespace" <|> pure "PS" 117 | 118 | dceModules :: Args [String] 119 | dceModules = many (flagArg "m" <|> flagArg "module") 120 | 121 | codeGenModules :: Args [String] 122 | codeGenModules = many (flagArg "codegen") 123 | 124 | verboseErrors :: Args Boolean 125 | verboseErrors = flag "v" "verbose-errors" 126 | 127 | options :: Args Options 128 | options = mkOptions <$> noPrelude 129 | <*> noTco 130 | <*> performRuntimeTypeChecks 131 | <*> noMagicDo 132 | <*> runMain 133 | <*> noOpts 134 | <*> (Just <$> browserNamespace) 135 | <*> dceModules 136 | <*> codeGenModules 137 | <*> verboseErrors 138 | 139 | term :: Args (Eff (fs :: FS, trace :: Trace, process :: Process) Unit) 140 | term = runCompiler <$> options <*> inputFiles <*> outputFile <*> externsFile 141 | 142 | main = do 143 | result <- readArgs' term 144 | case result of 145 | Left err -> print err 146 | _ -> return unit 147 | 148 | -------------------------------------------------------------------------------- /src/Control/Monad/Application.purs: -------------------------------------------------------------------------------- 1 | module Control.Monad.Application where 2 | 3 | import Data.Either 4 | import Data.Maybe 5 | 6 | import Control.Monad.Trans 7 | import Control.Monad.Error 8 | import Control.Monad.Error.Class 9 | import Control.Monad.Error.Trans 10 | import Control.Monad.Eff 11 | import Control.Monad.Eff.Exception 12 | import Control.Monad.Eff.FS 13 | import Control.Monad.Eff.Process 14 | 15 | import Node.FS 16 | import Node.Path 17 | 18 | import Debug.Trace 19 | 20 | import Language.PureScript 21 | 22 | data Application a = Application (forall eff. ErrorT String (Eff (fs :: FS, trace :: Trace, process :: Process | eff)) a) 23 | 24 | unApplication :: forall eff a. Application a -> ErrorT String (Eff (fs :: FS, trace :: Trace, process :: Process | eff)) a 25 | unApplication (Application m) = m 26 | 27 | instance functorApplication :: Functor Application where 28 | (<$>) f (Application m) = Application (f <$> m) 29 | 30 | instance applyApplication :: Apply Application where 31 | (<*>) (Application f) (Application x) = Application (f <*> x) 32 | 33 | instance applicativeApplication :: Applicative Application where 34 | pure a = Application (pure a) 35 | 36 | instance bindApplication :: Bind Application where 37 | (>>=) (Application m) f = Application (m >>= (unApplication <<< f)) 38 | 39 | instance monadApplication :: Monad Application 40 | 41 | instance monadErrorApplication :: MonadError String Application where 42 | throwError e = Application (throwError e) 43 | catchError (Application e) f = Application (catchError e (unApplication <<< f)) 44 | 45 | instance monadMakeApp :: MonadMake Application where 46 | getTimestamp path = do 47 | exists <- doesFileExistApplication path 48 | case exists of 49 | true -> Just <$> getModificationTimeApplication path 50 | false -> return Nothing 51 | readTextFile path = do 52 | effApplication (trace $ "Reading " ++ path) 53 | readFileApplication path 54 | writeTextFile path text = do 55 | mkdirpApplication (dirname path) 56 | effApplication (trace $ "Writing " ++ path) 57 | writeFileApplication path text 58 | liftError = eitherApplication 59 | progress msg = effApplication (trace msg) 60 | 61 | runApplication :: forall eff a. Application a -> Eff (fs :: FS, trace :: Trace, process :: Process | eff) Unit 62 | runApplication (Application app) = do 63 | result <- runErrorT app 64 | case result of 65 | Left err -> do 66 | trace err 67 | exit 1 68 | Right _ -> exit 0 69 | 70 | runApplication' :: forall eff a. Application a -> Eff (fs :: FS, trace :: Trace, process :: Process | eff) (Either String a) 71 | runApplication' (Application app) = runErrorT app 72 | 73 | fsAction :: forall a. (forall eff r. (a -> r) -> (Error -> r) -> Eff (fs :: FS | eff) r) -> Application a 74 | fsAction k = Application (ErrorT (k Right (Left <<< show))) 75 | 76 | readFileApplication :: String -> Application String 77 | readFileApplication filename = fsAction (readFile filename) 78 | 79 | writeFileApplication :: String -> String -> Application Unit 80 | writeFileApplication filename text = fsAction (writeFile filename text) 81 | 82 | doesFileExistApplication :: String -> Application Boolean 83 | doesFileExistApplication filename = fsAction (doesFileExist filename) 84 | 85 | getModificationTimeApplication :: String -> Application Number 86 | getModificationTimeApplication filename = fsAction (getModificationTime filename) 87 | 88 | mkdirpApplication :: String -> Application Unit 89 | mkdirpApplication filename = fsAction (mkdirp filename) 90 | 91 | eitherApplication :: forall a. Either String a -> Application a 92 | eitherApplication e = Application (ErrorT (return e)) 93 | 94 | effApplication :: forall a. (forall eff. Eff (fs :: FS, trace :: Trace, process :: Process | eff) a) -> Application a 95 | effApplication a = Application (lift a) 96 | -------------------------------------------------------------------------------- /src/Control/Monad/Eff/FS.purs: -------------------------------------------------------------------------------- 1 | module Control.Monad.Eff.FS where 2 | 3 | import Data.Date 4 | import Data.Either 5 | 6 | import Control.Monad.Eff 7 | import Control.Monad.Eff.Exception 8 | 9 | import qualified Control.Monad.Eff.Unsafe as U 10 | 11 | import Node.Encoding 12 | import Node.FS 13 | import Node.FS.Stats 14 | import Node.FS.Sync (readTextFile, writeTextFile, stat) 15 | import Node.Path 16 | 17 | liftFSAction :: forall eff r. Eff (fs :: FS, err :: Exception | eff) r -> Eff (fs :: FS | eff) (Either Error r) 18 | liftFSAction fs = U.unsafeInterleaveEff (catchException (return <<< Left) $ Right <$> fs) 19 | 20 | readFile :: forall eff r. FilePath -> (String -> r) -> (Error -> r) -> Eff (fs :: FS | eff) r 21 | readFile path f g = either g f <$> (liftFSAction $ readTextFile UTF8 path) 22 | 23 | writeFile :: forall eff r. FilePath -> String -> (Unit -> r) -> (Error -> r) -> Eff (fs :: FS | eff) r 24 | writeFile path content f g = either g f <$> (liftFSAction $ writeTextFile UTF8 path content) 25 | 26 | doesFileExist :: forall eff r. FilePath -> (Boolean -> r) -> (Error -> r) -> Eff (fs :: FS | eff) r 27 | doesFileExist path f g = either (f <<< const false) (f <<< const true) <$> (liftFSAction $ stat path) 28 | 29 | getModificationTime :: forall eff r. FilePath -> (Number -> r) -> (Error -> r) -> Eff (fs :: FS | eff) r 30 | getModificationTime path f g = either g (f <<< toEpochMilliseconds <<< modifiedTime) <$> (liftFSAction $ stat path) 31 | 32 | foreign import mkdirp 33 | "function mkdirp(filename) {\ 34 | \ return function(k) {\ 35 | \ return function(fail) {\ 36 | \ return function() {\ 37 | \ try {\ 38 | \ return k(require('mkdirp').sync(filename));\ 39 | \ } catch(err) {\ 40 | \ return fail(err);\ 41 | \ }\ 42 | \ };\ 43 | \ };\ 44 | \ };\ 45 | \}" :: forall eff r. FilePath -> (Unit -> r) -> (Error -> r) -> Eff (fs :: FS | eff) r 46 | -------------------------------------------------------------------------------- /src/Control/Monad/Eff/Process.purs: -------------------------------------------------------------------------------- 1 | module Control.Monad.Eff.Process where 2 | 3 | import Control.Monad.Eff 4 | 5 | foreign import data Process :: ! 6 | 7 | foreign import exit 8 | "function exit(code) {\ 9 | \ return function() {\ 10 | \ process.exit(code);\ 11 | \ };\ 12 | \}" :: forall eff. Number -> Eff (process :: Process | eff) Unit -------------------------------------------------------------------------------- /src/Control/Monad/Error/Proxy.purs: -------------------------------------------------------------------------------- 1 | module Control.Monad.Error.Proxy where 2 | 3 | -- 4 | -- A proxy for the type variable a 5 | -- 6 | data WithErrorType e = WithErrorType 7 | 8 | withErrorType :: forall e. WithErrorType e -> e -> e 9 | withErrorType _ e = e -------------------------------------------------------------------------------- /src/Control/Monad/Unify.purs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- 3 | -- Module : Control.Monad.Unify 4 | -- Copyright : (c) Phil Freeman 2013 5 | -- License : MIT 6 | -- 7 | -- Maintainer : Phil Freeman 8 | -- Stability : experimental 9 | -- Portability : 10 | -- 11 | -- | 12 | -- 13 | -- 14 | ----------------------------------------------------------------------------- 15 | 16 | module Control.Monad.Unify where 17 | 18 | import Data.Either 19 | import Data.Foldable 20 | import Data.Maybe 21 | import Data.Monoid 22 | import Data.Tuple 23 | 24 | import Control.Monad.Trans 25 | import Control.Monad.State 26 | import Control.Monad.State.Trans 27 | import Control.Monad.State.Class 28 | import Control.Monad.Error 29 | import Control.Monad.Error.Class 30 | import Control.Monad.Error.Proxy 31 | 32 | -- | 33 | -- Untyped unification variables 34 | -- 35 | type Unknown = Number 36 | 37 | -- | 38 | -- A type which can contain unification variables 39 | -- 40 | class Partial t where 41 | unknown :: Unknown -> t 42 | isUnknown :: t -> Maybe Unknown 43 | unknowns :: t -> [Unknown] 44 | ($?) :: Substitution t -> t -> t 45 | 46 | -- | 47 | -- Identifies types which support unification 48 | -- 49 | class (Partial t) <= Unifiable m t where 50 | (=?=) :: t -> t -> UnifyT t m Unit 51 | 52 | -- | 53 | -- A substitution maintains a mapping from unification variables to their values 54 | -- 55 | data Substitution t = Substitution (Data.Map.Map Unknown t) 56 | 57 | runSubstitution :: forall t. Substitution t -> Data.Map.Map Number t 58 | runSubstitution (Substitution m) = m 59 | 60 | 61 | instance semigroupSubstitution :: (Partial t) => Semigroup (Substitution t) where 62 | (<>) s1 s2 = Substitution $ 63 | Data.Map.map (($?) s2) (runSubstitution s1) `Data.Map.union` 64 | Data.Map.map (($?) s1) (runSubstitution s2) 65 | 66 | instance monoidSubstitution :: (Partial t) => Monoid (Substitution t) where 67 | mempty = Substitution Data.Map.empty 68 | 69 | -- | 70 | -- State required for type checking 71 | -- 72 | data UnifyState t = UnifyState (UnifyStateObj t) 73 | 74 | type UnifyStateObj t = { 75 | -- | 76 | -- The next fresh unification variable 77 | -- 78 | nextVar :: Unknown 79 | -- | 80 | -- The current substitution 81 | -- 82 | , currentSubstitution :: Substitution t 83 | } 84 | 85 | unifyStateObj :: forall t. UnifyState t -> UnifyStateObj t 86 | unifyStateObj (UnifyState o) = o 87 | 88 | -- | 89 | -- An empty @UnifyState@ 90 | -- 91 | defaultUnifyState :: forall t. (Partial t) => UnifyState t 92 | defaultUnifyState = UnifyState { nextVar: 0, currentSubstitution: mempty } 93 | 94 | -- | 95 | -- The type checking monad, which provides the state of the type checker, and error reporting capabilities 96 | -- 97 | data UnifyT t m a = UnifyT (StateT (UnifyState t) m a) 98 | 99 | unUnifyT :: forall t m a. UnifyT t m a -> StateT (UnifyState t) m a 100 | unUnifyT (UnifyT s) = s 101 | 102 | instance functorUnify :: (Monad m) => Functor (UnifyT t m) where 103 | (<$>) = liftA1 104 | 105 | instance applyUnify :: (Monad m) => Apply (UnifyT t m) where 106 | (<*>) = ap 107 | 108 | instance applicativeUnify :: (Monad m) => Applicative (UnifyT t m) where 109 | pure = UnifyT <<< pure 110 | 111 | instance bindUnify :: (Monad m) => Bind (UnifyT t m) where 112 | (>>=) (UnifyT x) f = UnifyT (x >>= unUnifyT <<< f) 113 | 114 | instance monadUnify :: (Monad m) => Monad (UnifyT t m) 115 | 116 | instance monadErrorUnify :: (Monad m, MonadError e m) => MonadError e (UnifyT t m) where 117 | throwError = UnifyT <<< throwError 118 | catchError e f = UnifyT $ catchError (unUnifyT e) (unUnifyT <<< f) 119 | 120 | instance monadStateUnify :: (Monad m, MonadState s m) => MonadState s (UnifyT t m) where 121 | state f = UnifyT (lift (state f)) 122 | 123 | instance monadStateUnifyState :: (Monad m) => MonadState (UnifyState t) (UnifyT t m) where 124 | state = UnifyT <<< state 125 | 126 | -- | 127 | -- Run a computation in the Unify monad, failing with an error, or succeeding with a return value and the new next unification variable 128 | -- 129 | runUnify :: forall t m a. (Monad m) => UnifyState t -> UnifyT t m a -> m (Tuple a (UnifyState t)) 130 | runUnify s = flip runStateT s <<< unUnifyT 131 | 132 | -- | 133 | -- Substitute a single unification variable 134 | -- 135 | substituteOne :: forall t. (Partial t) => Unknown -> t -> Substitution t 136 | substituteOne u t = Substitution $ Data.Map.singleton u t 137 | 138 | -- | 139 | -- Replace a unification variable with the specified value in the current substitution 140 | -- 141 | substitute :: forall e m t. (Error e, Monad m, MonadError e m, Partial t, Unifiable m t) => WithErrorType e -> Unknown -> t -> UnifyT t m Unit 142 | substitute errorType u t' = do 143 | UnifyState st <- get 144 | let sub = st.currentSubstitution 145 | let t = sub $? t' 146 | occursCheck errorType u t 147 | let current = sub $? unknown u 148 | case isUnknown current of 149 | Just u1 | u1 == u -> return unit 150 | _ -> current =?= t 151 | modify $ \(UnifyState s) -> UnifyState { nextVar: st.nextVar, currentSubstitution: substituteOne u t <> s.currentSubstitution } 152 | 153 | -- | 154 | -- This type exists to get around a type error caused by the lack of functional dependencies 155 | -- 156 | data Proxy e = Proxy 157 | 158 | -- | 159 | -- Perform the occurs check, to make sure a unification variable does not occur inside a value 160 | -- 161 | occursCheck :: forall e m t. (Error e, Monad m, MonadError e m, Partial t) => WithErrorType e -> Unknown -> t -> UnifyT t m Unit 162 | occursCheck errorType u t = 163 | case isUnknown t of 164 | Nothing | u `elem` unknowns t -> UnifyT $ lift $ throwError $ withErrorType errorType $ strMsg $ "Occurs check fails" 165 | _ -> return unit 166 | 167 | -- | 168 | -- Generate a fresh untyped unification variable 169 | -- 170 | fresh' :: forall m t. (Monad m) => UnifyT t m Unknown 171 | fresh' = do 172 | UnifyState st <- getState 173 | put $ UnifyState 174 | { nextVar: st.nextVar + 1 175 | , currentSubstitution: st.currentSubstitution 176 | } 177 | return st.nextVar 178 | where 179 | getState :: forall m t. (Monad m) => UnifyT t m (UnifyState t) 180 | getState = get 181 | 182 | -- | 183 | -- Generate a fresh unification variable at a specific type 184 | -- 185 | fresh :: forall m t. (Monad m, Partial t) => UnifyT t m t 186 | fresh = do 187 | u <- fresh' 188 | return $ unknown u 189 | -------------------------------------------------------------------------------- /src/Data/List.purs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- 3 | -- Module : Data.List 4 | -- Copyright : (c) Phil Freeman 2014 5 | -- License : MIT 6 | -- 7 | -- Maintainer : Phil Freeman 8 | -- Stability : experimental 9 | -- Portability : 10 | -- 11 | -- | 12 | -- Enumerators for singly-linked lists 13 | -- 14 | ----------------------------------------------------------------------------- 15 | 16 | module Data.List where 17 | 18 | data List a = Nil | Cons a (Unit -> List a) 19 | 20 | instance functorList :: Functor List where 21 | (<$>) _ Nil = Nil 22 | (<$>) f (Cons h t) = Cons (f h) $ \_ -> f <$> t unit 23 | 24 | filter :: forall a. (a -> Boolean) -> List a -> List a 25 | filter _ Nil = Nil 26 | filter f (Cons h t) | f h = Cons h $ \_ -> filter f (t unit) 27 | filter f (Cons h t) = filter f (t unit) 28 | 29 | enumFrom :: Number -> List Number 30 | enumFrom n = Cons n $ \_ -> enumFrom (n + 1) 31 | 32 | fromArray :: forall a. [a] -> List a 33 | fromArray [] = Nil 34 | fromArray (h : t) = Cons h $ \_ -> fromArray t 35 | 36 | toArray :: forall a. List a -> [a] 37 | toArray Nil = [] 38 | toArray (Cons h t) = h : toArray (t unit) 39 | 40 | (\\) :: forall a. (Eq a) => List a -> [a] -> List a 41 | (\\) l arr = filter (\a -> not (a `elem` arr)) l 42 | where 43 | elem :: forall a. (Eq a) => a -> [a] -> Boolean 44 | elem _ [] = false 45 | elem a (h : _) | a == h = true 46 | elem a (_ : t) = elem a t 47 | 48 | take :: forall a. Number -> List a -> List a 49 | take _ Nil = Nil 50 | take 0 _ = Nil 51 | take n (Cons h t) = Cons h $ \_ -> take (n - 1) (t unit) -------------------------------------------------------------------------------- /src/Data/Tuple3.purs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- 3 | -- Module : Data.Tuple3 4 | -- Copyright : (c) 2014 Phil Freeman 5 | -- License : MIT 6 | -- 7 | -- Maintainer : Phil Freeman 8 | -- Stability : experimental 9 | -- Portability : 10 | -- 11 | -- | A tuple with three values 12 | -- 13 | ----------------------------------------------------------------------------- 14 | 15 | module Data.Tuple3 where 16 | 17 | data Tuple3 a b c = Tuple3 a b c 18 | 19 | instance showTuple3 :: (Show a, Show b, Show c) => Show (Tuple3 a b c) where 20 | show (Tuple3 a b c) = "Tuple3 (" ++ show a ++ ") (" ++ show b ++ ") (" ++ show c ++ ")" 21 | 22 | instance eqTuple3 :: (Eq a, Eq b, Eq c) => Eq (Tuple3 a b c) where 23 | (==) (Tuple3 a1 b1 c1) (Tuple3 a2 b2 c2) = (a1 == a2) && (b1 == b2) && (c1 == c2) 24 | (/=) (Tuple3 a1 b1 c1) (Tuple3 a2 b2 c2) = (a1 /= a2) || (b1 /= b2) || (c1 /= c2) -------------------------------------------------------------------------------- /src/DocGen.purs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- 3 | -- Module : Main 4 | -- Copyright : (c) Phil Freeman 2013-14 5 | -- License : MIT 6 | -- 7 | -- Maintainer : Phil Freeman 8 | -- Stability : experimental 9 | -- Portability : 10 | -- 11 | -- | Generates Markdown documentation from PureScript source files. 12 | -- 13 | ----------------------------------------------------------------------------- 14 | 15 | module DocGen where 16 | 17 | import Data.Maybe 18 | import Data.Array 19 | import Data.Tuple 20 | import Data.Either 21 | import Data.String (joinWith, split) 22 | import Data.Function (on) 23 | import Data.Foldable 24 | import Data.Traversable 25 | 26 | import qualified Language.PureScript.Types as P 27 | import qualified Language.PureScript.Names as P 28 | import qualified Language.PureScript.Errors as P 29 | import qualified Language.PureScript.Environment as P 30 | import qualified Language.PureScript.Declarations as P 31 | import qualified Language.PureScript.Pretty.Types as P 32 | import qualified Language.PureScript.Pretty.Kinds as P 33 | 34 | import qualified Language.PureScript.Parser.Lexer as Parser 35 | import qualified Language.PureScript.Parser.Common as Parser 36 | import qualified Language.PureScript.Parser.Declarations as Parser 37 | 38 | import Debug.Trace 39 | 40 | import Control.Alt 41 | import Control.Alternative 42 | import Control.Apply 43 | import Control.Monad 44 | import Control.Monad.Eff 45 | import Control.Monad.Eff.Ref 46 | import Control.Monad.Eff.Process 47 | import Control.Monad.Eff.FS 48 | import Control.Monad.Application 49 | 50 | import Control.Monad.Writer 51 | import Control.Monad.Writer.Class 52 | 53 | import Control.Monad.Error.Class 54 | 55 | import Node.Args 56 | import Node.FS 57 | 58 | docgen :: [String] -> Maybe String -> Eff (fs :: FS, trace :: Trace, process :: Process) Unit 59 | docgen input output = runApplication do 60 | ms <- readInput input 61 | let docs = runDocs $ renderModules ms 62 | case output of 63 | Nothing -> effApplication (trace docs) 64 | Just filename -> writeFileApplication filename docs 65 | effApplication (exit 0) 66 | 67 | moduleFromText :: String -> Either String P.Module 68 | moduleFromText text = do 69 | tokens <- Parser.lex text 70 | Parser.runTokenParser Parser.parseModule tokens 71 | 72 | readInput :: forall eff. [String] -> Application [P.Module] 73 | readInput input = 74 | for input (\inputFile -> do 75 | text <- readFileApplication inputFile 76 | case moduleFromText text of 77 | Left err -> throwError err 78 | Right m -> return m) 79 | 80 | type Docs = Writer [String] Unit 81 | 82 | runDocs :: Docs -> String 83 | runDocs = joinWith "\n" <<< execWriter 84 | 85 | spacer :: Docs 86 | spacer = tell [""] 87 | 88 | replicate :: Number -> String -> String 89 | replicate n s = go n "" 90 | where 91 | go 0 acc = acc 92 | go n acc = go (n - 1) (acc ++ s) 93 | 94 | headerLevel :: Number -> String -> Docs 95 | headerLevel level hdr = tell [replicate level "#" ++ " " ++ hdr] 96 | 97 | atIndent :: Number -> String -> Docs 98 | atIndent indent text = 99 | let ls = split "\n" text in 100 | for_ ls $ \l -> tell [replicate indent " " ++ l] 101 | 102 | renderModules :: [P.Module] -> Docs 103 | renderModules ms = do 104 | headerLevel 1 "Module Documentation" 105 | spacer 106 | traverse_ renderModule ms 107 | 108 | renderModule :: P.Module -> Docs 109 | renderModule (P.Module moduleName ds exps) = 110 | let exported = filter (isExported exps) ds 111 | hasTypes = any isTypeDeclaration ds 112 | hasTypeclasses = any isTypeClassDeclaration ds 113 | hasTypeclassInstances = any isTypeInstanceDeclaration ds 114 | hasValues = any isValueDeclaration ds 115 | in do 116 | headerLevel 2 $ "Module " ++ P.runModuleName moduleName 117 | spacer 118 | when hasTypes $ do 119 | headerLevel 3 "Types" 120 | spacer 121 | renderTopLevel exps (filter isTypeDeclaration exported) 122 | spacer 123 | when hasTypeclasses $ do 124 | headerLevel 3 "Type Classes" 125 | spacer 126 | renderTopLevel exps (filter isTypeClassDeclaration exported) 127 | spacer 128 | when hasTypeclassInstances $ do 129 | headerLevel 3 "Type Class Instances" 130 | spacer 131 | renderTopLevel exps (filter isTypeInstanceDeclaration ds) 132 | spacer 133 | when hasValues $ do 134 | headerLevel 3 "Values" 135 | spacer 136 | renderTopLevel exps (filter isValueDeclaration exported) 137 | spacer 138 | 139 | isExported :: Maybe [P.DeclarationRef] -> P.Declaration -> Boolean 140 | isExported Nothing _ = true 141 | isExported _ (P.TypeInstanceDeclaration _ _ _ _ _) = true 142 | isExported exps (P.PositionedDeclaration _ d) = isExported exps d 143 | isExported (Just exps) decl = any (matches decl) exps 144 | where 145 | matches (P.TypeDeclaration ident _) (P.ValueRef ident') = ident == ident' 146 | matches (P.ExternDeclaration _ ident _ _) (P.ValueRef ident') = ident == ident' 147 | matches (P.DataDeclaration ident _ _) (P.TypeRef ident' _) = ident == ident' 148 | matches (P.ExternDataDeclaration ident _) (P.TypeRef ident' _) = ident == ident' 149 | matches (P.TypeSynonymDeclaration ident _ _) (P.TypeRef ident' _) = ident == ident' 150 | matches (P.TypeClassDeclaration ident _ _ _) (P.TypeClassRef ident') = ident == ident' 151 | matches (P.PositionedDeclaration _ d) r = d `matches` r 152 | matches d (P.PositionedDeclarationRef _ r) = d `matches` r 153 | matches _ _ = false 154 | 155 | isDctorExported :: P.ProperName -> Maybe [P.DeclarationRef] -> P.ProperName -> Boolean 156 | isDctorExported _ Nothing _ = true 157 | isDctorExported ident (Just exps) ctor = test `any` exps 158 | where 159 | test (P.PositionedDeclarationRef _ d) = test d 160 | test (P.TypeRef ident' Nothing) = ident == ident' 161 | test (P.TypeRef ident' (Just ctors)) = ident == ident' && ctor `elem` ctors 162 | test _ = false 163 | 164 | renderTopLevel :: Maybe [P.DeclarationRef] -> [P.Declaration] -> Docs 165 | renderTopLevel exps decls = for_ (sortBy (compare `on` getName) decls) $ \decl -> do 166 | renderDeclaration 4 exps decl 167 | spacer 168 | 169 | renderDeclaration :: Number -> Maybe [P.DeclarationRef] -> P.Declaration -> Docs 170 | renderDeclaration n _ (P.TypeDeclaration ident ty) = 171 | atIndent n $ show ident ++ " :: " ++ prettyPrintType' ty 172 | renderDeclaration n _ (P.ExternDeclaration _ ident _ ty) = 173 | atIndent n $ show ident ++ " :: " ++ prettyPrintType' ty 174 | renderDeclaration n exps (P.DataDeclaration name args ctors) = do 175 | let typeName = P.runProperName name ++ (if null args then "" else " " ++ joinWith " " args) 176 | let exported = filter (isDctorExported name exps <<< fst) ctors 177 | atIndent n $ "data " ++ typeName ++ (if null exported then "" else " where") 178 | for_ exported $ \(Tuple ctor tys) -> 179 | atIndent (n + 2) $ P.runProperName ctor ++ " :: " ++ joinWith "" (map (\ty -> prettyPrintType' ty ++ " -> ") tys) ++ typeName 180 | renderDeclaration n _ (P.ExternDataDeclaration name kind) = 181 | atIndent n $ "data " ++ P.runProperName name ++ " :: " ++ P.prettyPrintKind kind 182 | renderDeclaration n _ (P.TypeSynonymDeclaration name args ty) = do 183 | let typeName = P.runProperName name ++ " " ++ joinWith " " args 184 | atIndent n $ "type " ++ typeName ++ " = " ++ prettyPrintType' ty 185 | renderDeclaration n exps (P.TypeClassDeclaration name args implies ds) = do 186 | let impliesText = case implies of 187 | [] -> "" 188 | is -> "(" ++ joinWith ", " (map (\(Tuple pn tys') -> show pn ++ " " ++ joinWith " " (map P.prettyPrintTypeAtom tys')) is) ++ ") <= " 189 | atIndent n $ "class " ++ impliesText ++ P.runProperName name ++ " " ++ joinWith " " args ++ " where" 190 | traverse_ (renderDeclaration (n + 2) exps) ds 191 | renderDeclaration n _ (P.TypeInstanceDeclaration name constraints className tys _) = do 192 | let constraintsText = case constraints of 193 | [] -> "" 194 | cs -> "(" ++ joinWith ", " (map (\(Tuple pn tys') -> show pn ++ " " ++ joinWith " " (map P.prettyPrintTypeAtom tys')) cs) ++ ") => " 195 | atIndent n $ "instance " ++ show name ++ " :: " ++ constraintsText ++ show className ++ " " ++ joinWith " " (map P.prettyPrintTypeAtom tys) 196 | renderDeclaration n exps (P.PositionedDeclaration _ d) = 197 | renderDeclaration n exps d 198 | renderDeclaration _ _ _ = return unit 199 | 200 | prettyPrintType' :: P.Type -> String 201 | prettyPrintType' = P.prettyPrintType <<< P.everywhereOnTypes dePrim 202 | where 203 | dePrim ty@(P.TypeConstructor (P.Qualified _ name)) 204 | | ty == P.tyBoolean || ty == P.tyNumber || ty == P.tyString = 205 | P.TypeConstructor $ P.Qualified Nothing name 206 | dePrim other = other 207 | 208 | getName :: P.Declaration -> String 209 | getName (P.TypeDeclaration ident _) = show ident 210 | getName (P.ExternDeclaration _ ident _ _) = show ident 211 | getName (P.DataDeclaration name _ _) = P.runProperName name 212 | getName (P.ExternDataDeclaration name _) = P.runProperName name 213 | getName (P.TypeSynonymDeclaration name _ _) = P.runProperName name 214 | getName (P.TypeClassDeclaration name _ _ _) = P.runProperName name 215 | getName (P.TypeInstanceDeclaration name _ _ _ _) = show name 216 | getName (P.PositionedDeclaration _ d) = getName d 217 | getName _ = P.theImpossibleHappened "Invalid argument to getName" 218 | 219 | isValueDeclaration :: P.Declaration -> Boolean 220 | isValueDeclaration (P.TypeDeclaration _ _) = true 221 | isValueDeclaration (P.ExternDeclaration _ _ _ _) = true 222 | isValueDeclaration (P.PositionedDeclaration _ d) = isValueDeclaration d 223 | isValueDeclaration _ = false 224 | 225 | isTypeDeclaration :: P.Declaration -> Boolean 226 | isTypeDeclaration (P.DataDeclaration _ _ _) = true 227 | isTypeDeclaration (P.ExternDataDeclaration _ _) = true 228 | isTypeDeclaration (P.TypeSynonymDeclaration _ _ _) = true 229 | isTypeDeclaration (P.PositionedDeclaration _ d) = isTypeDeclaration d 230 | isTypeDeclaration _ = false 231 | 232 | isTypeClassDeclaration :: P.Declaration -> Boolean 233 | isTypeClassDeclaration (P.TypeClassDeclaration _ _ _ _) = true 234 | isTypeClassDeclaration (P.PositionedDeclaration _ d) = isTypeClassDeclaration d 235 | isTypeClassDeclaration _ = false 236 | 237 | isTypeInstanceDeclaration :: P.Declaration -> Boolean 238 | isTypeInstanceDeclaration (P.TypeInstanceDeclaration _ _ _ _ _) = true 239 | isTypeInstanceDeclaration (P.PositionedDeclaration _ d) = isTypeInstanceDeclaration d 240 | isTypeInstanceDeclaration _ = false 241 | 242 | inputFiles :: Args [String] 243 | inputFiles = many argOnly 244 | 245 | outputFile :: Args (Maybe String) 246 | outputFile = opt (flagArg "o" <|> flagArg "output") 247 | 248 | term :: Args (Eff (fs :: FS, trace :: Trace, process :: Process) Unit) 249 | term = docgen <$> inputFiles <*> outputFile 250 | 251 | main = do 252 | result <- readArgs' term 253 | case result of 254 | Left err -> print err 255 | _ -> return unit 256 | 257 | -------------------------------------------------------------------------------- /src/Language/PureScript/CodeGen/Common.purs: -------------------------------------------------------------------------------- 1 | module Language.PureScript.CodeGen.Common where 2 | 3 | import Data.Array (concatMap, map) 4 | import Data.Foldable (all, elem, foldMap) 5 | import Data.Monoid () 6 | import Data.String (charCodeAt, joinWith, split) 7 | import Data.String.Regex (Regex(..), regex, test, parseFlags) 8 | import Language.PureScript.Names 9 | 10 | -- | 11 | -- Convert an Ident into a valid Javascript identifier: 12 | -- 13 | -- * Alphanumeric characters are kept unmodified. 14 | -- 15 | -- * Reserved javascript identifiers are prefixed with '$$'. 16 | -- 17 | -- * Symbols are prefixed with '$' followed by a symbol name or their ordinal value. 18 | -- 19 | identToJs :: Ident -> String 20 | identToJs (Ident name) | nameIsJsReserved name = "$$" ++ name 21 | identToJs (Ident name) = foldMap identCharToString (split "" name) 22 | identToJs (Op op) = foldMap identCharToString (split "" op) 23 | 24 | -- | 25 | -- Attempts to find a human-readable name for a symbol, if none has been specified returns the 26 | -- ordinal value. 27 | -- 28 | identCharToString :: String -> String 29 | identCharToString c | test rxAlphaNum c = c 30 | identCharToString "_" = "_" 31 | identCharToString "." = "$dot" 32 | identCharToString "$" = "$dollar" 33 | identCharToString "~" = "$tilde" 34 | identCharToString "=" = "$eq" 35 | identCharToString "<" = "$less" 36 | identCharToString ">" = "$greater" 37 | identCharToString "!" = "$bang" 38 | identCharToString "#" = "$hash" 39 | identCharToString "%" = "$percent" 40 | identCharToString "^" = "$up" 41 | identCharToString "&" = "$amp" 42 | identCharToString "|" = "$bar" 43 | identCharToString "*" = "$times" 44 | identCharToString "/" = "$div" 45 | identCharToString "+" = "$plus" 46 | identCharToString "-" = "$minus" 47 | identCharToString ":" = "$colon" 48 | identCharToString "\\" = "$bslash" 49 | identCharToString "?" = "$qmark" 50 | identCharToString "@" = "$at" 51 | identCharToString "\'" = "$prime" 52 | identCharToString c = "$" ++ show (charCodeAt 0 c) 53 | 54 | -- | 55 | -- Checks whether an identifier name is reserved in Javascript. 56 | -- 57 | nameIsJsReserved :: String -> Boolean 58 | nameIsJsReserved name = 59 | name `elem` [ "abstract" 60 | , "arguments" 61 | , "boolean" 62 | , "break" 63 | , "byte" 64 | , "case" 65 | , "catch" 66 | , "char" 67 | , "class" 68 | , "const" 69 | , "continue" 70 | , "debugger" 71 | , "default" 72 | , "delete" 73 | , "do" 74 | , "double" 75 | , "else" 76 | , "enum" 77 | , "eval" 78 | , "export" 79 | , "extends" 80 | , "final" 81 | , "finally" 82 | , "float" 83 | , "for" 84 | , "function" 85 | , "goto" 86 | , "if" 87 | , "implements" 88 | , "import" 89 | , "in" 90 | , "instanceof" 91 | , "int" 92 | , "interface" 93 | , "let" 94 | , "long" 95 | , "native" 96 | , "new" 97 | , "null" 98 | , "package" 99 | , "private" 100 | , "protected" 101 | , "public" 102 | , "return" 103 | , "short" 104 | , "static" 105 | , "super" 106 | , "switch" 107 | , "synchronized" 108 | , "this" 109 | , "throw" 110 | , "throws" 111 | , "transient" 112 | , "try" 113 | , "typeof" 114 | , "var" 115 | , "void" 116 | , "volatile" 117 | , "while" 118 | , "with" 119 | , "yield" ] 120 | 121 | -- | 122 | -- Test if a string is a valid JS identifier (may return false negatives) 123 | -- 124 | isIdent :: String -> Boolean 125 | isIdent = test rxIdent 126 | 127 | moduleNameToJs :: ModuleName -> String 128 | moduleNameToJs (ModuleName pns) = joinWith "_" (runProperName `map` pns) 129 | 130 | rxAlphaNum :: Regex 131 | rxAlphaNum = regex "[a-z0-9]" (parseFlags "i") 132 | 133 | rxIdent :: Regex 134 | rxIdent = regex "^[a-z][a-z0-9]*$" (parseFlags "i") 135 | -------------------------------------------------------------------------------- /src/Language/PureScript/CodeGen/Externs.purs: -------------------------------------------------------------------------------- 1 | module Language.PureScript.CodeGen.Externs (moduleToPs) where 2 | 3 | import Control.Monad.Identity 4 | import Control.Monad.Writer 5 | import Control.Monad.Writer.Trans 6 | import Control.Monad.Writer.Class 7 | 8 | import Data.Array (filter, map, mapMaybe, null) 9 | import Data.Maybe (Maybe(..), fromMaybe) 10 | import Data.Foldable (elem, find, for_, traverse_, lookup) 11 | import Data.Monoid 12 | import Data.String (joinWith) 13 | import Data.Tuple 14 | import Data.Tuple3 15 | 16 | import qualified Data.Map as M 17 | 18 | import Language.PureScript.Declarations 19 | import Language.PureScript.Environment 20 | import Language.PureScript.Errors (theImpossibleHappened) 21 | import Language.PureScript.Names 22 | import Language.PureScript.Pretty.Kinds 23 | import Language.PureScript.Pretty.Types 24 | import Language.PureScript.TypeClassDictionaries 25 | 26 | -- | 27 | -- Generate foreign imports for all declarations in a module 28 | -- 29 | moduleToPs :: Module -> Environment -> String 30 | moduleToPs (Module _ _ Nothing) _ = theImpossibleHappened "Module exports were not elaborated in moduleToPs" 31 | moduleToPs (Module moduleName ds (Just exts)) (Environment env) = joinWith "\n" <<< execWriter $ do 32 | tell [ "module " ++ runModuleName moduleName ++ " where"] 33 | traverse_ declToPs ds 34 | traverse_ exportToPs exts 35 | where 36 | 37 | declToPs :: Declaration -> Writer [String] Unit 38 | declToPs (ImportDeclaration mn _ _) = tell ["import " ++ show mn ++ " ()"] 39 | declToPs (FixityDeclaration (Fixity assoc prec) ident) = 40 | tell [ joinWith " " [ show assoc, show prec, ident ] ] 41 | declToPs (PositionedDeclaration _ d) = declToPs d 42 | declToPs _ = return unit 43 | 44 | exportToPs :: DeclarationRef -> Writer [String] Unit 45 | exportToPs (PositionedDeclarationRef _ r) = exportToPs r 46 | exportToPs (TypeRef pn dctors) = 47 | case Qualified (Just moduleName) pn `M.lookup` env.types of 48 | Nothing -> theImpossibleHappened $ show pn ++ " has no kind in exportToPs" 49 | Just (Tuple kind ExternData) -> 50 | tell ["foreign import data " ++ show pn ++ " :: " ++ prettyPrintKind kind] 51 | Just (Tuple _ (DataType args tys)) -> do 52 | let dctors' = fromMaybe (map fst tys) dctors 53 | printDctor dctor = case dctor `lookup` tys of 54 | Nothing -> Nothing 55 | Just tyArgs -> Just $ show dctor ++ " " ++ joinWith " " (map prettyPrintTypeAtom tyArgs) 56 | tell ["data " ++ show pn ++ " " ++ joinWith " " args ++ (if null dctors' then "" else " = " ++ joinWith " | " (mapMaybe printDctor dctors'))] 57 | Just (Tuple _ TypeSynonym) -> 58 | case Qualified (Just moduleName) pn `M.lookup` env.typeSynonyms of 59 | Nothing -> theImpossibleHappened $ show pn ++ " has no type synonym info in exportToPs" 60 | Just (Tuple args synTy) -> 61 | tell ["type " ++ show pn ++ " " ++ joinWith " " args ++ " = " ++ prettyPrintType synTy] 62 | _ -> theImpossibleHappened "Invalid input in exportToPs" 63 | 64 | exportToPs (ValueRef ident) = 65 | case (Tuple moduleName ident) `M.lookup` env.names of 66 | Nothing -> theImpossibleHappened $ show ident ++ " has no type in exportToPs" 67 | Just (Tuple ty nameKind) | nameKind == Value || nameKind == Extern ForeignImport || nameKind == Extern InlineJavascript -> 68 | tell ["foreign import " ++ show ident ++ " :: " ++ prettyPrintType ty] 69 | _ -> return unit 70 | exportToPs (TypeClassRef className) = 71 | case Qualified (Just moduleName) className `M.lookup` env.typeClasses of 72 | Nothing -> theImpossibleHappened $ show className ++ " has no type class definition in exportToPs" 73 | Just (Tuple3 args members implies) -> do 74 | let impliesString = if null implies then "" else "(" ++ joinWith ", " (map (\(Tuple pn tys') -> show pn ++ " " ++ joinWith " " (map prettyPrintTypeAtom tys')) implies) ++ ") <= " 75 | let exportedMembers = filter (isValueExported <<< fst) members 76 | tell ["class " ++ impliesString ++ show className ++ " " ++ joinWith " " args ++ (if null exportedMembers then "" else " where")] 77 | for_ exportedMembers $ \(Tuple member ty) -> 78 | tell [ " " ++ show member ++ " :: " ++ prettyPrintType ty ] 79 | 80 | exportToPs (TypeInstanceRef ident) = do 81 | case find (((==) (Qualified (Just moduleName) ident)) <<< (\(TypeClassDictionaryInScope tcd) -> tcd.name)) $ M.values env.typeClassDictionaries of 82 | Nothing -> theImpossibleHappened "Type class instance has no dictionary in exportToPs" 83 | Just (TypeClassDictionaryInScope tcd) -> do 84 | let constraintsText = case fromMaybe [] tcd.dependencies of 85 | [] -> "" 86 | cs -> "(" ++ joinWith ", " (map (\(Tuple pn tys') -> show pn ++ " " ++ joinWith " " (map prettyPrintTypeAtom tys')) cs) ++ ") => " 87 | tell ["foreign import instance " ++ show ident ++ " :: " ++ constraintsText ++ show tcd.className ++ " " ++ joinWith " " (map prettyPrintTypeAtom tcd.instanceTypes)] 88 | 89 | isValueExported :: Ident -> Boolean 90 | isValueExported ident = ValueRef ident `elem` exts 91 | -------------------------------------------------------------------------------- /src/Language/PureScript/Constants.purs: -------------------------------------------------------------------------------- 1 | module Language.PureScript.Constants where 2 | 3 | import Prelude () 4 | 5 | -- Prelude Operators 6 | 7 | ($) :: String 8 | ($) = "$" 9 | 10 | (#) :: String 11 | (#) = "#" 12 | 13 | (++) :: String 14 | (++) = "++" 15 | 16 | (>>=) :: String 17 | (>>=) = ">>=" 18 | 19 | (+) :: String 20 | (+) = "+" 21 | 22 | (-) :: String 23 | (-) = "-" 24 | 25 | (*) :: String 26 | (*) = "*" 27 | 28 | (/) :: String 29 | (/) = "/" 30 | 31 | (%) :: String 32 | (%) = "%" 33 | 34 | (<) :: String 35 | (<) = "<" 36 | 37 | (>) :: String 38 | (>) = ">" 39 | 40 | (<=) :: String 41 | (<=) = "<=" 42 | 43 | (>=) :: String 44 | (>=) = ">=" 45 | 46 | (==) :: String 47 | (==) = "==" 48 | 49 | (/=) :: String 50 | (/=) = "/=" 51 | 52 | (&) :: String 53 | (&) = "&" 54 | 55 | bar :: String 56 | bar = "|" 57 | 58 | (^) :: String 59 | (^) = "^" 60 | 61 | (&&) :: String 62 | (&&) = "&&" 63 | 64 | (||) :: String 65 | (||) = "||" 66 | 67 | unsafeIndex :: String 68 | unsafeIndex = "unsafeIndex" 69 | 70 | -- Prelude Operator Functions 71 | 72 | negate :: String 73 | negate = "negate" 74 | 75 | shl :: String 76 | shl = "shl" 77 | 78 | shr :: String 79 | shr = "shr" 80 | 81 | zshr :: String 82 | zshr = "zshr" 83 | 84 | complement :: String 85 | complement = "complement" 86 | 87 | not :: String 88 | not = "not" 89 | 90 | -- Prelude Values 91 | 92 | return :: String 93 | return = "return" 94 | 95 | returnEscaped :: String 96 | returnEscaped = "$return" 97 | 98 | untilE :: String 99 | untilE = "untilE" 100 | 101 | whileE :: String 102 | whileE = "whileE" 103 | 104 | runST :: String 105 | runST = "runST" 106 | 107 | runSTArray :: String 108 | runSTArray = "runSTArray" 109 | 110 | stRefValue :: String 111 | stRefValue = "value" 112 | 113 | newSTRef :: String 114 | newSTRef = "newSTRef" 115 | 116 | readSTRef :: String 117 | readSTRef = "readSTRef" 118 | 119 | writeSTRef :: String 120 | writeSTRef = "writeSTRef" 121 | 122 | modifySTRef :: String 123 | modifySTRef = "modifySTRef" 124 | 125 | peekSTArray :: String 126 | peekSTArray = "peekSTArray" 127 | 128 | pokeSTArray :: String 129 | pokeSTArray = "pokeSTArray" 130 | 131 | -- Type Class Dictionary Names 132 | 133 | monadEffDictionary :: String 134 | monadEffDictionary = "monadEff" 135 | 136 | bindEffDictionary :: String 137 | bindEffDictionary = "bindEff" 138 | 139 | numNumber :: String 140 | numNumber = "numNumber" 141 | 142 | ordNumber :: String 143 | ordNumber = "ordNumber" 144 | 145 | eqNumber :: String 146 | eqNumber = "eqNumber" 147 | 148 | eqString :: String 149 | eqString = "eqString" 150 | 151 | eqBoolean :: String 152 | eqBoolean = "eqBoolean" 153 | 154 | bitsNumber :: String 155 | bitsNumber = "bitsNumber" 156 | 157 | boolLikeBoolean :: String 158 | boolLikeBoolean = "boolLikeBoolean" 159 | 160 | semigroupString :: String 161 | semigroupString = "semigroupString" 162 | 163 | -- Main module 164 | 165 | main :: String 166 | main = "main" 167 | 168 | -- Code Generation 169 | 170 | __superclasses :: String 171 | __superclasses = "__superclasses" 172 | 173 | -- Modules 174 | 175 | prim :: String 176 | prim = "Prim" 177 | 178 | prelude :: String 179 | prelude = "Prelude" 180 | 181 | preludeUnsafe :: String 182 | preludeUnsafe = "Prelude_Unsafe" 183 | 184 | eff :: String 185 | eff = "Control_Monad_Eff" 186 | 187 | st :: String 188 | st = "Control_Monad_ST" 189 | -------------------------------------------------------------------------------- /src/Language/PureScript/Environment.purs: -------------------------------------------------------------------------------- 1 | module Language.PureScript.Environment where 2 | 3 | import Data.Maybe 4 | import Data.Tuple 5 | import Data.Tuple3 6 | 7 | import Language.PureScript.Kinds 8 | import Language.PureScript.Names 9 | import Language.PureScript.TypeClassDictionaries 10 | import Language.PureScript.Types 11 | 12 | import qualified Language.PureScript.Constants as C 13 | import qualified Data.Map as M 14 | 15 | -- | 16 | -- The @Environment@ defines all values and types which are currently in scope: 17 | -- 18 | data Environment = Environment EnvironmentObj 19 | 20 | type EnvironmentObj = { 21 | -- | 22 | -- Value names currently in scope 23 | -- 24 | names :: M.Map (Tuple ModuleName Ident) (Tuple Type NameKind) 25 | -- | 26 | -- Type names currently in scope 27 | -- 28 | , types :: M.Map (Qualified ProperName) (Tuple Kind TypeKind) 29 | -- | 30 | -- Data constructors currently in scope, along with their associated data type constructors 31 | -- 32 | , dataConstructors :: M.Map (Qualified ProperName) (Tuple ProperName Type) 33 | -- | 34 | -- Type synonyms currently in scope 35 | -- 36 | , typeSynonyms :: M.Map (Qualified ProperName) (Tuple [String] Type) 37 | -- | 38 | -- Available type class dictionaries 39 | -- 40 | , typeClassDictionaries :: M.Map (Tuple (Qualified Ident) (Maybe ModuleName)) TypeClassDictionaryInScope 41 | -- | 42 | -- Type classes 43 | -- 44 | , typeClasses :: M.Map (Qualified ProperName) (Tuple3 [String] [Tuple Ident Type] [Tuple (Qualified ProperName) [Type]]) 45 | } 46 | 47 | envObj :: Environment -> EnvironmentObj 48 | envObj (Environment o) = o 49 | 50 | instance showEnv :: Show Environment where 51 | show (Environment o) = "Environment {" ++ 52 | "names: " ++ show o.names ++ ", " ++ 53 | "types: " ++ show o.types ++ ", " ++ 54 | "dataConstructors: " ++ show o.dataConstructors ++ ", " ++ 55 | "typeSynonyms: " ++ show o.typeSynonyms ++ ", " ++ 56 | "typeClassDictionaries: " ++ show o.typeClassDictionaries ++ ", " ++ 57 | "typeClasses: " ++ show o.typeClasses ++ " " ++ 58 | "}" 59 | 60 | -- | 61 | -- The initial environment with no values and only the default javascript types defined 62 | -- 63 | initEnvironment :: Environment 64 | initEnvironment = Environment { names: M.empty 65 | , types: primTypes 66 | , dataConstructors: M.empty 67 | , typeSynonyms: M.empty 68 | , typeClassDictionaries: M.empty 69 | , typeClasses: M.empty 70 | } 71 | 72 | -- | 73 | -- The type of a foreign import 74 | -- 75 | data ForeignImportType 76 | -- | 77 | -- A regular foreign import 78 | -- 79 | = ForeignImport 80 | -- | 81 | -- A foreign import which contains inline Javascript as a string literal 82 | -- 83 | | InlineJavascript 84 | 85 | instance showForeignImport :: Show ForeignImportType where 86 | show ForeignImport = "ForeignImport" 87 | show InlineJavascript = "InlineJavascript" 88 | 89 | instance eqForeignImport :: Eq ForeignImportType where 90 | (==) ForeignImport ForeignImport = true 91 | (==) InlineJavascript InlineJavascript = true 92 | (==) _ _ = false 93 | (/=) x y = not (x == y) 94 | 95 | -- | 96 | -- The kind of a name 97 | -- 98 | data NameKind 99 | -- | 100 | -- A value introduced as a binding in a module 101 | -- 102 | = Value 103 | -- | 104 | -- A foreign import 105 | -- 106 | | Extern ForeignImportType 107 | -- | 108 | -- A local name introduced using a lambda abstraction, variable introduction or binder 109 | -- 110 | | LocalVariable 111 | -- | 112 | -- A data constructor 113 | -- 114 | | DataConstructor 115 | -- | 116 | -- A type class dictionary, generated during desugaring of type class declarations 117 | -- 118 | | TypeInstanceDictionaryValue 119 | -- | 120 | -- A type instance member, generated during desugaring of type class declarations 121 | -- 122 | | TypeInstanceMember 123 | -- | 124 | -- A type class dictionary member accessor import, generated during desugaring of type class declarations 125 | -- 126 | | TypeClassAccessorImport 127 | 128 | instance showNameKind :: Show NameKind where 129 | show Value = "Value" 130 | show (Extern fit) = "Extern (" ++ show fit ++ ")" 131 | show LocalVariable = "LocalVariable" 132 | show DataConstructor = "DataConstructor" 133 | show TypeInstanceDictionaryValue = "TypeInstanceDictionaryValue" 134 | show TypeInstanceMember = "TypeInstanceMember" 135 | show TypeClassAccessorImport = "TypeClassAccessorImport" 136 | 137 | instance eqNameKind :: Eq NameKind where 138 | (==) Value Value = true 139 | (==) (Extern t1) (Extern t2) = t1 == t2 140 | (==) LocalVariable LocalVariable = true 141 | (==) DataConstructor DataConstructor = true 142 | (==) TypeInstanceDictionaryValue TypeInstanceDictionaryValue = true 143 | (==) TypeInstanceMember TypeInstanceMember = true 144 | (==) TypeClassAccessorImport TypeClassAccessorImport = true 145 | (==) _ _ = false 146 | (/=) x y = not (x == y) 147 | 148 | -- | 149 | -- The kinds of a type 150 | -- 151 | data TypeKind 152 | -- | 153 | -- Data type 154 | -- 155 | = DataType [String] [Tuple ProperName [Type]] 156 | -- | 157 | -- Type synonym 158 | -- 159 | | TypeSynonym 160 | -- | 161 | -- Foreign data 162 | -- 163 | | ExternData 164 | -- | 165 | -- A local type variable 166 | -- 167 | | LocalTypeVariable 168 | 169 | instance showTypeKind :: Show TypeKind where 170 | show (DataType args dctors) = "DataType (" ++ show args ++ ") (" ++ show dctors ++ ")" 171 | show TypeSynonym = "TypeSynonym" 172 | show ExternData = "ExternData" 173 | show LocalTypeVariable = "LocalTypeVariable" 174 | 175 | instance eqTypeKind :: Eq TypeKind where 176 | (==) (DataType args1 tys1) (DataType args2 tys2) = args1 == args2 && tys1 == tys2 177 | (==) TypeSynonym TypeSynonym = true 178 | (==) ExternData ExternData = true 179 | (==) LocalTypeVariable LocalTypeVariable = true 180 | (==) _ _ = false 181 | (/=) x y = not (x == y) 182 | 183 | -- | 184 | -- Construct a ProperName in the Prim module 185 | -- 186 | primName :: String -> Qualified ProperName 187 | primName = Qualified (Just $ ModuleName [ProperName C.prim]) <<< ProperName 188 | 189 | -- | 190 | -- Construct a type in the Prim module 191 | -- 192 | primTy :: String -> Type 193 | primTy = TypeConstructor <<< primName 194 | 195 | -- | 196 | -- Type constructor for functions 197 | -- 198 | tyFunction :: Type 199 | tyFunction = primTy "Function" 200 | 201 | -- | 202 | -- Type constructor for strings 203 | -- 204 | tyString :: Type 205 | tyString = primTy "String" 206 | 207 | -- | 208 | -- Type constructor for numbers 209 | -- 210 | tyNumber :: Type 211 | tyNumber = primTy "Number" 212 | 213 | -- | 214 | -- Type constructor for booleans 215 | -- 216 | tyBoolean :: Type 217 | tyBoolean = primTy "Boolean" 218 | 219 | -- | 220 | -- Type constructor for arrays 221 | -- 222 | tyArray :: Type 223 | tyArray = primTy "Array" 224 | 225 | -- | 226 | -- Type constructor for objects 227 | -- 228 | tyObject :: Type 229 | tyObject = primTy "Object" 230 | 231 | -- | 232 | -- Smart constructor for function types 233 | -- 234 | function :: Type -> Type -> Type 235 | function t1 = TypeApp (TypeApp tyFunction t1) 236 | 237 | -- | 238 | -- The primitive types in the external javascript environment with their associated kinds. 239 | -- 240 | primTypes :: M.Map (Qualified ProperName) (Tuple Kind TypeKind) 241 | primTypes = M.fromList [ Tuple (primName "Function") (Tuple (FunKind Star (FunKind Star Star)) ExternData) 242 | , Tuple (primName "Array") (Tuple (FunKind Star Star) ExternData) 243 | , Tuple (primName "Object") (Tuple (FunKind (Row Star) Star) ExternData) 244 | , Tuple (primName "String") (Tuple Star ExternData) 245 | , Tuple (primName "Number") (Tuple Star ExternData) 246 | , Tuple (primName "Boolean") (Tuple Star ExternData) ] 247 | -------------------------------------------------------------------------------- /src/Language/PureScript/Errors.purs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- 3 | -- Module : Language.PureScript.Error 4 | -- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors 5 | -- License : MIT 6 | -- 7 | -- Maintainer : Phil Freeman 8 | -- Stability : experimental 9 | -- Portability : 10 | -- 11 | -- | 12 | -- 13 | ----------------------------------------------------------------------------- 14 | 15 | module Language.PureScript.Errors where 16 | 17 | import Prelude.Unsafe (unsafeIndex) 18 | import Data.Array 19 | import qualified Data.Array.Unsafe as Unsafe 20 | import Data.String (joinWith) 21 | import Data.Maybe 22 | import Data.Monoid 23 | import Data.Either 24 | import Data.Monoid.Last 25 | import Data.Foldable (mconcat) 26 | 27 | import Control.Monad.Error 28 | import Control.Monad.Error.Class 29 | import Control.Monad.Error.Proxy 30 | 31 | import Language.PureScript.Pos 32 | import Language.PureScript.Declarations 33 | import Language.PureScript.Pretty.Values 34 | import Language.PureScript.Pretty.Types 35 | import Language.PureScript.Types 36 | 37 | -- | 38 | -- Type for sources of type checking errors 39 | -- 40 | data ErrorSource 41 | -- | 42 | -- An error which originated at a Value 43 | -- 44 | = ValueError Value 45 | -- | 46 | -- An error which originated at a Type 47 | -- 48 | | TypeError Type 49 | 50 | instance showErrorSource :: Show ErrorSource where 51 | show (ValueError v) = "ValueError (" ++ show v ++ ")" 52 | show (TypeError t) = "TypeError (" ++ show t ++ ")" 53 | 54 | -- | 55 | -- Compilation errors 56 | -- 57 | data CompileError = CompileError { 58 | -- | 59 | -- Error message 60 | -- 61 | message :: String 62 | -- | 63 | -- The value where the error occurred 64 | -- 65 | , value :: Maybe ErrorSource 66 | -- | 67 | -- Optional source position information 68 | -- 69 | , position :: Maybe SourcePos 70 | } 71 | 72 | mkCompileError :: String -> Maybe ErrorSource -> Maybe SourcePos -> CompileError 73 | mkCompileError message value position = 74 | CompileError { message: message 75 | , value: value 76 | , position: position 77 | } 78 | 79 | instance showCompileError :: Show CompileError where 80 | show (CompileError o) = "CompileError {" ++ 81 | "message: " ++ show o.message ++ ", " ++ 82 | "value: " ++ show o.value ++ ", " ++ 83 | "position: " ++ show o.position ++ " " ++ 84 | "}" 85 | 86 | -- | 87 | -- A stack trace for an error 88 | -- 89 | data ErrorStack = ErrorStack [CompileError] 90 | 91 | runErrorStack :: ErrorStack -> [CompileError] 92 | runErrorStack (ErrorStack es) = es 93 | 94 | instance showErrorStack :: Show ErrorStack where 95 | show (ErrorStack es) = "ErrorStack (" ++ show es ++ ")" 96 | 97 | instance semigroupErrorStack :: Semigroup ErrorStack where 98 | (<>) (ErrorStack es1) (ErrorStack es2) = ErrorStack (es1 <> es2) 99 | 100 | instance monoidErrorStack :: Monoid ErrorStack where 101 | mempty = ErrorStack [] 102 | 103 | instance errorErrorStack :: Error ErrorStack where 104 | strMsg s = ErrorStack [mkCompileError s Nothing Nothing] 105 | noMsg = ErrorStack [] 106 | 107 | unifyError :: WithErrorType ErrorStack 108 | unifyError = WithErrorType 109 | 110 | prettyPrintErrorStack :: Boolean -> ErrorStack -> String 111 | prettyPrintErrorStack printFullStack (ErrorStack es) = 112 | case mconcat $ map (\(CompileError o) -> Last o.position) es of 113 | Last (Just sourcePos) -> "Error at " ++ show sourcePos ++ ": \n" ++ prettyPrintErrorStack' 114 | _ -> prettyPrintErrorStack' 115 | where 116 | 117 | prettyPrintErrorStack' :: String 118 | prettyPrintErrorStack' = 119 | if printFullStack 120 | then 121 | joinWith "\n" (map showError (filter isErrorNonEmpty es)) 122 | else 123 | let 124 | es' = filter isErrorNonEmpty es 125 | in case length es' of 126 | 1 -> showError (Unsafe.head es') 127 | _ -> showError (Unsafe.head es') ++ "\n" ++ showError (Unsafe.last es') 128 | 129 | stringifyErrorStack :: forall a. Boolean -> Either ErrorStack a -> Either String a 130 | stringifyErrorStack printFullStack = either (Left <<< prettyPrintErrorStack printFullStack) Right 131 | 132 | isErrorNonEmpty :: CompileError -> Boolean 133 | isErrorNonEmpty (CompileError { message = "" }) = false 134 | isErrorNonEmpty _ = true 135 | 136 | showError :: CompileError -> String 137 | showError (CompileError { message = msg, value = Nothing }) = msg 138 | showError (CompileError { message = msg, value = Just (ValueError val) }) = "Error in value " ++ prettyPrintValue val ++ ":\n" ++ msg 139 | showError (CompileError { message = msg, value = Just (TypeError ty) }) = "Error in type " ++ prettyPrintType ty ++ ":\n" ++ msg 140 | 141 | mkErrorStack :: String -> Maybe ErrorSource -> ErrorStack 142 | mkErrorStack msg t = ErrorStack [mkCompileError msg t Nothing] 143 | 144 | positionError :: SourcePos -> ErrorStack 145 | positionError pos = ErrorStack [mkCompileError "" Nothing (Just pos)] 146 | 147 | -- | 148 | -- Rethrow an error with a more detailed error message in the case of failure 149 | -- 150 | rethrow :: forall e m a. (MonadError e m) => (e -> e) -> m a -> m a 151 | rethrow f = flip catchError $ \e -> throwError (f e) 152 | 153 | -- | 154 | -- Rethrow an error with source position information 155 | -- 156 | rethrowWithPosition :: forall m a. (MonadError ErrorStack m) => SourcePos -> m a -> m a 157 | rethrowWithPosition pos = rethrow ((<>) (positionError pos)) 158 | 159 | -- | 160 | -- Throw a runtime error for a situation where something unexpected (and 161 | -- supposedly impossible) happened 162 | -- 163 | foreign import theImpossibleHappened 164 | "function theImpossibleHappened(msg) {\ 165 | \ throw new Error(msg);\ 166 | \}" :: forall a. String -> a 167 | 168 | -- | 169 | -- This is a hack to emulate the semantics of Haskell's "error" function. 170 | -- It can only be used with types whose runtime representation is an Object. 171 | -- 172 | foreign import error 173 | "function error(msg) {\ 174 | \ var explode = function() {\ 175 | \ this.__defineGetter__('ctor', function() {\ 176 | \ throw new Error(msg);\ 177 | \ });\ 178 | \ };\ 179 | \ return new explode();\ 180 | \}" :: forall a. a 181 | -------------------------------------------------------------------------------- /src/Language/PureScript/Keywords.purs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- 3 | -- Module : Language.PureScript.Keywords 4 | -- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors 5 | -- License : MIT 6 | -- 7 | -- Maintainer : Phil Freeman 8 | -- Stability : experimental 9 | -- Portability : 10 | -- 11 | -- | Various reserved keywords and operator names 12 | -- 13 | ----------------------------------------------------------------------------- 14 | 15 | module Language.PureScript.Keywords where 16 | 17 | import Data.Char 18 | import Data.String (toCharArray) 19 | 20 | -- | 21 | -- A list of purescript reserved identifiers 22 | -- 23 | reservedPsNames :: [String] 24 | reservedPsNames = 25 | [ "data" 26 | , "type" 27 | , "foreign" 28 | , "import" 29 | , "infixl" 30 | , "infixr" 31 | , "infix" 32 | , "class" 33 | , "instance" 34 | , "module" 35 | , "case" 36 | , "of" 37 | , "if" 38 | , "then" 39 | , "else" 40 | , "do" 41 | , "let" 42 | , "true" 43 | , "false" 44 | , "in" 45 | , "where" ] 46 | 47 | -- | 48 | -- A list of additionally reserved identifiers for types 49 | -- 50 | reservedTypeNames :: [String] 51 | reservedTypeNames = 52 | [ "forall" 53 | , "where" ] 54 | 55 | opCharsString :: String 56 | opCharsString = ":!#$%&*+./<=>?@\\^|-~" 57 | 58 | -- | 59 | -- The characters allowed for use in operators 60 | -- 61 | opChars :: [Char] 62 | opChars = toCharArray opCharsString 63 | 64 | -- | 65 | -- A list of reserved operators 66 | -- 67 | reservedOpNames :: [String] 68 | reservedOpNames = 69 | [ "=>" 70 | , "->" 71 | , "=" 72 | , "." 73 | , "\\" ] 74 | -------------------------------------------------------------------------------- /src/Language/PureScript/Kinds.purs: -------------------------------------------------------------------------------- 1 | module Language.PureScript.Kinds where 2 | 3 | import Control.Monad.Unify (Unknown()) 4 | 5 | -- | 6 | -- The data type of kinds 7 | -- 8 | data Kind 9 | -- | 10 | -- Unification variable of type Kind 11 | -- 12 | = KUnknown Unknown 13 | -- | 14 | -- The kind of types 15 | -- 16 | | Star 17 | -- | 18 | -- The kind of effects 19 | -- 20 | | Bang 21 | -- | 22 | -- Kinds for labelled, unordered rows without duplicates 23 | -- 24 | | Row Kind 25 | -- | 26 | -- Function kinds 27 | -- 28 | | FunKind Kind Kind 29 | 30 | instance showKind :: Show Kind where 31 | show (KUnknown u) = "KUnknown (" ++ show u ++ ")" 32 | show Star = "Star" 33 | show Bang = "Bang" 34 | show (Row k) = "Row (" ++ show k ++ ")" 35 | show (FunKind x y) = "FunKind (" ++ show x ++ ") (" ++ show y ++ ")" 36 | 37 | instance eqKind :: Eq Kind where 38 | (==) (KUnknown u1) (KUnknown u2) = u1 == u2 39 | (==) Star Star = true 40 | (==) Bang Bang = true 41 | (==) (Row k1) (Row k2) = k1 == k2 42 | (==) (FunKind x1 y1) (FunKind x2 y2) = x1 == y1 && x2 == y2 43 | (==) _ _ = false 44 | (/=) x y = not (x == y) 45 | 46 | everywhereOnKinds :: (Kind -> Kind) -> Kind -> Kind 47 | everywhereOnKinds f = go 48 | where 49 | go (Row k1) = f (Row (go k1)) 50 | go (FunKind k1 k2) = f (FunKind (go k1) (go k2)) 51 | go other = f other 52 | 53 | everythingOnKinds :: forall r. (r -> r -> r) -> (Kind -> r) -> Kind -> r 54 | everythingOnKinds (<>) f = go 55 | where 56 | go k@(Row k1) = f k <> go k1 57 | go k@(FunKind k1 k2) = f k <> go k1 <> go k2 58 | go other = f other 59 | -------------------------------------------------------------------------------- /src/Language/PureScript/ModuleDependencies.purs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- 3 | -- Module : Language.PureScript.ModuleDependencies 4 | -- Copyright : (c) Phil Freeman 2013 5 | -- License : MIT 6 | -- 7 | -- Maintainer : Phil Freeman 8 | -- Stability : experimental 9 | -- Portability : 10 | -- 11 | -- | Provides the ability to sort modules based on module dependencies 12 | -- 13 | ----------------------------------------------------------------------------- 14 | 15 | module Language.PureScript.ModuleDependencies ( 16 | sortModules, 17 | ModuleGraph(..) 18 | ) where 19 | 20 | import Data.Graph 21 | import Data.Tuple 22 | import Data.Either 23 | import Data.Array (concatMap, map, nub, mapMaybe) 24 | import Data.Maybe 25 | import Data.Foldable (elem, find) 26 | import Data.Traversable (traverse) 27 | 28 | import Language.PureScript.Declarations 29 | import Language.PureScript.Names 30 | import Language.PureScript.Types 31 | import Language.PureScript.Errors 32 | 33 | -- | 34 | -- A list of modules with their dependencies 35 | -- 36 | type ModuleGraph = [Tuple ModuleName [ModuleName]] 37 | 38 | -- | 39 | -- Sort a collection of modules based on module dependencies. 40 | -- 41 | -- Reports an error if the module graph contains a cycle. 42 | -- 43 | sortModules :: [Module] -> Either String (Tuple [Module] ModuleGraph) 44 | sortModules ms = do 45 | let 46 | moduleGraph = map (\(m@(Module mn ds _)) -> Tuple mn (nub (concatMap usedModules ds))) ms 47 | edges = do Tuple mn mns <- moduleGraph 48 | mn' <- mns 49 | return $ Edge mn mn' 50 | moduleNamed mn = 51 | case find (\m -> getModuleName m == mn) ms of 52 | Just m -> m 53 | Nothing -> theImpossibleHappened ("Module '" ++ show mn ++ "' was not found") 54 | ms' <- traverse toModule $ scc' getModuleName moduleNamed $ Graph ms edges 55 | return $ Tuple ms' moduleGraph 56 | 57 | -- | 58 | -- Calculate a list of used modules based on explicit imports and qualified names 59 | -- 60 | usedModules :: Declaration -> [ModuleName] 61 | usedModules = nub <<< (everythingOnValues (++) forDecls forValues (const []) (const []) (const [])).decls 62 | where 63 | forDecls :: Declaration -> [ModuleName] 64 | forDecls (ImportDeclaration mn _ _) = [mn] 65 | forDecls _ = [] 66 | 67 | forValues :: Value -> [ModuleName] 68 | forValues (Var (Qualified (Just mn) _)) = [mn] 69 | forValues (BinaryNoParens (Qualified (Just mn) _) _ _) = [mn] 70 | forValues (Constructor (Qualified (Just mn) _)) = [mn] 71 | forValues (TypedValue _ _ ty) = forTypes ty 72 | forValues _ = [] 73 | 74 | forTypes :: Type -> [ModuleName] 75 | forTypes (TypeConstructor (Qualified (Just mn) _)) = [mn] 76 | forTypes (ConstrainedType cs _) = mapMaybe (\(Tuple (Qualified mn _) _) -> mn) cs 77 | forTypes _ = [] 78 | 79 | getModuleName :: Module -> ModuleName 80 | getModuleName (Module mn _ _) = mn 81 | 82 | -- | 83 | -- Convert a strongly connected component of the module graph to a module 84 | -- 85 | toModule :: SCC Module -> Either String Module 86 | toModule (AcyclicSCC m) = return m 87 | toModule (CyclicSCC ms) = Left $ "Cycle in module dependencies: " ++ show (map getModuleName ms) 88 | -------------------------------------------------------------------------------- /src/Language/PureScript/Names.purs: -------------------------------------------------------------------------------- 1 | module Language.PureScript.Names where 2 | 3 | import Data.Array (map) 4 | import Data.Maybe 5 | import Data.Tuple 6 | import Data.String (joinWith, split) 7 | 8 | -- | 9 | -- Names for value identifiers 10 | -- 11 | data Ident 12 | -- | 13 | -- An alphanumeric identifier 14 | -- 15 | = Ident String 16 | -- | 17 | -- A symbolic name for an infix operator 18 | -- 19 | | Op String 20 | 21 | runIdent :: Ident -> String 22 | runIdent (Ident i) = i 23 | runIdent (Op op) = op 24 | 25 | instance showIdent :: Show Ident where 26 | show (Ident i) = i 27 | show (Op op) = "(" ++ op ++ ")" 28 | 29 | instance eqIdent :: Eq Ident where 30 | (==) (Ident s1) (Ident s2) = s1 == s2 31 | (==) (Op s1) (Op s2) = s1 == s2 32 | (==) _ _ = false 33 | (/=) i1 i2 = not (i1 == i2) 34 | 35 | instance ordIdent :: Ord Ident where 36 | compare (Ident i1) (Ident i2) = compare i1 i2 37 | compare (Ident _) _ = LT 38 | compare (Op op1) (Op op2) = compare op1 op2 39 | compare (Op op1) _ = GT 40 | 41 | -- | 42 | -- Proper names, i.e. capitalized names for e.g. module names, type//data constructors. 43 | -- 44 | data ProperName = ProperName String 45 | 46 | runProperName :: ProperName -> String 47 | runProperName (ProperName s) = s 48 | 49 | instance showProperName :: Show ProperName where 50 | show = runProperName 51 | 52 | instance eqProperName :: Eq ProperName where 53 | (==) (ProperName s1) (ProperName s2) = s1 == s2 54 | (/=) (ProperName s1) (ProperName s2) = s1 /= s2 55 | 56 | instance ordProperName :: Ord ProperName where 57 | compare (ProperName s1) (ProperName s2) = compare s1 s2 58 | 59 | -- | 60 | -- Module names 61 | -- 62 | data ModuleName = ModuleName [ProperName] 63 | 64 | runModuleName :: ModuleName -> String 65 | runModuleName (ModuleName pns) = joinWith "." (runProperName `map` pns) 66 | 67 | instance showModuleName :: Show ModuleName where 68 | show = runModuleName 69 | 70 | instance eqModuleName :: Eq ModuleName where 71 | (==) (ModuleName s1) (ModuleName s2) = s1 == s2 72 | (/=) (ModuleName s1) (ModuleName s2) = s1 /= s2 73 | 74 | instance ordModuleName :: Ord ModuleName where 75 | compare (ModuleName s1) (ModuleName s2) = compare s1 s2 76 | 77 | moduleNameFromString :: String -> ModuleName 78 | moduleNameFromString = ModuleName <<< map ProperName <<< split "." 79 | 80 | -- | 81 | -- A qualified name, i.e. a name with an optional module name 82 | -- 83 | data Qualified a = Qualified (Maybe ModuleName) a 84 | 85 | instance showQualified :: (Show a) => Show (Qualified a) where 86 | show (Qualified Nothing a) = show a 87 | show (Qualified (Just name) a) = show name ++ "." ++ show a 88 | 89 | instance eqQualified :: (Eq a) => Eq (Qualified a) where 90 | (==) (Qualified m1 a1) (Qualified m2 a2) = m1 == m2 && a1 == a2 91 | (/=) q1 q2 = not (q1 == q2) 92 | 93 | instance ordQualified :: (Ord a) => Ord (Qualified a) where 94 | compare (Qualified m1 a1) (Qualified m2 a2) = case compare m1 m2 of 95 | EQ -> compare a1 a2 96 | other -> other 97 | 98 | -- | 99 | -- Provide a default module name, if a name is unqualified 100 | -- 101 | qualify :: forall a. ModuleName -> Qualified a -> Tuple ModuleName a 102 | qualify m (Qualified Nothing a) = Tuple m a 103 | qualify _ (Qualified (Just m) a) = Tuple m a 104 | -------------------------------------------------------------------------------- /src/Language/PureScript/Optimizer.purs: -------------------------------------------------------------------------------- 1 | module Language.PureScript.Optimizer (optimize) where 2 | 3 | import Data.Tuple 4 | import Language.PureScript.CodeGen.JS.AST 5 | import Language.PureScript.Options 6 | import Language.PureScript.Optimizer.Common 7 | import Language.PureScript.Optimizer.TCO 8 | import Language.PureScript.Optimizer.MagicDo 9 | import Language.PureScript.Optimizer.Inliner 10 | import Language.PureScript.Optimizer.Unused 11 | import Language.PureScript.Optimizer.Blocks 12 | import qualified Language.PureScript.Constants as C 13 | 14 | -- | 15 | -- Apply a series of optimizer passes to simplified Javascript code 16 | -- 17 | optimize :: Options -> JS -> JS 18 | optimize (Options o) | o.noOptimizations = id 19 | optimize opts = untilFixedPoint (applyAll 20 | [ collapseNestedBlocks 21 | , tco opts 22 | , magicDo opts 23 | , removeUnusedVariables 24 | , removeCodeAfterReturnStatements 25 | , unThunk 26 | , etaConvert 27 | , evaluateIifes 28 | , inlineVariables 29 | , inlineOperator (Tuple C.prelude C.($)) $ \f x -> JSApp f [x] 30 | , inlineOperator (Tuple C.prelude C.(#)) $ \x f -> JSApp f [x] 31 | , inlineOperator (Tuple C.preludeUnsafe C.unsafeIndex) $ flip JSIndexer 32 | , inlineCommonOperators ]) 33 | 34 | untilFixedPoint :: forall a. (Eq a) => (a -> a) -> a -> a 35 | untilFixedPoint f = go 36 | where 37 | go a = let a' = f a in 38 | if a' == a then a' else go a' 39 | -------------------------------------------------------------------------------- /src/Language/PureScript/Optimizer/Blocks.purs: -------------------------------------------------------------------------------- 1 | module Language.PureScript.Optimizer.Blocks (collapseNestedBlocks) where 2 | 3 | import Data.Array (concatMap) 4 | import Language.PureScript.CodeGen.JS.AST 5 | 6 | -- | 7 | -- Collapse blocks which appear nested directly below another block 8 | -- 9 | collapseNestedBlocks :: JS -> JS 10 | collapseNestedBlocks = everywhereOnJS collapse 11 | where 12 | collapse :: JS -> JS 13 | collapse (JSBlock sts) = JSBlock (concatMap go sts) 14 | collapse js = js 15 | go :: JS -> [JS] 16 | go (JSBlock sts) = sts 17 | go s = [s] 18 | -------------------------------------------------------------------------------- /src/Language/PureScript/Optimizer/Common.purs: -------------------------------------------------------------------------------- 1 | module Language.PureScript.Optimizer.Common where 2 | 3 | import Data.Foldable (foldl, lookup, elem, any) 4 | import Data.Maybe (fromMaybe) 5 | import Data.Tuple 6 | import Language.PureScript.Errors 7 | import Language.PureScript.CodeGen.JS.AST 8 | 9 | applyAll :: forall a. [a -> a] -> a -> a 10 | applyAll (f : fs) = foldl (<<<) f fs 11 | 12 | replaceIdent :: String -> JS -> JS -> JS 13 | replaceIdent var1 js = everywhereOnJS replace 14 | where 15 | replace (JSVar var2) | var1 == var2 = js 16 | replace other = other 17 | 18 | replaceIdents :: [Tuple String JS] -> JS -> JS 19 | replaceIdents vars = everywhereOnJS replace 20 | where 21 | replace v@(JSVar var) = fromMaybe v $ lookup var vars 22 | replace other = other 23 | 24 | isReassigned :: String -> JS -> Boolean 25 | isReassigned var1 = everythingOnJS (||) check 26 | where 27 | check :: JS -> Boolean 28 | check (JSFunction _ args _) | var1 `elem` args = true 29 | check (JSVariableIntroduction arg _) | var1 == arg = true 30 | check (JSAssignment (JSVar arg) _) | var1 == arg = true 31 | check (JSFor arg _ _ _) | var1 == arg = true 32 | check (JSForIn arg _ _) | var1 == arg = true 33 | check _ = false 34 | 35 | isRebound :: JS -> JS -> Boolean 36 | isRebound js d = any (\v -> isReassigned v d || isUpdated v d) (everythingOnJS (++) variablesOf js) 37 | where 38 | variablesOf (JSVar var) = [var] 39 | variablesOf _ = [] 40 | 41 | isUsed :: String -> JS -> Boolean 42 | isUsed var1 = everythingOnJS (||) check 43 | where 44 | check :: JS -> Boolean 45 | check (JSVar var2) | var1 == var2 = true 46 | check (JSAssignment target _) | var1 == targetVariable target = true 47 | check _ = false 48 | 49 | targetVariable :: JS -> String 50 | targetVariable (JSVar var) = var 51 | targetVariable (JSAccessor _ tgt) = targetVariable tgt 52 | targetVariable (JSIndexer _ tgt) = targetVariable tgt 53 | targetVariable _ = theImpossibleHappened "Invalid argument to targetVariable" 54 | 55 | isUpdated :: String -> JS -> Boolean 56 | isUpdated var1 = everythingOnJS (||) check 57 | where 58 | check :: JS -> Boolean 59 | check (JSAssignment target _) | var1 == targetVariable target = true 60 | check _ = false 61 | 62 | removeFromBlock :: ([JS] -> [JS]) -> JS -> JS 63 | removeFromBlock go (JSBlock sts) = JSBlock (go sts) 64 | removeFromBlock _ js = js 65 | -------------------------------------------------------------------------------- /src/Language/PureScript/Optimizer/Inliner.purs: -------------------------------------------------------------------------------- 1 | module Language.PureScript.Optimizer.Inliner 2 | ( inlineVariables 3 | , inlineOperator 4 | , inlineCommonOperators 5 | , etaConvert 6 | , unThunk 7 | , evaluateIifes 8 | ) where 9 | 10 | import Data.Array (map, zipWith) 11 | import Data.Array.Unsafe (last, init) 12 | import Data.Foldable (all, any) 13 | import Data.Maybe 14 | import Data.Tuple 15 | import Language.PureScript.CodeGen.JS.AST 16 | import Language.PureScript.CodeGen.Common (identToJs) 17 | import Language.PureScript.Names 18 | import Language.PureScript.Optimizer.Common 19 | 20 | import qualified Language.PureScript.Constants as C 21 | 22 | shouldInline :: JS -> Boolean 23 | shouldInline (JSVar _) = true 24 | shouldInline (JSNumericLiteral _) = true 25 | shouldInline (JSStringLiteral _) = true 26 | shouldInline (JSBooleanLiteral _) = true 27 | shouldInline (JSAccessor _ val) = shouldInline val 28 | shouldInline (JSIndexer index val) = shouldInline index && shouldInline val 29 | shouldInline _ = false 30 | 31 | etaConvert :: JS -> JS 32 | etaConvert = everywhereOnJS convert 33 | where 34 | convert :: JS -> JS 35 | convert (JSBlock [JSReturn (JSApp (JSFunction Nothing idents block@(JSBlock body)) args)]) 36 | | all shouldInline args && 37 | not (any (flip isRebound block) (map JSVar idents)) && 38 | not (any (flip isRebound block) args) 39 | = JSBlock (map (replaceIdents (zipWith Tuple idents args)) body) 40 | convert js = js 41 | 42 | unThunk :: JS -> JS 43 | unThunk = everywhereOnJS convert 44 | where 45 | convert :: JS -> JS 46 | convert (JSBlock []) = JSBlock [] 47 | convert (JSBlock jss) = 48 | case last jss of 49 | JSReturn (JSApp (JSFunction Nothing [] (JSBlock body)) []) -> JSBlock $ init jss ++ body 50 | _ -> JSBlock jss 51 | convert js = js 52 | 53 | evaluateIifes :: JS -> JS 54 | evaluateIifes = everywhereOnJS convert 55 | where 56 | convert :: JS -> JS 57 | convert (JSApp (JSFunction Nothing [] (JSBlock [JSReturn ret])) []) = ret 58 | convert js = js 59 | 60 | inlineVariables :: JS -> JS 61 | inlineVariables = everywhereOnJS $ removeFromBlock go 62 | where 63 | go :: [JS] -> [JS] 64 | go [] = [] 65 | go (JSVariableIntroduction var (Just js) : sts) 66 | | shouldInline js && not (any (isReassigned var) sts) && not (any (isRebound js) sts) && not (any (isUpdated var) sts) = 67 | go (map (replaceIdent var js) sts) 68 | go (s:sts) = s : go sts 69 | 70 | inlineOperator :: (Tuple String String) -> (JS -> JS -> JS) -> JS -> JS 71 | inlineOperator (Tuple m op) f = everywhereOnJS convert 72 | where 73 | convert :: JS -> JS 74 | convert (JSApp (JSApp op' [x]) [y]) | isOp op' = f x y 75 | convert other = other 76 | isOp (JSAccessor longForm (JSVar m')) = m == m' && longForm == identToJs (Op op) 77 | isOp (JSIndexer (JSStringLiteral op') (JSVar m')) = m == m' && op == op' 78 | isOp _ = false 79 | 80 | inlineCommonOperators :: JS -> JS 81 | inlineCommonOperators = applyAll 82 | [ binary C.numNumber C.(+) Add 83 | , binary C.numNumber C.(-) Subtract 84 | , binary C.numNumber C.(*) Multiply 85 | , binary C.numNumber C.(/) Divide 86 | , binary C.numNumber C.(%) Modulus 87 | , unary C.numNumber C.negate Negate 88 | 89 | , binary C.ordNumber C.(<) LessThan 90 | , binary C.ordNumber C.(>) GreaterThan 91 | , binary C.ordNumber C.(<=) LessThanOrEqualTo 92 | , binary C.ordNumber C.(>=) GreaterThanOrEqualTo 93 | 94 | , binary C.eqNumber C.(==) EqualTo 95 | , binary C.eqNumber C.(/=) NotEqualTo 96 | , binary C.eqString C.(==) EqualTo 97 | , binary C.eqString C.(/=) NotEqualTo 98 | , binary C.eqBoolean C.(==) EqualTo 99 | , binary C.eqBoolean C.(/=) NotEqualTo 100 | 101 | , binary C.semigroupString C.(++) Add 102 | 103 | , binaryFunction C.bitsNumber C.shl ShiftLeft 104 | , binaryFunction C.bitsNumber C.shr ShiftRight 105 | , binaryFunction C.bitsNumber C.zshr ZeroFillShiftRight 106 | , binary C.bitsNumber C.(&) BitwiseAnd 107 | , binary C.bitsNumber C.bar BitwiseOr 108 | , binary C.bitsNumber C.(^) BitwiseXor 109 | , unary C.bitsNumber C.complement BitwiseNot 110 | 111 | , binary C.boolLikeBoolean C.(&&) And 112 | , binary C.boolLikeBoolean C.(||) Or 113 | , unary C.boolLikeBoolean C.not Not 114 | ] 115 | where 116 | binary :: String -> String -> BinaryOperator -> JS -> JS 117 | binary dictName opString op = everywhereOnJS convert 118 | where 119 | convert :: JS -> JS 120 | convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict dictName dict = JSBinary op x y 121 | convert other = other 122 | isOp (JSAccessor longForm (JSAccessor prelude (JSVar _))) = prelude == C.prelude && longForm == identToJs (Op opString) 123 | isOp (JSIndexer (JSStringLiteral op') (JSVar prelude)) = prelude == C.prelude && opString == op' 124 | isOp _ = false 125 | binaryFunction :: String -> String -> BinaryOperator -> JS -> JS 126 | binaryFunction dictName fnName op = everywhereOnJS convert 127 | where 128 | convert :: JS -> JS 129 | convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict dictName dict = JSBinary op x y 130 | convert other = other 131 | isOp (JSAccessor fnName' (JSVar prelude)) = prelude == C.prelude && fnName == fnName' 132 | isOp _ = false 133 | unary :: String -> String -> UnaryOperator -> JS -> JS 134 | unary dictName fnName op = everywhereOnJS convert 135 | where 136 | convert :: JS -> JS 137 | convert (JSApp (JSApp fn [dict]) [x]) | isOp fn && isOpDict dictName dict = JSUnary op x 138 | convert other = other 139 | isOp (JSAccessor fnName' (JSVar prelude)) = prelude == C.prelude && fnName' == fnName 140 | isOp _ = false 141 | isOpDict dictName (JSApp (JSAccessor prop (JSVar prelude)) [JSObjectLiteral []]) = prelude == C.prelude && prop == dictName 142 | isOpDict _ _ = false 143 | -------------------------------------------------------------------------------- /src/Language/PureScript/Optimizer/MagicDo.purs: -------------------------------------------------------------------------------- 1 | module Language.PureScript.Optimizer.MagicDo (magicDo) where 2 | 3 | import Data.Array (nub, length, filter) 4 | import Data.Array.Unsafe (last, init) 5 | import Data.Foldable (all, elem) 6 | import Data.Maybe 7 | import Data.Maybe.Unsafe (fromJust) 8 | import Data.Tuple 9 | 10 | import Language.PureScript.Options 11 | import Language.PureScript.CodeGen.JS.AST 12 | import Language.PureScript.CodeGen.Common (identToJs) 13 | import Language.PureScript.Names 14 | 15 | import qualified Language.PureScript.Constants as C 16 | 17 | magicDo :: Options -> JS -> JS 18 | magicDo (Options o) | o.noMagicDo = id 19 | magicDo _ = inlineST <<< magicDo' 20 | 21 | -- | 22 | -- Inline type class dictionaries for >>= and return for the Eff monad 23 | -- 24 | -- E.g. 25 | -- 26 | -- Prelude[">>="](dict)(m1)(function(x) { 27 | -- return ...; 28 | -- }) 29 | -- 30 | -- becomes 31 | -- 32 | -- function __do { 33 | -- var x = m1(); 34 | -- ... 35 | -- } 36 | -- 37 | magicDo' :: JS -> JS 38 | magicDo' = everywhereOnJS undo <<< everywhereOnJSTopDown convert 39 | where 40 | -- The name of the function block which is added to denote a do block 41 | fnName = "__do" 42 | -- Desugar monomorphic calls to >>= and return for the Eff monad 43 | convert :: JS -> JS 44 | -- Desugar return 45 | convert (JSApp (JSApp ret [val]) []) | isReturn ret = val 46 | -- Desugar >> 47 | convert (JSApp (JSApp bind [m]) [JSFunction Nothing ["_"] (JSBlock js)]) | isBind bind && isJSReturn (last js) = 48 | case last js of JSReturn ret -> JSFunction (Just fnName) [] $ JSBlock (JSApp m [] : init js ++ [JSReturn (JSApp ret [])] ) 49 | -- Desugar >>= 50 | convert (JSApp (JSApp bind [m]) [JSFunction Nothing [arg] (JSBlock js)]) | isBind bind && isJSReturn (last js) = 51 | case last js of JSReturn ret -> JSFunction (Just fnName) [] $ JSBlock (JSVariableIntroduction arg (Just (JSApp m [])) : init js ++ [JSReturn (JSApp ret [])] ) 52 | -- Desugar untilE 53 | convert (JSApp (JSApp f [arg]) []) | isEffFunc C.untilE f = 54 | JSApp (JSFunction Nothing [] (JSBlock [ JSWhile (JSUnary Not (JSApp arg [])) (JSBlock []), JSReturn (JSObjectLiteral []) ])) [] 55 | -- Desugar whileE 56 | convert (JSApp (JSApp (JSApp f [arg1]) [arg2]) []) | isEffFunc C.whileE f = 57 | JSApp (JSFunction Nothing [] (JSBlock [ JSWhile (JSApp arg1 []) (JSBlock [ JSApp arg2 [] ]), JSReturn (JSObjectLiteral []) ])) [] 58 | convert other = other 59 | -- Check if an expression represents a monomorphic call to >>= for the Eff monad 60 | isBind (JSApp bindPoly [effDict]) | isBindPoly bindPoly && isEffDict C.bindEffDictionary effDict = true 61 | isBind _ = false 62 | -- Check if an expression represents a monomorphic call to return for the Eff monad 63 | isReturn (JSApp retPoly [effDict]) | isRetPoly retPoly && isEffDict C.monadEffDictionary effDict = true 64 | isReturn _ = false 65 | -- Check if an expression represents the polymorphic >>= function 66 | isBindPoly (JSAccessor prop (JSVar prelude)) = prelude == C.prelude && prop == identToJs (Op C.(>>=)) 67 | isBindPoly (JSIndexer (JSStringLiteral bind) (JSVar prelude)) = prelude == C.prelude && bind == C.(>>=) 68 | isBindPoly _ = false 69 | -- Check if an expression represents the polymorphic return function 70 | isRetPoly (JSAccessor returnEscaped (JSVar prelude)) = prelude == C.prelude && returnEscaped == C.returnEscaped 71 | isRetPoly (JSIndexer (JSStringLiteral return') (JSVar prelude)) = prelude == C.prelude && return' == C.return 72 | isRetPoly _ = false 73 | -- Check if an expression represents a function in the Ef module 74 | isEffFunc name (JSAccessor name' (JSVar eff)) = eff == C.eff && name == name' 75 | isEffFunc _ _ = false 76 | -- Check if an expression represents the Monad Eff dictionary 77 | isEffDict name (JSApp (JSVar ident) [JSObjectLiteral []]) | ident == name = true 78 | isEffDict name (JSApp (JSAccessor prop (JSVar eff)) [JSObjectLiteral []]) = eff == C.eff && prop == name 79 | isEffDict _ _ = false 80 | -- Remove __do function applications which remain after desugaring 81 | undo :: JS -> JS 82 | undo (JSReturn (JSApp (JSFunction (Just ident) [] body) [])) | ident == fnName = body 83 | undo other = other 84 | 85 | isJSReturn (JSReturn _) = true 86 | isJSReturn _ = false 87 | 88 | -- | 89 | -- Inline functions in the ST module 90 | -- 91 | inlineST :: JS -> JS 92 | inlineST = everywhereOnJS convertBlock 93 | where 94 | -- Look for runST blocks and inline the STRefs there. 95 | -- If all STRefs are used in the scope of the same runST, only using { read, write, modify }STRef then 96 | -- we can be more aggressive about inlining, and actually turn STRefs into local variables. 97 | convertBlock (JSApp f [arg]) | isSTFunc C.runST f || isSTFunc C.runSTArray f = 98 | let refs = nub <<< findSTRefsIn $ arg 99 | usages = findAllSTUsagesIn arg 100 | allUsagesAreLocalVars = all (\u -> let v = toVar u in isJust v && fromJust v `elem` refs) usages 101 | localVarsDoNotEscape = all (\r -> length (r `appearingIn` arg) == length (filter (\u -> let v = toVar u in v == Just r) usages)) refs 102 | in everywhereOnJS (convert (allUsagesAreLocalVars && localVarsDoNotEscape)) arg 103 | convertBlock other = other 104 | -- Convert a block in a safe way, preserving object wrappers of references, 105 | -- or in a more aggressive way, turning wrappers into local variables depending on the 106 | -- agg(ressive) parameter. 107 | convert agg (JSApp f [arg]) | isSTFunc C.newSTRef f = 108 | JSFunction Nothing [] (JSBlock [JSReturn $ if agg then arg else JSObjectLiteral [Tuple C.stRefValue arg]]) 109 | convert agg (JSApp (JSApp f [ref]) []) | isSTFunc C.readSTRef f = 110 | if agg then ref else JSAccessor C.stRefValue ref 111 | convert agg (JSApp (JSApp (JSApp f [ref]) [arg]) []) | isSTFunc C.writeSTRef f = 112 | if agg then JSAssignment ref arg else JSAssignment (JSAccessor C.stRefValue ref) arg 113 | convert agg (JSApp (JSApp (JSApp f [ref]) [func]) []) | isSTFunc C.modifySTRef f = 114 | if agg then JSAssignment ref (JSApp func [ref]) else JSAssignment (JSAccessor C.stRefValue ref) (JSApp func [JSAccessor C.stRefValue ref]) 115 | convert _ (JSApp (JSApp (JSApp f [arr]) [i]) []) | isSTFunc C.peekSTArray f = 116 | JSIndexer i arr 117 | convert _ (JSApp (JSApp (JSApp (JSApp f [arr]) [i]) [val]) []) | isSTFunc C.pokeSTArray f = 118 | JSAssignment (JSIndexer i arr) val 119 | convert _ other = other 120 | -- Check if an expression represents a function in the ST module 121 | isSTFunc name (JSAccessor name' (JSVar st)) = st == C.st && name == name' 122 | isSTFunc _ _ = false 123 | -- Find all ST Refs initialized in this block 124 | findSTRefsIn = everythingOnJS (++) isSTRef 125 | where 126 | isSTRef (JSVariableIntroduction ident (Just (JSApp (JSApp f [_]) []))) | isSTFunc C.newSTRef f = [ident] 127 | isSTRef _ = [] 128 | -- Find all STRefs used as arguments to readSTRef, writeSTRef, modifySTRef 129 | findAllSTUsagesIn = everythingOnJS (++) isSTUsage 130 | where 131 | isSTUsage (JSApp (JSApp f [ref]) []) | isSTFunc C.readSTRef f = [ref] 132 | isSTUsage (JSApp (JSApp (JSApp f [ref]) [_]) []) | isSTFunc C.writeSTRef f || isSTFunc C.modifySTRef f = [ref] 133 | isSTUsage _ = [] 134 | -- Find all uses of a variable 135 | appearingIn ref = everythingOnJS (++) isVar 136 | where 137 | isVar e@(JSVar v) | v == ref = [e] 138 | isVar _ = [] 139 | -- Convert a JS value to a String if it is a JSVar 140 | toVar (JSVar v) = Just v 141 | toVar _ = Nothing 142 | -------------------------------------------------------------------------------- /src/Language/PureScript/Optimizer/TCO.purs: -------------------------------------------------------------------------------- 1 | module Language.PureScript.Optimizer.TCO (tco) where 2 | 3 | import Data.Array (reverse, concat, map, zipWith) 4 | import Data.Maybe 5 | import Data.Tuple3 6 | import Data.Foldable (any) 7 | 8 | import Language.PureScript.Options 9 | import Language.PureScript.CodeGen.JS.AST 10 | 11 | -- | 12 | -- Eliminate tail calls 13 | -- 14 | tco :: Options -> JS -> JS 15 | tco (Options o) | o.noTco = id 16 | tco _ = tco' 17 | 18 | tco' :: JS -> JS 19 | tco' = everywhereOnJS convert 20 | where 21 | tcoLabel :: String 22 | tcoLabel = "tco" 23 | tcoVar :: String -> String 24 | tcoVar arg = "__tco_" ++ arg 25 | copyVar :: String -> String 26 | copyVar arg = "__copy_" ++ arg 27 | convert :: JS -> JS 28 | convert js@(JSVariableIntroduction name (Just fn@(JSFunction _ _ _))) = 29 | case collectAllFunctionArgs [] id fn of 30 | Tuple3 argss body' replace | isTailCall name body' -> 31 | let allArgs = reverse $ concat argss 32 | in JSVariableIntroduction name (Just (replace (toLoop name allArgs body'))) 33 | _ -> js 34 | convert js = js 35 | collectAllFunctionArgs :: [[String]] -> (JS -> JS) -> JS -> (Tuple3 [[String]] JS (JS -> JS)) 36 | collectAllFunctionArgs allArgs f (JSFunction ident args (JSBlock ((body@(JSReturn _)):_))) = 37 | collectAllFunctionArgs (args : allArgs) (\b -> f (JSFunction ident (map copyVar args) (JSBlock [b]))) body 38 | collectAllFunctionArgs allArgs f (JSFunction ident args body@(JSBlock _)) = 39 | Tuple3 (args : allArgs) body (f <<< JSFunction ident (map copyVar args)) 40 | collectAllFunctionArgs allArgs f (JSReturn (JSFunction ident args (JSBlock [body]))) = 41 | collectAllFunctionArgs (args : allArgs) (\b -> f (JSReturn (JSFunction ident (map copyVar args) (JSBlock [b])))) body 42 | collectAllFunctionArgs allArgs f (JSReturn (JSFunction ident args body@(JSBlock _))) = 43 | Tuple3 (args : allArgs) body (f <<< JSReturn <<< JSFunction ident (map copyVar args)) 44 | collectAllFunctionArgs allArgs f body = Tuple3 allArgs body f 45 | isTailCall :: String -> JS -> Boolean 46 | isTailCall ident js = 47 | let 48 | numSelfCalls = everythingOnJS (+) countSelfCalls js 49 | numSelfCallsInTailPosition = everythingOnJS (+) countSelfCallsInTailPosition js 50 | numSelfCallsUnderFunctions = everythingOnJS (+) countSelfCallsUnderFunctions js 51 | in 52 | numSelfCalls > 0 53 | && numSelfCalls == numSelfCallsInTailPosition 54 | && numSelfCallsUnderFunctions == 0 55 | where 56 | countSelfCalls :: JS -> Number 57 | countSelfCalls (JSApp (JSVar ident') _) | ident == ident' = 1 58 | countSelfCalls _ = 0 59 | countSelfCallsInTailPosition :: JS -> Number 60 | countSelfCallsInTailPosition (JSReturn ret) | isSelfCall ident ret = 1 61 | countSelfCallsInTailPosition _ = 0 62 | countSelfCallsUnderFunctions (JSFunction _ _ js') = everythingOnJS (+) countSelfCalls js' 63 | countSelfCallsUnderFunctions _ = 0 64 | toLoop :: String -> [String] -> JS -> JS 65 | toLoop ident allArgs js = JSBlock $ 66 | map (\arg -> JSVariableIntroduction arg (Just (JSVar (copyVar arg)))) allArgs ++ 67 | [ JSLabel tcoLabel $ JSWhile (JSBooleanLiteral true) (JSBlock [ everywhereOnJS loopify js ]) ] 68 | where 69 | loopify :: JS -> JS 70 | loopify (JSReturn ret) | isSelfCall ident ret = 71 | let 72 | allArgumentValues = concat $ collectSelfCallArgs [] ret 73 | in 74 | JSBlock $ zipWith (\val arg -> 75 | JSVariableIntroduction (tcoVar arg) (Just val)) allArgumentValues allArgs 76 | ++ map (\arg -> 77 | JSAssignment (JSVar arg) (JSVar (tcoVar arg))) allArgs 78 | ++ [ JSContinue tcoLabel ] 79 | loopify other = other 80 | collectSelfCallArgs :: [[JS]] -> JS -> [[JS]] 81 | collectSelfCallArgs allArgumentValues (JSApp fn args') = collectSelfCallArgs (args' : allArgumentValues) fn 82 | collectSelfCallArgs allArgumentValues _ = allArgumentValues 83 | isSelfCall :: String -> JS -> Boolean 84 | isSelfCall ident (JSApp (JSVar ident') args) | ident == ident' && not (any isFunction args) = true 85 | isSelfCall ident (JSApp fn args) | not (any isFunction args) = isSelfCall ident fn 86 | isSelfCall _ _ = false 87 | isFunction :: JS -> Boolean 88 | isFunction (JSFunction _ _ _) = true 89 | isFunction _ = false 90 | -------------------------------------------------------------------------------- /src/Language/PureScript/Optimizer/Unused.purs: -------------------------------------------------------------------------------- 1 | module Language.PureScript.Optimizer.Unused 2 | ( removeUnusedVariables 3 | , removeCodeAfterReturnStatements 4 | ) where 5 | 6 | import Data.Array (span) 7 | import Data.Foldable (any) 8 | import Data.Tuple 9 | import Language.PureScript.CodeGen.JS.AST 10 | import Language.PureScript.Optimizer.Common 11 | 12 | removeUnusedVariables :: JS -> JS 13 | removeUnusedVariables = everywhereOnJS (removeFromBlock withBlock) 14 | where 15 | withBlock :: [JS] -> [JS] 16 | withBlock sts = go sts sts 17 | go :: [JS] -> [JS] -> [JS] 18 | go _ [] = [] 19 | go sts (JSVariableIntroduction var _ : rest) | not (any (isUsed var) sts) = go sts rest 20 | go sts (s : rest) = s : go sts rest 21 | 22 | removeCodeAfterReturnStatements :: JS -> JS 23 | removeCodeAfterReturnStatements = everywhereOnJS (removeFromBlock go) 24 | where 25 | go :: [JS] -> [JS] 26 | go jss | not (any isJSReturn jss) = jss 27 | go jss = case span (not <<< isJSReturn) jss of 28 | { init = body, rest = (ret : _) } -> body ++ [ret] 29 | isJSReturn (JSReturn _) = true 30 | isJSReturn _ = false 31 | -------------------------------------------------------------------------------- /src/Language/PureScript/Options.purs: -------------------------------------------------------------------------------- 1 | module Language.PureScript.Options where 2 | 3 | import Data.Maybe 4 | 5 | -- | 6 | -- The data type of compiler 7 | -- 8 | data Options = Options { 9 | -- | 10 | -- Disable inclusion of the built in Prelude 11 | -- 12 | noPrelude :: Boolean 13 | -- | 14 | -- Disable tail-call elimination 15 | -- 16 | , noTco :: Boolean 17 | -- | 18 | -- Perform type checks at runtime 19 | -- 20 | , performRuntimeTypeChecks :: Boolean 21 | -- | 22 | -- Disable inlining of calls to return and bind for the Eff monad 23 | -- 24 | , noMagicDo :: Boolean 25 | -- | 26 | -- When specified, checks the type of `main` in the module, and generate a call to run main 27 | -- after the module definitions. 28 | -- 29 | , main :: Maybe String 30 | -- | 31 | -- Skip all optimizations 32 | -- 33 | , noOptimizations :: Boolean 34 | -- | 35 | -- Specify the namespace that PureScript modules will be exported to when running in the 36 | -- browser. 37 | -- 38 | , browserNamespace :: Maybe String 39 | -- | 40 | -- The modules to keep while enabling dead code elimination 41 | -- 42 | , modules :: [String] 43 | -- | 44 | -- The modules to code gen 45 | -- 46 | , codeGenModules :: [String] 47 | -- | 48 | -- Verbose error message 49 | -- 50 | , verboseErrors :: Boolean 51 | } 52 | 53 | mkOptions :: Boolean -> Boolean -> Boolean -> Boolean -> Maybe String -> Boolean -> Maybe String -> [String] -> [String] -> Boolean -> Options 54 | mkOptions noPrelude 55 | noTco 56 | performRuntimeTypeChecks 57 | noMagicDo 58 | main 59 | noOptimizations 60 | browserNamespace 61 | modules 62 | codeGenModules 63 | verboseErrors = 64 | Options { noPrelude: noPrelude 65 | , noTco: noTco 66 | , performRuntimeTypeChecks: performRuntimeTypeChecks 67 | , noMagicDo: noMagicDo 68 | , main: main 69 | , noOptimizations: noOptimizations 70 | , browserNamespace: browserNamespace 71 | , modules: modules 72 | , codeGenModules: codeGenModules 73 | , verboseErrors: verboseErrors 74 | } 75 | 76 | -- | 77 | -- Default compiler 78 | -- 79 | defaultOptions :: Options 80 | defaultOptions = Options { noPrelude: false 81 | , noTco: false 82 | , performRuntimeTypeChecks: false 83 | , noMagicDo: false 84 | , main: Nothing 85 | , noOptimizations: false 86 | , browserNamespace: Nothing 87 | , modules: [] 88 | , codeGenModules: [] 89 | , verboseErrors: false 90 | } 91 | -------------------------------------------------------------------------------- /src/Language/PureScript/Parser/Common.purs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- 3 | -- Module : Language.PureScript.Parser.Common 4 | -- Copyright : (c) Phil Freeman 2013 5 | -- License : MIT 6 | -- 7 | -- Maintainer : Phil Freeman 8 | -- Stability : experimental 9 | -- Portability : 10 | -- 11 | -- | 12 | -- Constants, and utility functions to be used when parsing 13 | -- 14 | ----------------------------------------------------------------------------- 15 | 16 | module Language.PureScript.Parser.Common where 17 | 18 | import Prelude.Unsafe (unsafeIndex) 19 | 20 | import Data.Maybe 21 | import Data.Either 22 | import Data.Array (map, null, length) 23 | import Data.Foldable (notElem, foldl) 24 | 25 | import Control.Alt 26 | import Control.Alternative 27 | import Control.Apply 28 | 29 | import Control.Monad.State.Class 30 | import Control.Monad.Error.Class 31 | 32 | import Text.Parsing.Parser 33 | import Text.Parsing.Parser.Combinators 34 | 35 | import Language.PureScript.Pos 36 | import Language.PureScript.Parser.Lexer 37 | import Language.PureScript.Names 38 | import Language.PureScript.Keywords 39 | 40 | data TokenStream = TokenStream { tokens :: [PositionedToken], position :: Number } 41 | 42 | toTokenStream :: [PositionedToken] -> TokenStream 43 | toTokenStream ts = TokenStream { tokens: ts, position: 0 } 44 | 45 | unconsStream :: TokenStream -> Maybe { head :: PositionedToken, tail :: TokenStream } 46 | unconsStream (TokenStream o) | o.position < length o.tokens = 47 | Just { head: o.tokens `unsafeIndex` o.position 48 | , tail: TokenStream { tokens: o.tokens 49 | , position: o.position + 1 50 | } 51 | } 52 | unconsStream _ = Nothing 53 | 54 | runTokenParser :: forall a. Parser TokenStream a -> [PositionedToken] -> Either String a 55 | runTokenParser p ts = case runParser (toTokenStream ts) p of 56 | Left (ParseError o) -> Left o.message 57 | Right a -> Right a 58 | 59 | eof :: Parser TokenStream Unit 60 | eof = do 61 | ts <- get 62 | case unconsStream ts of 63 | Nothing -> return unit 64 | Just cons -> fail $ "Expected EOF at line " ++ show cons.head.line ++ ", column " ++ show cons.head.column ++ ", found " ++ show cons.head.token 65 | 66 | token :: forall a. String -> (Token -> String) -> (Token -> Maybe a) -> Parser TokenStream a 67 | token exp sh p = do 68 | ts <- get 69 | case unconsStream ts of 70 | Just cons -> 71 | case p cons.head.token of 72 | Just a -> do 73 | consume 74 | put cons.tail 75 | return a 76 | Nothing -> fail $ "Expected " ++ exp ++ ", found " ++ sh cons.head.token ++ " at line " ++ show cons.head.line ++ ", column " ++ show cons.head.column 77 | _ -> fail $ "Expected " ++ exp ++ ", found EOF" 78 | 79 | token' :: forall a. String -> (Token -> Maybe a) -> Parser TokenStream a 80 | token' exp p = token exp show p 81 | 82 | match :: forall a. Token -> Parser TokenStream Unit 83 | match tok = token' (show tok) (\tok' -> if tok == tok' then Just unit else Nothing) 84 | 85 | lparen :: Parser TokenStream Unit 86 | lparen = match LParen 87 | 88 | rparen :: Parser TokenStream Unit 89 | rparen = match RParen 90 | 91 | parens :: forall a. Parser TokenStream a -> Parser TokenStream a 92 | parens = between lparen rparen 93 | 94 | lbrace :: Parser TokenStream Unit 95 | lbrace = match LBrace 96 | 97 | rbrace :: Parser TokenStream Unit 98 | rbrace = match RBrace 99 | 100 | braces :: forall a. Parser TokenStream a -> Parser TokenStream a 101 | braces = between lbrace rbrace 102 | 103 | langle :: Parser TokenStream Unit 104 | langle = match LAngle 105 | 106 | rangle :: Parser TokenStream Unit 107 | rangle = match RAngle 108 | 109 | angles :: forall a. Parser TokenStream a -> Parser TokenStream a 110 | angles = between langle rangle 111 | 112 | lsquare :: Parser TokenStream Unit 113 | lsquare = match LSquare 114 | 115 | rsquare :: Parser TokenStream Unit 116 | rsquare = match RSquare 117 | 118 | squares :: forall a. Parser TokenStream a -> Parser TokenStream a 119 | squares = between lsquare rsquare 120 | 121 | larrow :: Parser TokenStream Unit 122 | larrow = match LArrow 123 | 124 | rarrow :: Parser TokenStream Unit 125 | rarrow = match RArrow 126 | 127 | lfatArrow :: Parser TokenStream Unit 128 | lfatArrow = match LFatArrow 129 | 130 | rfatArrow :: Parser TokenStream Unit 131 | rfatArrow = match RFatArrow 132 | 133 | colon :: Parser TokenStream Unit 134 | colon = match Colon 135 | 136 | doubleColon :: Parser TokenStream Unit 137 | doubleColon = match DoubleColon 138 | 139 | equals :: Parser TokenStream Unit 140 | equals = match Equals 141 | 142 | pipe :: Parser TokenStream Unit 143 | pipe = match Pipe 144 | 145 | tick :: Parser TokenStream Unit 146 | tick = match Tick 147 | 148 | dot :: Parser TokenStream Unit 149 | dot = match Dot 150 | 151 | comma :: Parser TokenStream Unit 152 | comma = match Comma 153 | 154 | semi :: Parser TokenStream Unit 155 | semi = match Semi 156 | 157 | at :: Parser TokenStream Unit 158 | at = match At 159 | 160 | semiSep :: forall a. Parser TokenStream a -> Parser TokenStream [a] 161 | semiSep p = sepBy p semi 162 | 163 | semiSep1 :: forall a. Parser TokenStream a -> Parser TokenStream [a] 164 | semiSep1 p = sepBy1 p semi 165 | 166 | commaSep :: forall a. Parser TokenStream a -> Parser TokenStream [a] 167 | commaSep p = sepBy p comma 168 | 169 | commaSep1 :: forall a. Parser TokenStream a -> Parser TokenStream [a] 170 | commaSep1 p = sepBy1 p comma 171 | 172 | lname :: Parser TokenStream String 173 | lname = token' "identifier" go 174 | where 175 | go (LName s) = Just s 176 | go _ = Nothing 177 | 178 | reserved :: String -> Parser TokenStream Unit 179 | reserved s = token' (show s) go 180 | where 181 | go (LName s') | s == s' = Just unit 182 | go _ = Nothing 183 | 184 | uname :: Parser TokenStream String 185 | uname = token' "proper name" go 186 | where 187 | go (UName s) = Just s 188 | go _ = Nothing 189 | 190 | uname' :: String -> Parser TokenStream Unit 191 | uname' s = token' (show s) go 192 | where 193 | go (UName s') | s == s' = Just unit 194 | go _ = Nothing 195 | 196 | symbol :: Parser TokenStream String 197 | symbol = token' "symbol" go 198 | where 199 | go (Symbol s) = Just s 200 | go LAngle = Just "<" 201 | go RAngle = Just ">" 202 | go LFatArrow = Just "<=" 203 | go RFatArrow = Just "=>" 204 | go Colon = Just ":" 205 | go Pipe = Just "|" 206 | go Dot = Just "." 207 | go Comma = Just "," 208 | go At = Just "@" 209 | go _ = Nothing 210 | 211 | symbol' :: String -> Parser TokenStream Unit 212 | symbol' s = token' (show s) go 213 | where 214 | go (Symbol s') | s == s' = Just unit 215 | go LAngle | s == "<" = Just unit 216 | go RAngle | s == ">" = Just unit 217 | go LFatArrow | s == "<=" = Just unit 218 | go RFatArrow | s == "=>" = Just unit 219 | go Colon | s == ":" = Just unit 220 | go Pipe | s == "|" = Just unit 221 | go Dot | s == "." = Just unit 222 | go Comma | s == "," = Just unit 223 | go At | s == "@" = Just unit 224 | go _ = Nothing 225 | 226 | stringLiteral :: Parser TokenStream String 227 | stringLiteral = token' "string literal" go 228 | where 229 | go (StringLiteral s) = Just s 230 | go _ = Nothing 231 | 232 | natural :: Parser TokenStream Number 233 | natural = token' "natural number" go 234 | where 235 | go (Natural n) = Just n 236 | go _ = Nothing 237 | 238 | number :: Parser TokenStream Number 239 | number = token' "number" go 240 | where 241 | go (ANumber n) = Just n 242 | go _ = Nothing 243 | 244 | identifier :: Parser TokenStream String 245 | identifier = token' "identifier" go 246 | where 247 | go (LName s) | s `notElem` reservedPsNames = Just s 248 | go _ = Nothing 249 | 250 | -- | 251 | -- Parse an identifier 252 | -- 253 | ident :: Parser TokenStream Ident 254 | ident = (Ident <$> identifier) <|> (Op <$> parens symbol) 255 | 256 | -- | 257 | -- Parse an identifier in backticks or an operator 258 | -- 259 | parseIdentInfix :: Parser TokenStream (Qualified Ident) 260 | parseIdentInfix = between tick tick (parseQualified (Ident <$> lname)) <|> (parseQualified (Op <$> symbol)) 261 | 262 | -- | 263 | -- Parse a proper name 264 | -- 265 | properName :: Parser TokenStream ProperName 266 | properName = ProperName <$> uname 267 | 268 | -- | 269 | -- Parse a module name 270 | -- 271 | moduleName :: Parser TokenStream ModuleName 272 | moduleName = ModuleName <$> (sepBy properName dot) 273 | 274 | notFollowedBy :: forall s a. String -> Parser s a -> Parser s Unit 275 | notFollowedBy name p = try (do 276 | c <- p 277 | fail ("Unexpected " ++ name)) <|> return unit 278 | 279 | -- | 280 | -- Run the first parser, then match the second if possible, applying the specified function on a successful match 281 | -- 282 | augment :: forall s a b. Parser s a -> Parser s b -> (a -> b -> a) -> Parser s a 283 | augment p q f = flip (maybe id $ flip f) <$> p <*> optionMaybe q 284 | 285 | -- | 286 | -- Run the first parser, then match the second zero or more times, applying the specified function for each match 287 | -- 288 | fold :: forall s a b. Parser s a -> Parser s b -> (a -> b -> a) -> Parser s a 289 | fold first more combine = do 290 | a <- first 291 | bs <- many more 292 | return $ foldl combine a bs 293 | 294 | -- | 295 | -- Build a parser from a smaller parser and a list of parsers for postfix operators 296 | -- 297 | buildPostfixParser :: forall s a. [a -> Parser s a] -> Parser s a -> Parser s a 298 | buildPostfixParser fs first = do 299 | a <- first 300 | go a 301 | where 302 | go a = do 303 | maybeA <- optionMaybe $ choice (map (\f -> f a) fs) 304 | case maybeA of 305 | Nothing -> return a 306 | Just a' -> go a' 307 | 308 | -- | 309 | -- Parse a qualified name, i.e. M.name or just name 310 | -- 311 | parseQualified :: forall a. Parser TokenStream a -> Parser TokenStream (Qualified a) 312 | parseQualified parser = part [] 313 | where 314 | part path = (do name <- try (properName <* delimiter) 315 | part (updatePath path name)) 316 | <|> (Qualified (qual path) <$> try parser) 317 | 318 | delimiter :: Parser TokenStream Unit 319 | delimiter = dot <* notFollowedBy "dot" dot 320 | 321 | updatePath :: [ProperName] -> ProperName -> [ProperName] 322 | updatePath path name = path ++ [name] 323 | 324 | qual :: [ProperName] -> Maybe ModuleName 325 | qual path = if null path then Nothing else Just $ ModuleName path 326 | 327 | -- | 328 | -- A parser which returns the current source position 329 | -- 330 | sourcePos :: Parser TokenStream SourcePos 331 | sourcePos = do 332 | ts <- get 333 | case unconsStream ts of 334 | Nothing -> return $ mkSourcePos "" 0 0 335 | Just cons -> return $ mkSourcePos "" cons.head.line cons.head.column 336 | 337 | -- | 338 | -- A parser which returns the comments for the next lexeme 339 | -- 340 | comments :: Parser TokenStream [String] 341 | comments = do 342 | ts <- get 343 | case unconsStream ts of 344 | Nothing -> return [] 345 | Just cons -> return cons.head.comments 346 | -------------------------------------------------------------------------------- /src/Language/PureScript/Parser/Kinds.purs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- 3 | -- Module : Language.PureScript.Parser.Kinds 4 | -- Copyright : (c) Phil Freeman 2013 5 | -- License : MIT 6 | -- 7 | -- Maintainer : Phil Freeman 8 | -- Stability : experimental 9 | -- Portability : 10 | -- 11 | -- | 12 | -- A parser for kinds 13 | -- 14 | ----------------------------------------------------------------------------- 15 | 16 | module Language.PureScript.Parser.Kinds ( 17 | parseKind 18 | ) where 19 | 20 | import Control.Apply 21 | import Control.Lazy 22 | 23 | import Language.PureScript.Kinds 24 | import Language.PureScript.Parser.Lexer 25 | import Language.PureScript.Parser.Common 26 | 27 | import Text.Parsing.Parser 28 | import Text.Parsing.Parser.Combinators 29 | import Text.Parsing.Parser.Expr 30 | 31 | parseStar :: Parser TokenStream Kind 32 | parseStar = const Star <$> symbol' "*" 33 | 34 | parseBang :: Parser TokenStream Kind 35 | parseBang = const Bang <$> symbol' "!" 36 | 37 | -- | 38 | -- Parse a kind 39 | -- 40 | parseKind :: Parser TokenStream Kind 41 | parseKind = fix1 (\parseKind -> 42 | let 43 | parseKindAtom :: Parser TokenStream Kind 44 | parseKindAtom = choice 45 | [ parseStar 46 | , parseBang 47 | , parens parseKind ] 48 | 49 | in buildExprParser operators parseKindAtom) 50 | where 51 | operators = [ [ Prefix (symbol' "#" *> return Row) ] 52 | , [ Infix (rarrow *> return FunKind) AssocRight ] ] 53 | -------------------------------------------------------------------------------- /src/Language/PureScript/Parser/Types.purs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- 3 | -- Module : Language.PureScript.Parser.Types 4 | -- Copyright : (c) Phil Freeman 2013 5 | -- License : MIT 6 | -- 7 | -- Maintainer : Phil Freeman 8 | -- Stability : experimental 9 | -- Portability : 10 | ----------------------------------------------------------------------------- 11 | -- | 12 | -- Parsers for types 13 | -- 14 | ----------------------------------------------------------------------------- 15 | 16 | module Language.PureScript.Parser.Types ( 17 | parseType, 18 | parseTypeAtom 19 | ) where 20 | 21 | import Control.Alt 22 | import Control.Alternative 23 | import Control.Apply 24 | import Control.Lazy 25 | import Control.Monad (when, unless) 26 | 27 | import Data.Maybe 28 | import Data.Tuple 29 | import Data.Array (map) 30 | import Data.Foldable (elem) 31 | 32 | import Language.PureScript.Types 33 | import Language.PureScript.Parser.Lexer 34 | import Language.PureScript.Parser.Common 35 | import Language.PureScript.Environment 36 | import Language.PureScript.Keywords 37 | 38 | import Text.Parsing.Parser 39 | import Text.Parsing.Parser.Combinators 40 | import Text.Parsing.Parser.Expr 41 | 42 | parseType :: Parser TokenStream Type 43 | parseType = snd parseType_ 44 | 45 | parseTypeAtom :: Parser TokenStream Type 46 | parseTypeAtom = fst parseType_ 47 | 48 | parseType_ :: Tuple (Parser TokenStream Type) (Parser TokenStream Type) 49 | parseType_ = fix $ \(Tuple atom p) -> 50 | let 51 | -- | 52 | -- Parse a type as it appears in e.g. a data constructor 53 | -- 54 | atom' :: Parser TokenStream Type 55 | atom' = choice (map try 56 | [ parseNumber 57 | , parseString 58 | , parseBoolean 59 | , parseArray 60 | , parseArrayOf 61 | , parseFunction 62 | , parseObject 63 | , parseTypeVariable 64 | , parseTypeConstructor 65 | , parseForAll 66 | , parens (parseRow true) 67 | , parens p ]) 68 | 69 | parseNumber :: Parser TokenStream Type 70 | parseNumber = const tyNumber <$> uname' "Number" 71 | 72 | parseString :: Parser TokenStream Type 73 | parseString = const tyString <$> uname' "String" 74 | 75 | parseBoolean :: Parser TokenStream Type 76 | parseBoolean = const tyBoolean <$> uname' "Boolean" 77 | 78 | parseArray :: Parser TokenStream Type 79 | parseArray = squares $ return tyArray 80 | 81 | parseArrayOf :: Parser TokenStream Type 82 | parseArrayOf = squares $ TypeApp tyArray <$> p 83 | 84 | parseFunction :: Parser TokenStream Type 85 | parseFunction = parens $ try rarrow *> return tyFunction 86 | 87 | parseObject :: Parser TokenStream Type 88 | parseObject = braces $ TypeApp tyObject <$> parseRow false 89 | 90 | parseTypeVariable :: Parser TokenStream Type 91 | parseTypeVariable = do 92 | ident <- lname 93 | when (ident `elem` reservedTypeNames) $ fail ("Unexpected " ++ show ident) 94 | return $ TypeVar ident 95 | 96 | parseTypeConstructor :: Parser TokenStream Type 97 | parseTypeConstructor = TypeConstructor <$> parseQualified properName 98 | 99 | parseForAll :: Parser TokenStream Type 100 | parseForAll = mkForAll <$> (try (reserved "forall") *> some lname <* dot) 101 | <*> parseConstrainedType 102 | 103 | parseConstrainedType :: Parser TokenStream Type 104 | parseConstrainedType = do 105 | constraints <- optionMaybe <<< try $ do 106 | constraints <- parens <<< commaSep1 $ do 107 | className <- parseQualified properName 108 | ty <- many atom 109 | return (Tuple className ty) 110 | rfatArrow 111 | return constraints 112 | ty <- p 113 | return $ maybe ty (flip ConstrainedType ty) constraints 114 | 115 | parseNameAndType :: forall t. Parser TokenStream t -> Parser TokenStream (Tuple String t) 116 | parseNameAndType p = Tuple <$> ((lname <|> stringLiteral) <* doubleColon) <*> p 117 | 118 | parseRowEnding :: Parser TokenStream Type 119 | parseRowEnding = option REmpty (TypeVar <$> (pipe *> lname)) 120 | 121 | parseRow :: Boolean -> Parser TokenStream Type 122 | parseRow nonEmpty = (curry rowFromList <$> many' (parseNameAndType p) <*> parseRowEnding) "row" 123 | where many' = if nonEmpty then commaSep1 else commaSep 124 | 125 | in Tuple atom' (buildExprParser operators atom' "type") 126 | where 127 | operators = [ [ Infix (return TypeApp) AssocLeft ] 128 | , [ Infix (try rarrow *> return function) AssocRight ] ] 129 | -------------------------------------------------------------------------------- /src/Language/PureScript/Pos.purs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- 3 | -- Module : Language.PureScript.Pos 4 | -- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors 5 | -- License : MIT 6 | -- 7 | -- Maintainer : Phil Freeman 8 | -- Stability : experimental 9 | -- Portability : 10 | -- 11 | -- | Source position information 12 | -- 13 | ----------------------------------------------------------------------------- 14 | 15 | module Language.PureScript.Pos where 16 | 17 | -- | 18 | -- Source position information 19 | -- 20 | data SourcePos = SourcePos { name :: String, line :: Number, column :: Number } 21 | 22 | mkSourcePos :: String -> Number -> Number -> SourcePos 23 | mkSourcePos name line column = SourcePos { name: name, line: line, column: column } 24 | 25 | instance showSourcePos :: Show SourcePos where 26 | show (SourcePos sp) = sp.name ++ 27 | " line " ++ show sp.line ++ 28 | ", column " ++ show sp.column -------------------------------------------------------------------------------- /src/Language/PureScript/Prelude.purs: -------------------------------------------------------------------------------- 1 | module Language.PureScript.Prelude where 2 | 3 | import Language.PureScript (procFilePath) 4 | import Node.Path 5 | 6 | preludeBaseDir :: String 7 | preludeBaseDir = join [(dirname procFilePath), "../prelude/"] 8 | 9 | preludeFiles :: [String] 10 | preludeFiles = 11 | [ preludeBaseDir ++ "Prelude.purs" 12 | , preludeBaseDir ++ "Prelude/Unsafe.purs" 13 | , preludeBaseDir ++ "Control/Monad/Eff.purs" 14 | , preludeBaseDir ++ "Control/Monad/Eff/Unsafe.purs" 15 | , preludeBaseDir ++ "Control/Monad/ST.purs" 16 | , preludeBaseDir ++ "Data/Eq.purs" 17 | , preludeBaseDir ++ "Data/Function.purs" 18 | , preludeBaseDir ++ "Debug/Trace.purs" 19 | ] 20 | -------------------------------------------------------------------------------- /src/Language/PureScript/Pretty/Common.purs: -------------------------------------------------------------------------------- 1 | module Language.PureScript.Pretty.Common where 2 | 3 | import Control.Monad.State.Trans 4 | import Control.Monad.State.Class 5 | import Data.Array (map) 6 | import Data.Foldable (elem) 7 | import Data.Maybe 8 | import Data.Monoid 9 | import Data.Traversable (traverse) 10 | import Data.String (joinWith) 11 | import Data.String.Unsafe (charAt) 12 | 13 | import Language.PureScript.Keywords 14 | 15 | -- | 16 | -- Wrap a string in parentheses 17 | -- 18 | parens :: String -> String 19 | parens s = "(" ++ s ++ ")" 20 | 21 | data PrinterState = PrinterState { indent :: Number } 22 | 23 | instance showPrinterState :: Show PrinterState where 24 | show (PrinterState { indent = i }) = "PrinterState { indent: " ++ show i ++ " }" 25 | 26 | instance eqPrinterState :: Eq PrinterState where 27 | (==) (PrinterState { indent = i1 }) (PrinterState { indent = i2 }) = i1 == i2 28 | (/=) x y = not (x == y) 29 | 30 | instance ordPrinterState :: Ord PrinterState where 31 | compare (PrinterState { indent = i1 }) (PrinterState { indent = i2 }) = compare i1 i2 32 | 33 | -- | 34 | -- Number of characters per identation level 35 | -- 36 | blockIndent :: Number 37 | blockIndent = 4 38 | 39 | -- | 40 | -- Pretty print with a new indentation level 41 | -- 42 | withIndent :: StateT PrinterState Maybe String -> StateT PrinterState Maybe String 43 | withIndent action = do 44 | modify $ \(PrinterState st) -> PrinterState $ st { indent = st.indent + blockIndent } 45 | result <- action 46 | modify $ \(PrinterState st) -> PrinterState $ st { indent = st.indent - blockIndent } 47 | return result 48 | 49 | -- | 50 | -- Get the current indentation level 51 | -- 52 | currentIndent :: StateT PrinterState Maybe String 53 | currentIndent = do 54 | PrinterState { indent = current } <- get 55 | return $ replicate current " " 56 | where 57 | replicate 0 x = "" 58 | replicate n x = x ++ replicate (n - 1) x 59 | 60 | -- | 61 | -- Print many lines 62 | -- 63 | prettyPrintMany :: forall a. (a -> StateT PrinterState Maybe String) -> [a] -> StateT PrinterState Maybe String 64 | prettyPrintMany f xs = do 65 | ss <- traverse f xs 66 | indentString <- currentIndent 67 | return $ joinWith "\n" $ map ((++) indentString) ss 68 | 69 | -- | 70 | -- Prints an object key, escaping reserved names. 71 | -- 72 | prettyPrintObjectKey :: String -> String 73 | prettyPrintObjectKey s | s `elem` reservedPsNames = show s 74 | prettyPrintObjectKey s | charAt 0 s `elem` opChars = show s 75 | prettyPrintObjectKey s = s 76 | 77 | runPretty :: forall a b. (a -> Maybe b) -> a -> b 78 | runPretty p x = case p x of 79 | Just x -> x 80 | -------------------------------------------------------------------------------- /src/Language/PureScript/Pretty/JS.purs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- 3 | -- Module : Language.PureScript.Pretty.JS 4 | -- Copyright : (c) Phil Freeman 2013-14 5 | -- License : MIT 6 | -- 7 | -- Maintainer : Phil Freeman 8 | -- Stability : experimental 9 | -- Portability : 10 | -- 11 | -- | 12 | -- Pretty printer for the Javascript AST 13 | -- 14 | ----------------------------------------------------------------------------- 15 | 16 | module Language.PureScript.Pretty.JS ( 17 | prettyPrintJS 18 | ) where 19 | 20 | import Data.Array 21 | import Data.Maybe 22 | import Data.Maybe.Unsafe 23 | import Data.Tuple 24 | import Data.Either 25 | import Data.Traversable (for, traverse, sequence) 26 | 27 | import qualified Data.String as S 28 | 29 | import Text.Pretty.PatternArrows 30 | 31 | import Control.Arrow ((<+>)) 32 | import Control.Apply 33 | 34 | import Control.Monad.Trans 35 | 36 | import Control.Monad.State 37 | import Control.Monad.State.Trans 38 | 39 | import Language.PureScript.Pretty.Common 40 | import Language.PureScript.CodeGen.Common (isIdent) 41 | import Language.PureScript.CodeGen.JS.AST 42 | 43 | foreign import string 44 | "function string(s) {\ 45 | \ return JSON.stringify(s);\ 46 | \}" :: String -> String 47 | 48 | literals :: Unit -> Pattern PrinterState JS String 49 | literals _ = mkPattern' match 50 | where 51 | match :: JS -> StateT PrinterState Maybe String 52 | match (JSNumericLiteral n) = return $ show n 53 | match (JSStringLiteral s) = return $ string s 54 | match (JSBooleanLiteral true) = return "true" 55 | match (JSBooleanLiteral false) = return "false" 56 | match (JSArrayLiteral xs) = S.joinWith "" <$> sequence 57 | [ return "[ " 58 | , S.joinWith ", " <$> for xs prettyPrintJS' 59 | , return " ]" 60 | ] 61 | match (JSObjectLiteral []) = return "{}" 62 | match (JSObjectLiteral ps) = S.joinWith "" <$> sequence 63 | [ return "{\n" 64 | , withIndent $ do 65 | jss <- for ps $ \(Tuple key value) -> (<$>) (\s -> (objectPropertyToString key ++ ": ") ++ s) <<< prettyPrintJS' $ value 66 | indentString <- currentIndent 67 | return $ S.joinWith ", \n" $ map (\s -> indentString ++ s) jss 68 | , return "\n" 69 | , currentIndent 70 | , return "}" 71 | ] 72 | where 73 | objectPropertyToString :: String -> String 74 | objectPropertyToString s | isIdent s = s 75 | objectPropertyToString s = show s 76 | match (JSBlock sts) = S.joinWith "" <$> sequence 77 | [ return "{\n" 78 | , withIndent $ prettyStatements sts 79 | , return "\n" 80 | , currentIndent 81 | , return "}" 82 | ] 83 | match (JSVar ident) = return ident 84 | match (JSVariableIntroduction ident value) = S.joinWith "" <$> sequence 85 | [ return "var " 86 | , return ident 87 | , maybe (return "") ((<$>) (\s -> " = " ++ s) <<< prettyPrintJS') value 88 | ] 89 | match (JSAssignment target value) = S.joinWith "" <$> sequence 90 | [ prettyPrintJS' target 91 | , return " = " 92 | , prettyPrintJS' value 93 | ] 94 | match (JSWhile cond sts) = S.joinWith "" <$> sequence 95 | [ return "while (" 96 | , prettyPrintJS' cond 97 | , return ") " 98 | , prettyPrintJS' sts 99 | ] 100 | match (JSFor ident start end sts) = S.joinWith "" <$> sequence 101 | [ return $ "for (var " ++ ident ++ " = " 102 | , prettyPrintJS' start 103 | , return $ "; " ++ ident ++ " < " 104 | , prettyPrintJS' end 105 | , return $ "; " ++ ident ++ "++) " 106 | , prettyPrintJS' sts 107 | ] 108 | match (JSForIn ident obj sts) = S.joinWith "" <$> sequence 109 | [ return $ "for (var " ++ ident ++ " in " 110 | , prettyPrintJS' obj 111 | , return ") " 112 | , prettyPrintJS' sts 113 | ] 114 | match (JSIfElse cond thens elses) = S.joinWith "" <$> sequence 115 | [ return "if (" 116 | , prettyPrintJS' cond 117 | , return ") " 118 | , prettyPrintJS' thens 119 | , maybe (return "") ((<$>) (\s -> " else " ++ s) <<< prettyPrintJS') elses 120 | ] 121 | match (JSReturn value) = S.joinWith "" <$> sequence 122 | [ return "return " 123 | , prettyPrintJS' value 124 | ] 125 | match (JSThrow value) = S.joinWith "" <$> sequence 126 | [ return "throw " 127 | , prettyPrintJS' value 128 | ] 129 | match (JSBreak lbl) = return $ "break " ++ lbl 130 | match (JSContinue lbl) = return $ "continue " ++ lbl 131 | match (JSLabel lbl js) = S.joinWith "" <$> sequence 132 | [ return $ lbl ++ ": " 133 | , prettyPrintJS' js 134 | ] 135 | match (JSRaw js) = return js 136 | match _ = lift Nothing 137 | 138 | conditional :: Pattern PrinterState JS (Tuple (Tuple JS JS) JS) 139 | conditional = mkPattern match 140 | where 141 | match (JSConditional cond th el) = Just (Tuple (Tuple th el) cond) 142 | match _ = Nothing 143 | 144 | accessor :: Unit -> Pattern PrinterState JS (Tuple String JS) 145 | accessor _ = mkPattern match 146 | where 147 | match (JSAccessor prop val) = Just (Tuple prop val) 148 | match _ = Nothing 149 | 150 | indexer :: Unit -> Pattern PrinterState JS (Tuple String JS) 151 | indexer _ = mkPattern' match 152 | where 153 | match (JSIndexer index val) = Tuple <$> prettyPrintJS' index <*> pure val 154 | match _ = lift Nothing 155 | 156 | lam :: Pattern PrinterState JS (Tuple (Tuple (Maybe String) [String]) JS) 157 | lam = mkPattern match 158 | where 159 | match (JSFunction name args ret) = Just (Tuple (Tuple name args) ret) 160 | match _ = Nothing 161 | 162 | app :: Unit -> Pattern PrinterState JS (Tuple String JS) 163 | app _ = mkPattern' match 164 | where 165 | match (JSApp val args) = do 166 | jss <- traverse prettyPrintJS' args 167 | return (Tuple (S.joinWith ", " jss) val) 168 | match _ = lift Nothing 169 | 170 | typeOf :: Pattern PrinterState JS (Tuple Unit JS) 171 | typeOf = mkPattern match 172 | where 173 | match (JSTypeOf val) = Just (Tuple unit val) 174 | match _ = Nothing 175 | 176 | unary :: UnaryOperator -> String -> Operator PrinterState JS String 177 | unary op str = Operator (wrap match (++)) 178 | where 179 | match :: Pattern PrinterState JS (Tuple String JS) 180 | match = mkPattern match' 181 | where 182 | match' (JSUnary op' val) | op' == op = Just (Tuple str val) 183 | match' _ = Nothing 184 | 185 | binary :: BinaryOperator -> String -> Operator PrinterState JS String 186 | binary op str = Operator (assocR match (\v1 v2 -> v1 ++ " " ++ str ++ " " ++ v2)) 187 | where 188 | match :: Pattern PrinterState JS (Tuple JS JS) 189 | match = mkPattern match' 190 | where 191 | match' (JSBinary op' v1 v2) | op' == op = Just (Tuple v1 v2) 192 | match' _ = Nothing 193 | 194 | prettyStatements :: [JS] -> StateT PrinterState Maybe String 195 | prettyStatements sts = do 196 | jss <- for sts prettyPrintJS' 197 | indentString <- currentIndent 198 | return $ S.joinWith "\n" $ map (\s -> indentString ++ s ++ ";") jss 199 | 200 | -- | 201 | -- Generate a pretty-printed string representing a Javascript expression 202 | -- 203 | prettyPrintJS1 :: JS -> String 204 | prettyPrintJS1 js = runPretty (flip evalStateT (PrinterState { indent: 0 }) <<< prettyPrintJS') js 205 | 206 | -- | 207 | -- Generate a pretty-printed string representing a collection of Javascript expressions at the same indentation level 208 | -- 209 | prettyPrintJS :: [JS] -> String 210 | prettyPrintJS jss = runPretty (flip evalStateT (PrinterState { indent: 0 }) <<< prettyStatements) jss 211 | 212 | -- | 213 | -- Generate an indented, pretty-printed string representing a Javascript expression 214 | -- 215 | prettyPrintJS' :: JS -> StateT PrinterState Maybe String 216 | prettyPrintJS' js = runPattern matchValue js 217 | where 218 | matchValue :: Pattern PrinterState JS String 219 | matchValue = fix $ \p -> buildPrettyPrinter operators (literals unit <+> (<$>) parens p) 220 | operators :: OperatorTable PrinterState JS String 221 | operators = 222 | OperatorTable [ [ Operator (wrap (accessor unit) $ \prop val -> val ++ "." ++ prop) ] 223 | , [ Operator (wrap (indexer unit) $ \index val -> val ++ "[" ++ index ++ "]") ] 224 | , [ Operator (wrap (app unit) $ \args val -> val ++ "(" ++ args ++ ")") ] 225 | , [ Operator (wrap lam $ \(Tuple name args) ret -> "function " 226 | ++ fromMaybe "" name 227 | ++ "(" ++ S.joinWith ", " args ++ ") " 228 | ++ ret) ] 229 | , [ binary LessThan "<" ] 230 | , [ binary LessThanOrEqualTo "<=" ] 231 | , [ binary GreaterThan ">" ] 232 | , [ binary GreaterThanOrEqualTo ">=" ] 233 | , [ Operator (wrap typeOf $ \_ s -> "typeof " ++ s) ] 234 | , [ unary Not "!" ] 235 | , [ unary BitwiseNot "~" ] 236 | , [ unary Negate "-" ] 237 | , [ unary Positive "+" ] 238 | , [ binary Multiply "*" ] 239 | , [ binary Divide "/" ] 240 | , [ binary Modulus "%" ] 241 | , [ binary Add "+" ] 242 | , [ binary Subtract "-" ] 243 | , [ binary ShiftLeft "<<" ] 244 | , [ binary ShiftRight ">>" ] 245 | , [ binary ZeroFillShiftRight ">>>" ] 246 | , [ binary EqualTo "===" ] 247 | , [ binary NotEqualTo "!==" ] 248 | , [ binary BitwiseAnd "&" ] 249 | , [ binary BitwiseXor "^" ] 250 | , [ binary BitwiseOr "|" ] 251 | , [ binary And "&&" ] 252 | , [ binary Or "||" ] 253 | , [ Operator (wrap conditional $ \(Tuple th el) cond -> cond ++ " ? " ++ prettyPrintJS1 th ++ " : " ++ prettyPrintJS1 el) ] 254 | ] -------------------------------------------------------------------------------- /src/Language/PureScript/Pretty/Kinds.purs: -------------------------------------------------------------------------------- 1 | module Language.PureScript.Pretty.Kinds (prettyPrintKind) where 2 | 3 | import Control.Arrow 4 | import Data.Maybe 5 | import Data.Tuple 6 | import Text.Pretty.PatternArrows 7 | 8 | import Language.PureScript.Kinds 9 | import Language.PureScript.Pretty.Common 10 | 11 | typeLiterals :: Pattern Unit Kind String 12 | typeLiterals = mkPattern match 13 | where 14 | match Star = Just "*" 15 | match Bang = Just "!" 16 | match (KUnknown u) = Just $ "u" ++ show u 17 | match _ = Nothing 18 | 19 | matchRow :: Pattern Unit Kind (Tuple Unit Kind) 20 | matchRow = mkPattern match 21 | where 22 | match (Row k) = Just (Tuple unit k) 23 | match _ = Nothing 24 | 25 | funKind :: Pattern Unit Kind (Tuple Kind Kind) 26 | funKind = mkPattern match 27 | where 28 | match (FunKind arg ret) = Just (Tuple arg ret) 29 | match _ = Nothing 30 | 31 | -- | 32 | -- Generate a pretty-printed string representing a Kind 33 | -- 34 | prettyPrintKind :: Kind -> String 35 | prettyPrintKind = runPretty $ pattern matchKind unit 36 | where 37 | matchKind :: Pattern Unit Kind String 38 | matchKind = fix $ \p -> buildPrettyPrinter operators (typeLiterals <+> (parens <$> p)) 39 | operators :: OperatorTable Unit Kind String 40 | operators = 41 | OperatorTable [ [ Operator (wrap matchRow $ \_ k -> "# " ++ k) ] 42 | , [ Operator (assocR funKind $ \arg ret -> arg ++ " -> " ++ ret) ] ] 43 | -------------------------------------------------------------------------------- /src/Language/PureScript/Pretty/Types.purs: -------------------------------------------------------------------------------- 1 | module Language.PureScript.Pretty.Types 2 | ( prettyPrintType 3 | , prettyPrintTypeAtom 4 | , prettyPrintRow 5 | ) where 6 | 7 | import Control.Arrow ((<+>)) 8 | import Data.Array (map) 9 | import Data.Maybe (Maybe(..), fromMaybe) 10 | import Data.String (joinWith) 11 | import Data.Tuple 12 | import Text.Pretty.PatternArrows 13 | 14 | import Language.PureScript.Environment 15 | import Language.PureScript.Pretty.Common 16 | import Language.PureScript.Types 17 | import Language.PureScript.Names 18 | 19 | typeLiterals :: Unit -> Pattern Unit Type String 20 | typeLiterals _ = mkPattern match 21 | where 22 | match (TypeVar var) = Just var 23 | match (PrettyPrintObject row) = Just $ "{ " ++ prettyPrintRow row ++ " }" 24 | match (PrettyPrintArray ty) = Just $ "[" ++ prettyPrintType ty ++ "]" 25 | match (TypeConstructor ctor) = Just $ show ctor 26 | match (TUnknown u) = Just $ "u" ++ show u 27 | match (Skolem name s _) = Just $ name ++ show s 28 | match (ConstrainedType deps ty) = Just $ "(" ++ joinWith ", " (map (\(Tuple pn ty') -> show pn ++ " " ++ joinWith " " (map prettyPrintTypeAtom ty')) deps) ++ ") => " ++ prettyPrintType ty 29 | match (SaturatedTypeSynonym name args) = Just $ show name ++ "<" ++ joinWith "," (map prettyPrintTypeAtom args) ++ ">" 30 | match REmpty = Just "()" 31 | match row@(RCons _ _ _) = Just $ "(" ++ prettyPrintRow row ++ ")" 32 | match _ = Nothing 33 | 34 | typeApp :: Pattern Unit Type (Tuple Type Type) 35 | typeApp = mkPattern match 36 | where 37 | match (TypeApp f x) = Just (Tuple f x) 38 | match _ = Nothing 39 | 40 | appliedFunction :: Pattern Unit Type (Tuple Type Type) 41 | appliedFunction = mkPattern match 42 | where 43 | match (PrettyPrintFunction arg ret) = Just (Tuple arg ret) 44 | match _ = Nothing 45 | 46 | insertPlaceholders :: Type -> Type 47 | insertPlaceholders = everywhereOnTypesTopDown convertForAlls <<< everywhereOnTypes convert 48 | where 49 | convert (TypeApp (TypeApp f arg) ret) | f == tyFunction = PrettyPrintFunction arg ret 50 | convert (TypeApp a el) | a == tyArray = PrettyPrintArray el 51 | convert (TypeApp o r) | o == tyObject = PrettyPrintObject r 52 | convert other = other 53 | convertForAlls (ForAll ident ty _) = go [ident] ty 54 | where 55 | go idents (ForAll ident' ty' _) = go (ident' : idents) ty' 56 | go idents other = PrettyPrintForAll idents other 57 | convertForAlls other = other 58 | 59 | matchTypeAtom :: Unit -> Pattern Unit Type String 60 | matchTypeAtom _ = typeLiterals unit <+> (parens <$> matchType unit) 61 | 62 | matchType :: Unit -> Pattern Unit Type String 63 | matchType _ = fix $ \p -> buildPrettyPrinter operators (typeLiterals unit <+> (parens <$> p)) 64 | where 65 | operators :: OperatorTable Unit Type String 66 | operators = 67 | OperatorTable [ [ Operator (assocL typeApp $ \f x -> f ++ " " ++ x) ] 68 | , [ Operator (assocR appliedFunction $ \arg ret -> arg ++ " -> " ++ ret) ] 69 | , [ Operator (wrap forall_ $ \idents ty -> "forall " ++ joinWith " " idents ++ ". " ++ ty) ] 70 | ] 71 | 72 | forall_ :: Pattern Unit Type (Tuple [String] Type) 73 | forall_ = mkPattern match 74 | where 75 | match (PrettyPrintForAll idents ty) = Just (Tuple idents ty) 76 | match _ = Nothing 77 | 78 | -- | 79 | -- Generate a pretty-printed string representing a Type, as it should appear inside parentheses 80 | -- 81 | prettyPrintTypeAtom :: Type -> String 82 | prettyPrintTypeAtom p = runPretty (pattern (matchTypeAtom unit) unit <<< insertPlaceholders) p 83 | 84 | -- | 85 | -- Generate a pretty-printed string representing a Type 86 | -- 87 | prettyPrintType :: Type -> String 88 | prettyPrintType p = runPretty (pattern (matchType unit) unit <<< insertPlaceholders) p 89 | 90 | -- | 91 | -- Generate a pretty-printed string representing a Row 92 | -- 93 | prettyPrintRow :: Type -> String 94 | prettyPrintRow t = (\(Tuple tys rest) -> joinWith ", " (map (uncurry nameAndTypeToPs) tys) ++ tailToPs rest) $ toList [] t 95 | where 96 | nameAndTypeToPs :: String -> Type -> String 97 | nameAndTypeToPs name ty = prettyPrintObjectKey name ++ " :: " ++ prettyPrintType ty 98 | tailToPs :: Type -> String 99 | tailToPs REmpty = "" 100 | tailToPs other = " | " ++ prettyPrintType other 101 | toList :: [Tuple String Type] -> Type -> (Tuple [Tuple String Type] Type) 102 | toList tys (RCons name ty row) = toList ((Tuple name ty):tys) row 103 | toList tys r = (Tuple tys r) 104 | -------------------------------------------------------------------------------- /src/Language/PureScript/Pretty/Values.purs: -------------------------------------------------------------------------------- 1 | module Language.PureScript.Pretty.Values 2 | ( prettyPrintValue 3 | , prettyPrintBinder 4 | ) where 5 | 6 | import Control.Apply 7 | import Control.Arrow ((<+>)) 8 | import Control.Arrow.Kleisli (runKleisli) 9 | import Control.Monad.State 10 | import Control.Monad.State.Trans 11 | import Data.Array (map) 12 | import Data.Either (Either(..), either) 13 | import Data.Maybe (Maybe(..), fromMaybe, maybe) 14 | import Data.String (joinWith) 15 | import Data.Traversable (sequence, for) 16 | import Data.Tuple 17 | import Text.Pretty.PatternArrows 18 | 19 | import Language.PureScript.Names 20 | import Language.PureScript.Declarations 21 | import Language.PureScript.Pretty.Common 22 | import Language.PureScript.Pretty.Types (prettyPrintType) 23 | 24 | literals :: Unit -> Pattern PrinterState Value String 25 | literals _ = mkPattern' match 26 | where 27 | match :: Value -> StateT PrinterState Maybe String 28 | match (NumericLiteral n) = return $ show n 29 | match (StringLiteral s) = return $ show s 30 | match (BooleanLiteral true) = return "true" 31 | match (BooleanLiteral false) = return "false" 32 | match (ArrayLiteral xs) = joinWith "" <$> sequence 33 | [ return "[ " 34 | , withIndent $ prettyPrintMany prettyPrintValue' xs 35 | , return " ]" 36 | ] 37 | match (ObjectLiteral []) = return "{}" 38 | match (ObjectLiteral ps) = joinWith "" <$> sequence 39 | [ return "{\n" 40 | , withIndent $ prettyPrintMany prettyPrintObjectProperty ps 41 | , return "\n" 42 | , currentIndent 43 | , return "}" 44 | ] 45 | match (Constructor name) = return $ show name 46 | match (Case values binders) = joinWith "" <$> sequence 47 | [ return "case " 48 | , joinWith " " <$> for values prettyPrintValue' 49 | , return " of\n" 50 | , withIndent $ prettyPrintMany prettyPrintCaseAlternative binders 51 | , currentIndent 52 | ] 53 | match (Let ds val) = joinWith "" <$> sequence 54 | [ return "let\n" 55 | , withIndent $ prettyPrintMany prettyPrintDeclaration ds 56 | , return "\n" 57 | , currentIndent 58 | , return "in " 59 | , prettyPrintValue' val 60 | ] 61 | match (Var ident) = return $ show ident 62 | match (Do els) = joinWith "" <$> sequence 63 | [ return "do " 64 | , withIndent $ prettyPrintMany prettyPrintDoNotationElement els 65 | , currentIndent 66 | ] 67 | match (TypeClassDictionary _ _ _) = return "<>" 68 | match (SuperClassDictionary _ _) = return "<>" 69 | match (TypedValue _ val _) = prettyPrintValue' val 70 | match (PositionedValue _ val) = prettyPrintValue' val 71 | match _ = return "" 72 | 73 | prettyPrintDeclaration :: Declaration -> StateT PrinterState Maybe String 74 | prettyPrintDeclaration (TypeDeclaration ident ty) = return $ show ident ++ " :: " ++ prettyPrintType ty 75 | prettyPrintDeclaration (ValueDeclaration ident _ [] Nothing val) = joinWith "" <$> sequence 76 | [ return $ show ident ++ " = " 77 | , prettyPrintValue' val 78 | ] 79 | prettyPrintDeclaration (PositionedDeclaration _ d) = prettyPrintDeclaration d 80 | 81 | prettyPrintCaseAlternative :: CaseAlternative -> StateT PrinterState Maybe String 82 | prettyPrintCaseAlternative (CaseAlternative { binders = binders, guard = grd, result = val }) = 83 | joinWith "" <$> sequence 84 | [ joinWith ", " <$> for binders prettyPrintBinder' 85 | , maybe (return "") ((<$>) ((++) "| ") <<< prettyPrintValue') grd 86 | , return " -> " 87 | , prettyPrintValue' val 88 | ] 89 | 90 | prettyPrintDoNotationElement :: DoNotationElement -> StateT PrinterState Maybe String 91 | prettyPrintDoNotationElement (DoNotationValue val) = 92 | prettyPrintValue' val 93 | prettyPrintDoNotationElement (DoNotationBind binder val) = 94 | joinWith "" <$> sequence 95 | [ prettyPrintBinder' binder 96 | , return " <- " 97 | , prettyPrintValue' val 98 | ] 99 | prettyPrintDoNotationElement (DoNotationLet ds) = 100 | joinWith "" <$> sequence 101 | [ return "let " 102 | , withIndent $ prettyPrintMany prettyPrintDeclaration ds 103 | ] 104 | prettyPrintDoNotationElement (PositionedDoNotationElement _ el) = prettyPrintDoNotationElement el 105 | 106 | ifThenElse :: Pattern PrinterState Value (Tuple (Tuple Value Value) Value) 107 | ifThenElse = mkPattern match 108 | where 109 | match (IfThenElse cond th el) = Just (Tuple (Tuple th el) cond) 110 | match _ = Nothing 111 | 112 | accessor :: Pattern PrinterState Value (Tuple String Value) 113 | accessor = mkPattern match 114 | where 115 | match (Accessor prop val) = Just (Tuple prop val) 116 | match _ = Nothing 117 | 118 | objectUpdate :: Unit -> Pattern PrinterState Value (Tuple [String] Value) 119 | objectUpdate _ = mkPattern match 120 | where 121 | match (ObjectUpdate o ps) = Just (Tuple (flip map ps $ \(Tuple key val) -> key ++ " = " ++ prettyPrintValue val) o) 122 | match _ = Nothing 123 | 124 | app :: Unit -> Pattern PrinterState Value (Tuple String Value) 125 | app _ = mkPattern match 126 | where 127 | match (App val arg) = Just (Tuple (prettyPrintValue arg) val) 128 | match _ = Nothing 129 | 130 | lam :: Pattern PrinterState Value (Tuple String Value) 131 | lam = mkPattern match 132 | where 133 | match (Abs (Left arg) val) = Just (Tuple (show arg) val) 134 | match _ = Nothing 135 | 136 | -- | 137 | -- Generate a pretty-printed string representing an expression 138 | -- 139 | prettyPrintValue :: Value -> String 140 | prettyPrintValue p = runPretty (flip evalStateT (PrinterState { indent: 0 }) <<< prettyPrintValue') p 141 | 142 | prettyPrintValue' :: Value -> StateT PrinterState Maybe String 143 | prettyPrintValue' v = runPattern matchValue v 144 | where 145 | matchValue :: Pattern PrinterState Value String 146 | matchValue = fix $ \p -> buildPrettyPrinter operators (literals unit <+> (parens <$> p)) 147 | operators :: OperatorTable PrinterState Value String 148 | operators = 149 | OperatorTable [ [ Operator (wrap accessor $ \prop val -> val ++ "." ++ prop) ] 150 | , [ Operator (wrap (objectUpdate unit) $ \ps val -> val ++ "{ " ++ joinWith ", " ps ++ " }") ] 151 | , [ Operator (wrap (app unit) $ \arg val -> val ++ "(" ++ arg ++ ")") ] 152 | , [ Operator (split lam $ \arg val -> "\\" ++ arg ++ " -> " ++ prettyPrintValue val) ] 153 | , [ Operator (wrap ifThenElse $ \(Tuple th el) cond -> "if " ++ cond ++ " then " ++ prettyPrintValue th ++ " else " ++ prettyPrintValue el) ] 154 | ] 155 | 156 | prettyPrintBinderAtom :: Unit -> Pattern PrinterState Binder String 157 | prettyPrintBinderAtom _ = mkPattern' match 158 | where 159 | match :: Binder -> StateT PrinterState Maybe String 160 | match NullBinder = return "_" 161 | match (StringBinder str) = return $ show str 162 | match (NumberBinder num) = return $ show num 163 | match (BooleanBinder true) = return "true" 164 | match (BooleanBinder false) = return "false" 165 | match (VarBinder ident) = return $ show ident 166 | match (ConstructorBinder ctor args) = joinWith "" <$> sequence 167 | [ return $ show ctor ++ " " 168 | , joinWith " " <$> for args match 169 | ] 170 | match (ObjectBinder bs) = joinWith "" <$> sequence 171 | [ return "{\n" 172 | , withIndent $ prettyPrintMany prettyPrintObjectPropertyBinder bs 173 | , currentIndent 174 | , return "}" 175 | ] 176 | match (ArrayBinder bs) = joinWith "" <$> sequence 177 | [ return "[" 178 | , joinWith " " <$> for bs prettyPrintBinder' 179 | , return "]" 180 | ] 181 | match (NamedBinder ident binder) = ((++) (show ident ++ "@")) <$> prettyPrintBinder' binder 182 | match (PositionedBinder _ binder) = prettyPrintBinder' binder 183 | match _ = return "" 184 | 185 | -- | 186 | -- Generate a pretty-printed string representing a Binder 187 | -- 188 | prettyPrintBinder :: Binder -> String 189 | prettyPrintBinder b = runPretty (flip evalStateT (PrinterState { indent: 0 }) <<< prettyPrintBinder') b 190 | 191 | prettyPrintBinder' :: Binder -> StateT PrinterState Maybe String 192 | prettyPrintBinder' b = runPattern matchBinder b 193 | where 194 | matchBinder :: Pattern PrinterState Binder String 195 | matchBinder = fix $ \p -> buildPrettyPrinter operators (prettyPrintBinderAtom unit <+> (parens <$> p)) 196 | operators :: OperatorTable PrinterState Binder String 197 | operators = 198 | OperatorTable [ [ Operator (assocR matchConsBinder (\b1 b2 -> b1 ++ " : " ++ b2)) ] ] 199 | 200 | matchConsBinder :: Pattern PrinterState Binder (Tuple Binder Binder) 201 | matchConsBinder = mkPattern match' 202 | where 203 | match' (ConsBinder b1 b2) = Just (Tuple b1 b2) 204 | match' _ = Nothing 205 | 206 | prettyPrintObjectPropertyBinder :: (Tuple String Binder) -> StateT PrinterState Maybe String 207 | prettyPrintObjectPropertyBinder (Tuple key binder) = joinWith "" <$> sequence 208 | [ return $ prettyPrintObjectKey key ++ ": " 209 | , prettyPrintBinder' binder 210 | ] 211 | 212 | prettyPrintObjectProperty :: (Tuple String Value) -> StateT PrinterState Maybe String 213 | prettyPrintObjectProperty (Tuple key value) = joinWith "" <$> sequence 214 | [ return $ prettyPrintObjectKey key ++ ": " 215 | , prettyPrintValue' value 216 | ] 217 | -------------------------------------------------------------------------------- /src/Language/PureScript/Sugar.purs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- 3 | -- Module : Language.PureScript.Sugar 4 | -- Copyright : (c) Phil Freeman 2013-14 5 | -- License : MIT 6 | -- 7 | -- Maintainer : Phil Freeman 8 | -- Stability : experimental 9 | -- Portability : 10 | -- 11 | -- | 12 | -- Desugaring passes 13 | -- 14 | ----------------------------------------------------------------------------- 15 | 16 | module Language.PureScript.Sugar (desugar) where 17 | 18 | import Data.Either 19 | import Data.Traversable (traverse) 20 | import Data.Array (map) 21 | 22 | import Control.Bind ((>=>)) 23 | import Control.Monad 24 | import Control.Monad.Trans 25 | 26 | import Language.PureScript.Declarations 27 | import Language.PureScript.Errors 28 | import Language.PureScript.Supply 29 | 30 | import Language.PureScript.Sugar.TypeClasses 31 | import Language.PureScript.Sugar.Names 32 | import Language.PureScript.Sugar.CaseDeclarations 33 | import Language.PureScript.Sugar.BindingGroups 34 | import Language.PureScript.Sugar.DoNotation 35 | import Language.PureScript.Sugar.TypeDeclarations 36 | import Language.PureScript.Sugar.Operators 37 | 38 | -- | 39 | -- The desugaring pipeline proceeds as follows: 40 | -- 41 | -- * Introduce type synonyms for type class dictionaries 42 | -- 43 | -- * Rebracket user-defined binary operators 44 | -- 45 | -- * Desugar do-notation using the @Prelude.Monad@ type class 46 | -- 47 | -- * Desugar top-level case declarations into explicit case expressions 48 | -- 49 | -- * Desugar type declarations into value declarations with explicit type annotations 50 | -- 51 | -- * Group mutually recursive value and data declarations into binding groups. 52 | -- 53 | -- * Qualify any unqualified names and types 54 | -- 55 | desugar :: [Module] -> SupplyT (Either ErrorStack) [Module] 56 | desugar = map removeSignedLiterals 57 | >>> traverse desugarDoModule 58 | >=> desugarCasesModule 59 | >=> lift <<< (desugarTypeDeclarationsModule 60 | >=> desugarImports 61 | >=> rebracket) 62 | >=> desugarTypeClasses 63 | >=> lift <<< createBindingGroupsModule -------------------------------------------------------------------------------- /src/Language/PureScript/Sugar/BindingGroups.purs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- 3 | -- Module : Language.PureScript.BindingGroups 4 | -- Copyright : (c) Phil Freeman 2013-14 5 | -- License : MIT 6 | -- 7 | -- Maintainer : Phil Freeman 8 | -- Stability : experimental 9 | -- Portability : 10 | -- 11 | -- | 12 | -- This module implements the desugaring pass which creates binding groups from sets of 13 | -- mutually-recursive value declarations and mutually-recursive type declarations. 14 | -- 15 | ----------------------------------------------------------------------------- 16 | 17 | module Language.PureScript.Sugar.BindingGroups ( 18 | createBindingGroups, 19 | createBindingGroupsModule, 20 | collapseBindingGroups, 21 | collapseBindingGroupsModule 22 | ) where 23 | 24 | import Data.Array 25 | import Data.Maybe 26 | import Data.Either 27 | import Data.Foldable (all, find) 28 | import Data.Traversable 29 | 30 | import Data.Graph 31 | 32 | import Data.Tuple 33 | import Data.Tuple3 34 | 35 | import Control.Apply 36 | 37 | import Language.PureScript.Declarations 38 | import Language.PureScript.Names 39 | import Language.PureScript.Types 40 | import Language.PureScript.Environment 41 | import Language.PureScript.Errors 42 | 43 | -- | 44 | -- Replace all sets of mutually-recursive declarations in a module with binding groups 45 | -- 46 | createBindingGroupsModule :: [Module] -> Either ErrorStack [Module] 47 | createBindingGroupsModule = traverse $ \(Module name ds exps) -> Module name <$> createBindingGroups name ds <*> pure exps 48 | 49 | -- | 50 | -- Collapse all binding groups in a module to individual declarations 51 | -- 52 | collapseBindingGroupsModule :: [Module] -> [Module] 53 | collapseBindingGroupsModule = map $ \(Module name ds exps) -> Module name (collapseBindingGroups ds) exps 54 | 55 | -- | 56 | -- Replace all sets of mutually-recursive declarations with binding groups 57 | -- 58 | createBindingGroups :: ModuleName -> [Declaration] -> Either ErrorStack [Declaration] 59 | createBindingGroups moduleName ds = do 60 | values <- traverse (createBindingGroupsForValue moduleName) $ filter isValueDecl ds 61 | let dataDecls = filter isDataDecl ds 62 | declNamed pn = 63 | case find (\d -> getProperName d == pn) dataDecls of 64 | Just d -> d 65 | dataVerts = map getProperName dataDecls 66 | dataEdges = do d1 <- dataDecls 67 | d2 <- usedProperNames moduleName d1 `intersect` dataVerts 68 | return $ Edge (getProperName d1) d2 69 | dataBindingGroupDecls <- traverse toDataBindingGroup $ scc' getProperName declNamed $ Graph dataDecls dataEdges 70 | let valueVerts = map getIdent values 71 | valueNamed ident = 72 | case find (\v -> getIdent v == ident) values of 73 | Just v -> v 74 | valueEdges = do val1 <- values 75 | val2 <- usedIdents moduleName val1 `intersect` valueVerts 76 | return $ Edge (getIdent val1) val2 77 | bindingGroupDecls = map toBindingGroup $ scc' getIdent valueNamed $ Graph values valueEdges 78 | return $ filter isImportDecl ds ++ 79 | filter isExternDataDecl ds ++ 80 | filter isExternInstanceDecl ds ++ 81 | dataBindingGroupDecls ++ 82 | filter isTypeClassDeclaration ds ++ 83 | filter isFixityDecl ds ++ 84 | filter isExternDecl ds ++ 85 | bindingGroupDecls 86 | 87 | createBindingGroupsForValue :: ModuleName -> Declaration -> Either ErrorStack Declaration 88 | createBindingGroupsForValue moduleName = (everywhereOnValuesTopDownM return go return).decls 89 | where 90 | go (Let ds val) = Let <$> createBindingGroups moduleName ds <*> pure val 91 | go other = return other 92 | 93 | -- | 94 | -- Collapse all binding groups to individual declarations 95 | -- 96 | collapseBindingGroups :: [Declaration] -> [Declaration] 97 | collapseBindingGroups ds = map f (concatMap go ds) 98 | where 99 | f = (everywhereOnValues id collapseBindingGroupsForValue id).decls 100 | go (DataBindingGroupDeclaration ds) = ds 101 | go (BindingGroupDeclaration ds) = map (\(Tuple3 ident nameKind val) -> ValueDeclaration ident nameKind [] Nothing val) ds 102 | go (PositionedDeclaration pos d) = map (PositionedDeclaration pos) $ go d 103 | go other = [other] 104 | 105 | collapseBindingGroupsForValue :: Value -> Value 106 | collapseBindingGroupsForValue (Let ds val) = Let (collapseBindingGroups ds) val 107 | collapseBindingGroupsForValue other = other 108 | 109 | usedIdents :: ModuleName -> Declaration -> [Ident] 110 | usedIdents moduleName = 111 | nub <<< (everythingOnValues (++) (const []) usedNames (const []) (const []) (const [])).decls 112 | where 113 | usedNames :: Value -> [Ident] 114 | usedNames (Var (Qualified Nothing name)) = [name] 115 | usedNames (Var (Qualified (Just moduleName') name)) | moduleName == moduleName' = [name] 116 | usedNames _ = [] 117 | 118 | usedProperNames :: ModuleName -> Declaration -> [ProperName] 119 | usedProperNames moduleName = 120 | nub <<< (accumTypes (everythingOnTypes (++) usedNames)).decls 121 | where 122 | usedNames :: Type -> [ProperName] 123 | usedNames (ConstrainedType constraints _) = flip mapMaybe constraints $ \qual -> 124 | case qual of 125 | Tuple (Qualified (Just moduleName') name) _ | moduleName == moduleName' -> Just name 126 | _ -> Nothing 127 | usedNames (TypeConstructor (Qualified (Just moduleName') name)) | moduleName == moduleName' = [name] 128 | usedNames _ = [] 129 | 130 | getIdent :: Declaration -> Ident 131 | getIdent (ValueDeclaration ident _ _ _ _) = ident 132 | getIdent (PositionedDeclaration _ d) = getIdent d 133 | getIdent _ = theImpossibleHappened "Expected ValueDeclaration" 134 | 135 | getProperName :: Declaration -> ProperName 136 | getProperName (DataDeclaration pn _ _) = pn 137 | getProperName (TypeSynonymDeclaration pn _ _) = pn 138 | getProperName (PositionedDeclaration _ d) = getProperName d 139 | getProperName _ = theImpossibleHappened "Expected DataDeclaration" 140 | 141 | toBindingGroup :: SCC Declaration -> Declaration 142 | toBindingGroup (AcyclicSCC d) = d 143 | toBindingGroup (CyclicSCC [d]) = d 144 | toBindingGroup (CyclicSCC ds') = BindingGroupDeclaration $ map fromValueDecl ds' 145 | 146 | toDataBindingGroup :: SCC Declaration -> Either ErrorStack Declaration 147 | toDataBindingGroup (AcyclicSCC d) = return d 148 | toDataBindingGroup (CyclicSCC [d]) = 149 | case isTypeSynonym d of 150 | Just pn -> Left $ mkErrorStack ("Cycle in type synonym " ++ show pn) Nothing 151 | _ -> return d 152 | toDataBindingGroup (CyclicSCC ds') | all (isJust <<< isTypeSynonym) ds' = Left $ mkErrorStack "Cycle in type synonyms" Nothing 153 | toDataBindingGroup (CyclicSCC ds') = return $ DataBindingGroupDeclaration ds' 154 | 155 | isTypeSynonym :: Declaration -> Maybe ProperName 156 | isTypeSynonym (TypeSynonymDeclaration pn _ _) = Just pn 157 | isTypeSynonym (PositionedDeclaration _ d) = isTypeSynonym d 158 | isTypeSynonym _ = Nothing 159 | 160 | fromValueDecl :: Declaration -> Tuple3 Ident NameKind Value 161 | fromValueDecl (ValueDeclaration ident nameKind [] Nothing val) = Tuple3 ident nameKind val 162 | fromValueDecl (ValueDeclaration _ _ _ _ _) = theImpossibleHappened "Binders should have been desugared" 163 | fromValueDecl (PositionedDeclaration _ d) = fromValueDecl d 164 | fromValueDecl _ = theImpossibleHappened "Expected ValueDeclaration" 165 | -------------------------------------------------------------------------------- /src/Language/PureScript/Sugar/CaseDeclarations.purs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- 3 | -- Module : Language.PureScript.CaseDeclarations 4 | -- Copyright : (c) Phil Freeman 2013-14 5 | -- License : MIT 6 | -- 7 | -- Maintainer : Phil Freeman 8 | -- Stability : experimental 9 | -- Portability : 10 | -- 11 | -- | 12 | -- This module implements the desugaring pass which replaces top-level binders with 13 | -- case expressions. 14 | -- 15 | ----------------------------------------------------------------------------- 16 | 17 | module Language.PureScript.Sugar.CaseDeclarations ( 18 | desugarCases, 19 | desugarCasesModule 20 | ) where 21 | 22 | import Data.Array (map, groupBy, length) 23 | import qualified Data.Array.Unsafe as Unsafe 24 | 25 | import Data.Maybe 26 | import Data.Either 27 | import Data.Foldable (all, foldr) 28 | import Data.Traversable (for, traverse) 29 | 30 | import Data.Tuple 31 | 32 | import Control.Apply 33 | import Control.Bind ((<=<), join) 34 | import Control.Monad (unless, replicateM) 35 | 36 | import Control.Monad.Error 37 | import Control.Monad.Error.Class 38 | 39 | import Language.PureScript.Names 40 | import Language.PureScript.Declarations 41 | import Language.PureScript.Environment 42 | import Language.PureScript.Errors 43 | import Language.PureScript.Supply 44 | 45 | -- | 46 | -- Replace all top-level binders in a module with case expressions. 47 | -- 48 | desugarCasesModule :: [Module] -> SupplyT (Either ErrorStack) [Module] 49 | desugarCasesModule ms = for ms $ \(Module name ds exps) -> 50 | rethrow (\s -> (strMsg ("Error in module " ++ show name) :: ErrorStack) <> s) $ 51 | Module name <$> (desugarCases <=< desugarAbs $ ds) <*> pure exps 52 | 53 | desugarAbs :: [Declaration] -> SupplyT (Either ErrorStack) [Declaration] 54 | desugarAbs = traverse (everywhereOnValuesM return replace return).decls 55 | where 56 | replace :: Value -> SupplyT (Either ErrorStack) Value 57 | replace (Abs (Right binder) val) = do 58 | ident <- Ident <$> freshName 59 | return $ Abs (Left ident) $ Case [Var (Qualified Nothing ident)] [mkCaseAlternative [binder] Nothing val] 60 | replace other = return other 61 | 62 | -- | 63 | -- Replace all top-level binders with case expressions. 64 | -- 65 | desugarCases :: [Declaration] -> SupplyT (Either ErrorStack) [Declaration] 66 | desugarCases ds = do 67 | dss <- traverse toDecls $ groupBy inSameGroup $ ds 68 | desugarRest (join dss) 69 | where 70 | desugarRest :: [Declaration] -> SupplyT (Either ErrorStack) [Declaration] 71 | desugarRest (TypeInstanceDeclaration name constraints className tys ds : rest) = 72 | (:) <$> (TypeInstanceDeclaration name constraints className tys <$> desugarCases ds) <*> desugarRest rest 73 | desugarRest (ValueDeclaration name nameKind bs g val : rest) = 74 | (:) <$> (ValueDeclaration name nameKind bs g <$> f val) <*> desugarRest rest 75 | where 76 | f = (everywhereOnValuesTopDownM return go return).values 77 | go (Let ds val') = Let <$> desugarCases ds <*> pure val' 78 | go other = return other 79 | desugarRest (PositionedDeclaration pos d : ds) = do 80 | (d' : ds') <- desugarRest (d : ds) 81 | return (PositionedDeclaration pos d' : ds') 82 | desugarRest (d : ds) = (:) d <$> desugarRest ds 83 | desugarRest [] = pure [] 84 | 85 | inSameGroup :: Declaration -> Declaration -> Boolean 86 | inSameGroup (ValueDeclaration ident1 _ _ _ _) (ValueDeclaration ident2 _ _ _ _) = ident1 == ident2 87 | inSameGroup (PositionedDeclaration _ d1) d2 = inSameGroup d1 d2 88 | inSameGroup d1 (PositionedDeclaration _ d2) = inSameGroup d1 d2 89 | inSameGroup _ _ = false 90 | 91 | toDecls :: [Declaration] -> SupplyT (Either ErrorStack) [Declaration] 92 | toDecls [ValueDeclaration ident nameKind bs Nothing val] | all isVarBinder bs = do 93 | let args = map (\(VarBinder arg) -> arg) bs 94 | body = foldr (Abs <<< Left) val args 95 | return [ValueDeclaration ident nameKind [] Nothing body] 96 | toDecls ds@(ValueDeclaration ident _ bs _ _ : _) = do 97 | let tuples = map toTuple ds 98 | unless (all (((==) (length bs)) <<< length <<< fst) tuples) $ 99 | throwError $ mkErrorStack ("Argument list lengths differ in declaration " ++ show ident) Nothing 100 | caseDecl <- makeCaseDeclaration ident tuples 101 | return [caseDecl] 102 | toDecls (PositionedDeclaration pos d : ds) = do 103 | (d' : ds') <- rethrowWithPosition pos $ toDecls (d : ds) 104 | return (PositionedDeclaration pos d' : ds') 105 | toDecls ds = return ds 106 | 107 | isVarBinder :: Binder -> Boolean 108 | isVarBinder (VarBinder _) = true 109 | isVarBinder _ = false 110 | 111 | toTuple :: Declaration -> Tuple [Binder] (Tuple (Maybe Guard) Value) 112 | toTuple (ValueDeclaration _ _ bs g val) = Tuple bs (Tuple g val) 113 | toTuple (PositionedDeclaration _ d) = toTuple d 114 | toTuple _ = theImpossibleHappened "Not a value declaration" 115 | 116 | makeCaseDeclaration :: Ident -> [Tuple [Binder] (Tuple (Maybe Guard) Value)] -> SupplyT (Either ErrorStack) Declaration 117 | makeCaseDeclaration ident alternatives = do 118 | let argPattern = length <<< fst <<< Unsafe.head $ alternatives 119 | args <- map Ident <$> replicateM argPattern freshName 120 | let 121 | vars = map (Var <<< Qualified Nothing) args 122 | binders = do (Tuple bs (Tuple g val)) <- alternatives 123 | return $ mkCaseAlternative bs g val 124 | value = foldr (Abs <<< Left) (Case vars binders) args 125 | return $ ValueDeclaration ident Value [] Nothing value 126 | -------------------------------------------------------------------------------- /src/Language/PureScript/Sugar/DoNotation.purs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- 3 | -- Module : Language.PureScript.Sugar.DoNotation 4 | -- Copyright : (c) Phil Freeman 2013-14 5 | -- License : MIT 6 | -- 7 | -- Maintainer : Phil Freeman 8 | -- Stability : experimental 9 | -- Portability : 10 | -- 11 | -- | 12 | -- This module implements the desugaring pass which replaces do-notation statements with 13 | -- appropriate calls to (>>=) from the Prelude.Monad type class. 14 | -- 15 | ----------------------------------------------------------------------------- 16 | 17 | module Language.PureScript.Sugar.DoNotation ( 18 | desugarDoModule 19 | ) where 20 | 21 | import Data.Maybe 22 | import Data.Either 23 | 24 | import Data.Traversable (traverse) 25 | 26 | import Control.Apply 27 | import Control.Monad.Trans 28 | 29 | import Language.PureScript.Names 30 | import Language.PureScript.Declarations 31 | import Language.PureScript.Errors 32 | import Language.PureScript.Supply 33 | 34 | import qualified Language.PureScript.Constants as C 35 | 36 | -- | 37 | -- Replace all @DoNotationBind@ and @DoNotationValue@ constructors with applications of the Prelude.(>>=) function, 38 | -- and all @DoNotationLet@ constructors with let expressions. 39 | -- 40 | desugarDoModule :: Module -> SupplyT (Either ErrorStack) Module 41 | desugarDoModule (Module mn ds exts) = Module mn <$> traverse desugarDo ds <*> pure exts 42 | 43 | desugarDo :: Declaration -> SupplyT (Either ErrorStack) Declaration 44 | desugarDo (PositionedDeclaration pos d) = (PositionedDeclaration pos) <$> (rethrowWithPosition pos $ desugarDo d) 45 | desugarDo d = (everywhereOnValuesM return replace return).decls d 46 | where 47 | prelude :: ModuleName 48 | prelude = ModuleName [ProperName C.prelude] 49 | 50 | bind :: Value 51 | bind = Var (Qualified (Just prelude) (Op C.(>>=))) 52 | 53 | replace :: Value -> SupplyT (Either ErrorStack) Value 54 | replace (Do els) = go els 55 | replace (PositionedValue pos v) = PositionedValue pos <$> rethrowWithPosition pos (replace v) 56 | replace other = return other 57 | 58 | go :: [DoNotationElement] -> SupplyT (Either ErrorStack) Value 59 | go [] = theImpossibleHappened "The impossible happened in desugarDo" 60 | go [DoNotationValue val] = return val 61 | go (DoNotationValue val : rest) = do 62 | rest' <- go rest 63 | return $ App (App bind val) (Abs (Left (Ident "_")) rest') 64 | go [DoNotationBind _ _] = lift $ Left $ mkErrorStack "Bind statement cannot be the last statement in a do block" Nothing 65 | go (DoNotationBind NullBinder val : rest) = go (DoNotationValue val : rest) 66 | go (DoNotationBind (VarBinder ident) val : rest) = do 67 | rest' <- go rest 68 | return $ App (App bind val) (Abs (Left ident) rest') 69 | go (DoNotationBind binder val : rest) = do 70 | rest' <- go rest 71 | ident <- Ident <$> freshName 72 | return $ App (App bind val) (Abs (Left ident) (Case [Var (Qualified Nothing ident)] [mkCaseAlternative [binder] Nothing rest'])) 73 | go [DoNotationLet _] = lift $ Left $ mkErrorStack "Let statement cannot be the last statement in a do block" Nothing 74 | go (DoNotationLet ds : rest) = do 75 | rest' <- go rest 76 | return $ Let ds rest' 77 | go (PositionedDoNotationElement pos el : rest) = rethrowWithPosition pos $ PositionedValue pos <$> go (el : rest) 78 | -------------------------------------------------------------------------------- /src/Language/PureScript/Sugar/Operators.purs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- 3 | -- Module : Language.PureScript.Sugar.Operators 4 | -- Copyright : (c) Phil Freeman 2013-14 5 | -- License : MIT 6 | -- 7 | -- Maintainer : Phil Freeman 8 | -- Stability : experimental 9 | -- Portability : 10 | -- 11 | -- | 12 | -- This module implements the desugaring pass which reapplies binary operators based 13 | -- on their fixity data and removes explicit parentheses. 14 | -- 15 | -- The value parser ignores fixity data when parsing binary operator applications, so 16 | -- it is necessary to reorder them here. 17 | -- 18 | ----------------------------------------------------------------------------- 19 | 20 | module Language.PureScript.Sugar.Operators ( 21 | rebracket, 22 | removeSignedLiterals 23 | ) where 24 | 25 | import Data.Either 26 | import Data.Maybe 27 | import Data.Function (on) 28 | import Data.Array 29 | import Data.Tuple 30 | import Data.Tuple3 31 | import Data.Traversable (traverse) 32 | 33 | import Control.Apply 34 | import Control.Monad.Identity 35 | import Control.Monad.State 36 | import Control.Monad.State.Class 37 | import Control.Monad.Error 38 | import Control.Monad.Error.Class 39 | 40 | import qualified Text.Parsing.Parser as P 41 | import qualified Text.Parsing.Parser.Combinators as P 42 | import qualified Text.Parsing.Parser.Expr as P 43 | 44 | import Language.PureScript.Names 45 | import Language.PureScript.Declarations 46 | import Language.PureScript.Errors 47 | import Language.PureScript.Pos 48 | 49 | import qualified Language.PureScript.Constants as C 50 | 51 | -- | 52 | -- Remove explicit parentheses and reorder binary operator applications 53 | -- 54 | rebracket :: [Module] -> Either ErrorStack [Module] 55 | rebracket ms = do 56 | let fixities = concatMap collectFixities ms 57 | ensureNoDuplicates $ map (\(Tuple3 i pos _) -> (Tuple i pos)) fixities 58 | let opTable = customOperatorTable $ map (\(Tuple3 i _ f) -> (Tuple i f)) fixities 59 | traverse (rebracketModule opTable) ms 60 | 61 | removeSignedLiterals :: Module -> Module 62 | removeSignedLiterals (Module mn ds exts) = Module mn (map f ds) exts 63 | where 64 | f = (everywhereOnValues id go id).decls 65 | go (UnaryMinus (NumericLiteral n)) = NumericLiteral (negate n) 66 | go (UnaryMinus val) = App (Var (Qualified (Just (ModuleName [ProperName C.prelude])) (Ident C.negate))) val 67 | go other = other 68 | 69 | rebracketModule :: [[Tuple3 (Qualified Ident) (Value -> Value -> Value) Associativity]] -> Module -> Either ErrorStack Module 70 | rebracketModule opTable (Module mn ds exts) = 71 | case everywhereOnValuesTopDownM return (matchOperators opTable) return of 72 | { decls = f } -> Module mn <$> (map removeParens <$> traverse f ds) <*> pure exts 73 | 74 | removeParens :: Declaration -> Declaration 75 | removeParens = (everywhereOnValues id go id).decls 76 | where 77 | go (Parens val) = val 78 | go val = val 79 | 80 | collectFixities :: Module -> [Tuple3 (Qualified Ident) SourcePos Fixity] 81 | collectFixities (Module moduleName ds _) = concatMap collect ds 82 | where 83 | collect :: Declaration -> [Tuple3 (Qualified Ident) SourcePos Fixity] 84 | collect (PositionedDeclaration pos (FixityDeclaration fixity name)) = [Tuple3 (Qualified (Just moduleName) (Op name)) pos fixity] 85 | collect (FixityDeclaration _ _) = theImpossibleHappened "Fixity without srcpos info" 86 | collect _ = [] 87 | 88 | ensureNoDuplicates :: [Tuple (Qualified Ident) SourcePos] -> Either ErrorStack Unit 89 | ensureNoDuplicates m = go $ sortBy (compare `on` fst) m 90 | where 91 | go [] = return unit 92 | go [_] = return unit 93 | go ((Tuple (x@(Qualified (Just mn) name)) _) : (Tuple y pos) : _) | x == y = 94 | rethrow (\e -> strMsg ("Error in module " ++ show mn) <> (e :: ErrorStack)) $ 95 | rethrowWithPosition pos $ 96 | throwError $ mkErrorStack ("Redefined fixity for " ++ show name) Nothing 97 | go (_ : rest) = go rest 98 | 99 | customOperatorTable :: [Tuple (Qualified Ident) Fixity] -> [[Tuple3 (Qualified Ident) (Value -> Value -> Value) Associativity]] 100 | customOperatorTable fixities = 101 | let 102 | applyUserOp ident t1 = App (App (Var ident) t1) 103 | userOps = map (\(Tuple name (Fixity a p)) -> (Tuple3 name (applyUserOp name) (Tuple p a))) fixities 104 | sorted = sortBy (flip compare `on` (\(Tuple3 _ _ (Tuple p _)) -> p)) userOps 105 | groups = groupBy ((==) `on` (\(Tuple3 _ _ (Tuple p _)) -> p)) sorted 106 | in 107 | map (map (\(Tuple3 name f (Tuple _ a)) -> (Tuple3 name f a))) groups 108 | 109 | type Link = Either Value (Qualified Ident) 110 | 111 | type Chain = [Link] 112 | 113 | matchOperators :: [[Tuple3 (Qualified Ident) (Value -> Value -> Value) Associativity]] -> Value -> Either ErrorStack Value 114 | matchOperators ops = parseChains 115 | where 116 | parseChains :: Value -> Either ErrorStack Value 117 | parseChains b@(BinaryNoParens _ _ _) = bracketChain (extendChain b) 118 | parseChains other = return other 119 | 120 | extendChain :: Value -> Chain 121 | extendChain (BinaryNoParens name l r) = Left l : Right name : extendChain r 122 | extendChain other = [Left other] 123 | 124 | bracketChain :: Chain -> Either ErrorStack Value 125 | bracketChain c = either (\(P.ParseError o) -> Left (o.message `mkErrorStack` Nothing)) Right 126 | (P.runParser c ((P.buildExprParser opTable parseValue <* eof) P. "operator expression")) 127 | 128 | opTable = [P.Infix (P.try (mkParser <$> parseTicks)) P.AssocLeft] 129 | : map (map (\(Tuple3 name f a) -> P.Infix (P.try (matchOp name) *> return f) (toAssoc a))) ops 130 | ++ [[ P.Infix (P.try (mkParser <$> parseOp)) P.AssocLeft ]] 131 | 132 | mkParser :: Qualified Ident -> Value -> Value -> Value 133 | mkParser ident t1 t2 = App (App (Var ident) t1) t2 134 | 135 | toAssoc :: Associativity -> P.Assoc 136 | toAssoc Infixl = P.AssocLeft 137 | toAssoc Infixr = P.AssocRight 138 | toAssoc Infix = P.AssocNone 139 | 140 | eof :: forall t. P.Parser Chain Unit 141 | eof = do 142 | ts <- get 143 | case ts :: Chain of 144 | [] -> return unit 145 | _ -> P.fail "Expected EOF" 146 | 147 | token :: forall a. String -> (Link -> Maybe a) -> P.Parser Chain a 148 | token exp p = do 149 | ts <- get 150 | case ts of 151 | (t : rest) -> 152 | case p t of 153 | Just a -> do 154 | P.consume 155 | put rest 156 | return a 157 | Nothing -> P.fail $ "Expected " ++ exp ++ ", found " ++ showLink t 158 | _ -> P.fail $ "Expected " ++ exp ++ ", found EOF" 159 | 160 | showLink :: Link -> String 161 | showLink (Left _) = "expression" 162 | showLink (Right _) = "operator" 163 | 164 | parseValue :: P.Parser Chain Value 165 | parseValue = token "expression" match 166 | where 167 | match (Left value) = Just value 168 | match _ = Nothing 169 | 170 | parseOp :: P.Parser Chain (Qualified Ident) 171 | parseOp = token "operator" match 172 | where 173 | match (Right (q@(Qualified _ (Op _)))) = Just q 174 | match _ = Nothing 175 | 176 | parseTicks :: P.Parser Chain (Qualified Ident) 177 | parseTicks = token "infix function" match 178 | where 179 | match (Right (q@(Qualified _ (Ident _)))) = Just q 180 | match _ = Nothing 181 | 182 | matchOp :: Qualified Ident -> P.Parser Chain Unit 183 | matchOp op = do 184 | ident <- parseOp 185 | if (ident == op) 186 | then return unit 187 | else P.fail "Expected operator" 188 | -------------------------------------------------------------------------------- /src/Language/PureScript/Sugar/TypeDeclarations.purs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- 3 | -- Module : Language.PureScript.Sugar.TypeDeclarations 4 | -- Copyright : (c) Phil Freeman 2013 5 | -- License : MIT 6 | -- 7 | -- Maintainer : Phil Freeman 8 | -- Stability : experimental 9 | -- Portability : 10 | -- 11 | -- | 12 | -- This module implements the desugaring pass which replaces top-level type declarations with 13 | -- type annotations on the corresponding expression. 14 | -- 15 | ----------------------------------------------------------------------------- 16 | 17 | module Language.PureScript.Sugar.TypeDeclarations ( 18 | desugarTypeDeclarations, 19 | desugarTypeDeclarationsModule 20 | ) where 21 | 22 | import Data.Maybe 23 | import Data.Either 24 | import Data.Traversable (for) 25 | import Data.Tuple3 26 | 27 | import Control.Apply 28 | 29 | import Control.Monad.Error 30 | import Control.Monad.Error.Class 31 | 32 | import Language.PureScript.Declarations 33 | import Language.PureScript.Names 34 | import Language.PureScript.Environment 35 | import Language.PureScript.Errors 36 | 37 | -- | 38 | -- Replace all top level type declarations in a module with type annotations 39 | -- 40 | desugarTypeDeclarationsModule :: [Module] -> Either ErrorStack [Module] 41 | desugarTypeDeclarationsModule ms = for ms $ \(Module name ds exps) -> 42 | rethrow (\e -> strMsg ("Error in module " ++ show name) <> (e :: ErrorStack)) $ 43 | Module name <$> desugarTypeDeclarations ds <*> pure exps 44 | 45 | -- | 46 | -- Replace all top level type declarations with type annotations 47 | -- 48 | desugarTypeDeclarations :: [Declaration] -> Either ErrorStack [Declaration] 49 | desugarTypeDeclarations (PositionedDeclaration pos d : ds) = do 50 | (d' : ds') <- rethrowWithPosition pos $ desugarTypeDeclarations (d : ds) 51 | return (PositionedDeclaration pos d' : ds') 52 | desugarTypeDeclarations (TypeDeclaration name ty : d : rest) = do 53 | (Tuple3 _ nameKind val) <- fromValueDeclaration d 54 | desugarTypeDeclarations (ValueDeclaration name nameKind [] Nothing (TypedValue true val ty) : rest) 55 | where 56 | fromValueDeclaration :: Declaration -> Either ErrorStack (Tuple3 Ident NameKind Value) 57 | fromValueDeclaration (ValueDeclaration name' nameKind [] Nothing val) | name == name' = return (Tuple3 name' nameKind val) 58 | fromValueDeclaration (PositionedDeclaration pos d') = do 59 | (Tuple3 ident nameKind val) <- rethrowWithPosition pos $ fromValueDeclaration d' 60 | return (Tuple3 ident nameKind (PositionedValue pos val)) 61 | fromValueDeclaration _ = throwError $ mkErrorStack ("Orphan type declaration for " ++ show name) Nothing 62 | desugarTypeDeclarations (TypeDeclaration name _ : []) = throwError $ mkErrorStack ("Orphan type declaration for " ++ show name) Nothing 63 | desugarTypeDeclarations (ValueDeclaration name nameKind bs g val : rest) = do 64 | (:) <$> (ValueDeclaration name nameKind bs g <$> f val) <*> desugarTypeDeclarations rest 65 | where 66 | f = (everywhereOnValuesTopDownM return go return).values 67 | go (Let ds val') = Let <$> desugarTypeDeclarations ds <*> pure val' 68 | go other = return other 69 | desugarTypeDeclarations (d:ds) = (:) d <$> desugarTypeDeclarations ds 70 | desugarTypeDeclarations [] = return [] 71 | -------------------------------------------------------------------------------- /src/Language/PureScript/Supply.purs: -------------------------------------------------------------------------------- 1 | module Language.PureScript.Supply where 2 | 3 | import Control.Monad.Identity 4 | import Control.Monad.State.Class 5 | import Control.Monad.State.Trans 6 | import Control.Monad.Error.Class 7 | import Control.Monad.Trans 8 | import Data.Tuple 9 | 10 | data SupplyT m a = SupplyT (StateT Number m a) 11 | 12 | unSupplyT :: forall m a. SupplyT m a -> StateT Number m a 13 | unSupplyT (SupplyT s) = s 14 | 15 | runSupplyT :: forall m a. Number -> SupplyT m a -> m (Tuple a Number) 16 | runSupplyT n = flip runStateT n <<< unSupplyT 17 | 18 | evalSupplyT :: forall m a. (Functor m) => Number -> SupplyT m a -> m a 19 | evalSupplyT n = (<$>) fst <<< runSupplyT n 20 | 21 | type Supply = SupplyT Identity 22 | 23 | runSupply :: forall a. Number -> Supply a -> (Tuple a Number) 24 | runSupply n = runIdentity <<< runSupplyT n 25 | 26 | evalSupply :: forall a. Number -> Supply a -> a 27 | evalSupply n = runIdentity <<< evalSupplyT n 28 | 29 | fresh :: forall m. (Monad m) => SupplyT m Number 30 | fresh = SupplyT $ do 31 | n <- get 32 | put (n + 1) 33 | return n 34 | 35 | freshName :: forall m. (Monad m) => SupplyT m String 36 | freshName = mkName <$> fresh 37 | where 38 | mkName n = "_" ++ show n 39 | 40 | instance functorSupplyT :: (Monad m) => Functor (SupplyT m) where 41 | (<$>) f (SupplyT x) = SupplyT (f <$> x) 42 | 43 | instance applySupplyT :: (Monad m) => Apply (SupplyT m) where 44 | (<*>) (SupplyT f) (SupplyT x) = SupplyT (f <*> x) 45 | 46 | instance applicativeSupplyT :: (Monad m) => Applicative (SupplyT m) where 47 | pure a = SupplyT (pure a) 48 | 49 | instance bindSupplyT :: (Monad m) => Bind (SupplyT m) where 50 | (>>=) (SupplyT x) f = SupplyT (x >>= unSupplyT <<< f) 51 | 52 | instance monadSupplyT :: (Monad m) => Monad (SupplyT m) 53 | 54 | instance monadTransSupplyT :: MonadTrans SupplyT where 55 | lift = SupplyT <<< lift 56 | 57 | instance monadErrorSupplyT :: (Monad m, MonadError e m) => MonadError e (SupplyT m) where 58 | throwError = SupplyT <<< throwError 59 | catchError e f = SupplyT $ catchError (unSupplyT e) (unSupplyT <<< f) 60 | -------------------------------------------------------------------------------- /src/Language/PureScript/Traversals.purs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- 3 | -- Module : Language.PureScript.Traversals 4 | -- Copyright : (c) 2014 Phil Freeman 5 | -- License : MIT 6 | -- 7 | -- Maintainer : Phil Freeman 8 | -- Stability : experimental 9 | -- Portability : 10 | -- 11 | -- | Common functions for implementing generic traversals 12 | -- 13 | ----------------------------------------------------------------------------- 14 | 15 | module Language.PureScript.Traversals where 16 | 17 | import Data.Maybe 18 | import Data.Tuple 19 | import Data.Tuple3 20 | import Control.Apply 21 | 22 | fstM :: forall f a b c. (Functor f) => (a -> f c) -> (Tuple a b) -> f (Tuple c b) 23 | fstM f (Tuple a b) = flip Tuple b <$> f a 24 | 25 | sndM :: forall f a b c. (Functor f) => (b -> f c) -> (Tuple a b) -> f (Tuple a c) 26 | sndM f (Tuple a b) = Tuple a <$> f b 27 | 28 | thirdM :: forall f a b c d. (Functor f) => (c -> f d) -> (Tuple3 a b c) -> f (Tuple3 a b d) 29 | thirdM f (Tuple3 a b c) = Tuple3 a b <$> f c 30 | 31 | maybeM :: forall f a b. (Applicative f) => (a -> f b) -> Maybe a -> f (Maybe b) 32 | maybeM _ Nothing = pure Nothing 33 | maybeM f (Just a) = Just <$> f a 34 | 35 | defS :: forall m st val. (Monad m) => st -> val -> m (Tuple st val) 36 | defS s val = return (Tuple s val) -------------------------------------------------------------------------------- /src/Language/PureScript/TypeChecker/Kinds.purs: -------------------------------------------------------------------------------- 1 | module Language.PureScript.TypeChecker.Kinds 2 | ( kindOf 3 | , kindsOf 4 | , kindsOfAll 5 | ) where 6 | 7 | import Language.PureScript.Environment 8 | import Language.PureScript.Errors 9 | import Language.PureScript.Kinds 10 | import Language.PureScript.Names 11 | import Language.PureScript.Pretty.Kinds 12 | import Language.PureScript.TypeChecker.Monad 13 | import Language.PureScript.Types 14 | 15 | import Control.Monad (replicateM) 16 | import Control.Monad.Error 17 | import Control.Monad.Error.Class 18 | import Control.Monad.Error.Proxy 19 | import Control.Monad.State 20 | import Control.Monad.State.Class 21 | import Control.Monad.Trans 22 | import Control.Monad.Unify 23 | 24 | import Data.Array (length, map, zipWith) 25 | import Data.Array.Unsafe (head) 26 | import Data.Foldable (foldr, foldl, for_) 27 | import Data.Maybe 28 | import Data.Monoid 29 | import Data.Traversable (traverse, zipWithA) 30 | import Data.Tuple 31 | import Data.Tuple3 32 | import qualified Data.Map as M 33 | 34 | instance partialKind :: Partial Kind where 35 | unknown = KUnknown 36 | isUnknown (KUnknown u) = Just u 37 | isUnknown _ = Nothing 38 | unknowns = everythingOnKinds (++) go 39 | where 40 | go (KUnknown u) = [u] 41 | go _ = [] 42 | ($?) sub = everywhereOnKinds go 43 | where 44 | go t@(KUnknown u) = case M.lookup u (runSubstitution sub) of 45 | Nothing -> t 46 | Just t' -> t' 47 | go other = other 48 | 49 | instance unifiableCheckKind :: Unifiable Check Kind where 50 | (=?=) (KUnknown u1) (KUnknown u2) | u1 == u2 = return unit 51 | (=?=) (KUnknown u) k = substitute unifyError u k 52 | (=?=) k (KUnknown u) = substitute unifyError u k 53 | (=?=) Star Star = return unit 54 | (=?=) Bang Bang = return unit 55 | (=?=) (Row k1) (Row k2) = k1 =?= k2 56 | (=?=) (FunKind k1 k2) (FunKind k3 k4) = do 57 | k1 =?= k3 58 | k2 =?= k4 59 | (=?=) k1 k2 = UnifyT $ lift $ throwError $ withErrorType unifyError $ strMsg $ "Cannot unify " ++ prettyPrintKind k1 ++ " with " ++ prettyPrintKind k2 ++ "." 60 | 61 | -- | 62 | -- Infer the kind of a single type 63 | -- 64 | kindOf :: ModuleName -> Type -> Check Kind 65 | kindOf _ ty = 66 | rethrow (\x -> mkErrorStack "Error checking kind" (Just (TypeError ty)) <> x) $ 67 | (<$>) tidyUp <<< liftUnify $ starIfUnknown <$> infer ty 68 | where 69 | tidyUp (Tuple k sub) = sub $? k 70 | 71 | -- | 72 | -- Infer the kind of a type constructor with a collection of arguments and a collection of associated data constructors 73 | -- 74 | kindsOf :: Boolean -> ModuleName -> ProperName -> [String] -> [Type] -> Check Kind 75 | kindsOf isData moduleName name args ts = (<$>) tidyUp <<< liftUnify $ do 76 | tyCon <- fresh 77 | kargs <- replicateM (length args) fresh 78 | let dict = (Tuple name tyCon) : zipWith (\arg kind -> (Tuple arg kind)) (map ProperName args) kargs 79 | bindLocalTypeVariables moduleName dict $ solveTypes isData ts kargs tyCon 80 | where 81 | tidyUp (Tuple k sub) = starIfUnknown (sub $? k) 82 | 83 | -- | 84 | -- Simultaneously infer the kinds of several mutually recursive type constructors 85 | -- 86 | kindsOfAll :: ModuleName -> [Tuple3 ProperName [String] Type] -> [Tuple3 ProperName [String] [Type]] -> Check (Tuple [Kind] [Kind]) 87 | kindsOfAll moduleName syns tys = (<$>) tidyUp <<< liftUnify $ do 88 | synVars <- replicateM (length syns) fresh 89 | let dict = zipWith (\(Tuple3 name _ _) var -> (Tuple name var)) syns synVars 90 | bindLocalTypeVariables moduleName dict $ do 91 | tyCons <- replicateM (length tys) fresh 92 | let dict' = zipWith (\(Tuple3 name _ _) tyCon -> (Tuple name tyCon)) tys tyCons 93 | bindLocalTypeVariables moduleName dict' $ do 94 | data_ks <- zipWithA (\tyCon (Tuple3 _ args ts) -> do 95 | kargs <- replicateM (length args) fresh 96 | let argDict = zip (map ProperName args) kargs 97 | bindLocalTypeVariables moduleName argDict $ 98 | solveTypes true ts kargs tyCon) tyCons tys 99 | syn_ks <- zipWithA (\synVar (Tuple3 _ args ty) -> do 100 | kargs <- replicateM (length args) fresh 101 | let argDict = zip (map ProperName args) kargs 102 | bindLocalTypeVariables moduleName argDict $ 103 | solveTypes false [ty] kargs synVar) synVars syns 104 | return (Tuple syn_ks data_ks) 105 | where 106 | tidyUp (Tuple (Tuple ks1 ks2) sub) = Tuple (map (starIfUnknown <<< (\x -> sub $? x)) ks1) (map (starIfUnknown <<< (\x -> sub $? x)) ks2) 107 | 108 | -- | 109 | -- Solve the set of kind constraints associated with the data constructors for a type constructor 110 | -- 111 | solveTypes :: Boolean -> [Type] -> [Kind] -> Kind -> UnifyT Kind (Check) Kind 112 | solveTypes isData ts kargs tyCon = traverse infer ts >>= \ks -> 113 | if isData 114 | then do 115 | tyCon =?= foldr FunKind Star kargs 116 | for_ ks $ \k -> k =?= Star 117 | return tyCon 118 | else do 119 | tyCon =?= foldr FunKind (head ks) kargs 120 | return tyCon 121 | 122 | -- | 123 | -- Default all unknown kinds to the Star kind of types 124 | -- 125 | starIfUnknown :: Kind -> Kind 126 | starIfUnknown (KUnknown _) = Star 127 | starIfUnknown (Row k) = Row (starIfUnknown k) 128 | starIfUnknown (FunKind k1 k2) = FunKind (starIfUnknown k1) (starIfUnknown k2) 129 | starIfUnknown k = k 130 | 131 | -- | 132 | -- Infer a kind for a type 133 | -- 134 | infer :: Type -> UnifyT Kind Check Kind 135 | infer ty = rethrow (\x -> mkErrorStack "Error inferring type of value" (Just (TypeError ty)) <> x) $ infer' ty 136 | 137 | infer' :: Type -> UnifyT Kind Check Kind 138 | infer' (TypeVar v) = do 139 | Just moduleName <- getCurrentModule 140 | UnifyT $ lift $ lookupTypeVariable unifyError moduleName (Qualified Nothing (ProperName v)) 141 | infer' c@(TypeConstructor v) = do 142 | Environment env <- liftCheck getEnv 143 | case M.lookup v env.types of 144 | Nothing -> UnifyT $ lift $ throwError $ mkErrorStack "Unknown type constructor" (Just (TypeError c)) 145 | Just (Tuple kind _) -> return kind 146 | infer' (TypeApp t1 t2) = do 147 | k0 <- fresh 148 | k1 <- infer t1 149 | k2 <- infer t2 150 | k1 =?= FunKind k2 k0 151 | return k0 152 | infer' (ForAll ident ty _) = do 153 | k1 <- fresh 154 | Just moduleName <- getCurrentModule 155 | k2 <- bindLocalTypeVariables moduleName [Tuple (ProperName ident) k1] $ infer ty 156 | k2 =?= Star 157 | return Star 158 | infer' REmpty = do 159 | k <- fresh 160 | return $ Row k 161 | infer' (RCons _ ty row) = do 162 | k1 <- infer ty 163 | k2 <- infer row 164 | k2 =?= Row k1 165 | return $ Row k1 166 | infer' (ConstrainedType deps ty) = do 167 | for_ deps $ \(Tuple className tys) -> do 168 | _ <- infer $ foldl TypeApp (TypeConstructor className) tys 169 | return unit 170 | k <- infer ty 171 | k =?= Star 172 | return Star 173 | infer' _ = error "Invalid argument to infer" 174 | -------------------------------------------------------------------------------- /src/Language/PureScript/TypeChecker/Monad.purs: -------------------------------------------------------------------------------- 1 | module Language.PureScript.TypeChecker.Monad where 2 | 3 | import Language.PureScript.Declarations (canonicalizeDictionary) 4 | import Language.PureScript.Environment 5 | import Language.PureScript.Errors 6 | import Language.PureScript.Kinds 7 | import Language.PureScript.Names 8 | import Language.PureScript.Options 9 | import Language.PureScript.TypeClassDictionaries 10 | import Language.PureScript.Types 11 | 12 | import Data.Array (map) 13 | import Data.Either 14 | import Data.Maybe 15 | import Data.Tuple 16 | 17 | import Control.Monad.Error 18 | import Control.Monad.Error.Class 19 | import Control.Monad.Error.Proxy 20 | import Control.Monad.State 21 | import Control.Monad.State.Class 22 | import Control.Monad.State.Trans 23 | import Control.Monad.Trans 24 | import Control.Monad.Unify 25 | 26 | import qualified Data.Map as M 27 | 28 | -- | 29 | -- Temporarily bind a collection of names to values 30 | -- 31 | bindNames :: forall m a. (Monad m, MonadState CheckState m) => M.Map (Tuple ModuleName Ident) (Tuple Type NameKind) -> m a -> m a 32 | bindNames newNames action = do 33 | CheckState orig <- get 34 | modify $ \(CheckState st) -> CheckState $ st { env = Environment $ (envObj st.env) { names = newNames `M.union` (envObj st.env).names } } 35 | a <- action 36 | modify $ \(CheckState st) -> CheckState $ st { env = Environment $ (envObj st.env) { names = (envObj orig.env).names } } 37 | return a 38 | 39 | -- | 40 | -- Temporarily bind a collection of names to types 41 | -- 42 | bindTypes :: forall m a. (Monad m, MonadState CheckState m) => M.Map (Qualified ProperName) (Tuple Kind TypeKind) -> m a -> m a 43 | bindTypes newNames action = do 44 | CheckState orig <- get 45 | modify $ \(CheckState st) -> CheckState $ st { env = Environment $ (envObj st.env) { types = newNames `M.union` (envObj st.env).types } } 46 | a <- action 47 | modify $ \(CheckState st) -> CheckState $ st { env = Environment $ (envObj st.env) { types = (envObj orig.env).types } } 48 | return a 49 | 50 | -- | 51 | -- Temporarily make a collection of type class dictionaries available 52 | -- 53 | withTypeClassDictionaries :: forall m a. (Monad m, MonadState CheckState m) => [TypeClassDictionaryInScope] -> m a -> m a 54 | withTypeClassDictionaries entries action = do 55 | CheckState orig <- get 56 | let mentries = M.fromList $ flip map entries $ \entry -> case entry of 57 | TypeClassDictionaryInScope { name = (Qualified mn _) } -> 58 | Tuple (Tuple (canonicalizeDictionary entry) mn) entry 59 | modify $ \(CheckState st) -> CheckState $ st { env = Environment $ (envObj st.env) { typeClassDictionaries = (envObj st.env).typeClassDictionaries `M.union` mentries } } 60 | a <- action 61 | modify $ \(CheckState st) -> CheckState $ st { env = Environment $ (envObj st.env) { typeClassDictionaries = (envObj orig.env).typeClassDictionaries } } 62 | return a 63 | 64 | -- | 65 | -- Get the currently available list of type class dictionaries 66 | -- 67 | getTypeClassDictionaries :: forall m. (Monad m, MonadState CheckState m) => m [TypeClassDictionaryInScope] 68 | getTypeClassDictionaries = M.values <<< (\(CheckState st) -> (envObj st.env).typeClassDictionaries) <$> get 69 | 70 | -- | 71 | -- Temporarily bind a collection of names to local variables 72 | -- 73 | bindLocalVariables :: forall m a. (Monad m, MonadState CheckState m) => ModuleName -> [Tuple Ident Type] -> m a -> m a 74 | bindLocalVariables moduleName bindings = 75 | bindNames (M.fromList $ flip map bindings $ \(Tuple name ty) -> Tuple (Tuple moduleName name) (Tuple ty LocalVariable)) 76 | 77 | -- | 78 | -- Temporarily bind a collection of names to local type variables 79 | -- 80 | bindLocalTypeVariables :: forall m a. (Monad m, MonadState CheckState m) => ModuleName -> [Tuple ProperName Kind] -> m a -> m a 81 | bindLocalTypeVariables moduleName bindings = 82 | bindTypes (M.fromList $ flip map bindings $ \(Tuple pn kind) -> Tuple (Qualified (Just moduleName) pn) (Tuple kind LocalTypeVariable)) 83 | 84 | -- | 85 | -- Lookup the type of a value by name in the @Environment@ 86 | -- 87 | lookupVariable :: forall e m. (Error e, Monad m, MonadState CheckState m, MonadError e m) => WithErrorType e -> ModuleName -> Qualified Ident -> m Type 88 | lookupVariable errorType currentModule (Qualified moduleName var) = do 89 | Environment env <- getEnv 90 | case M.lookup (Tuple (fromMaybe currentModule moduleName) var) env.names of 91 | Nothing -> throwError $ withErrorType errorType $ strMsg $ show var ++ " is undefined" 92 | Just (Tuple ty _) -> return ty 93 | 94 | -- | 95 | -- Lookup the kind of a type by name in the @Environment@ 96 | -- 97 | lookupTypeVariable :: forall e m. (Error e, Monad m, MonadState CheckState m, MonadError e m) => WithErrorType e -> ModuleName -> Qualified ProperName -> m Kind 98 | lookupTypeVariable errorType currentModule (Qualified moduleName name) = do 99 | Environment env <- getEnv 100 | case M.lookup (Qualified (Just $ fromMaybe currentModule moduleName) name) env.types of 101 | Nothing -> throwError $ withErrorType errorType $ strMsg $ "Type variable " ++ show name ++ " is undefined" 102 | Just (Tuple k _) -> return k 103 | 104 | -- | 105 | -- State required for type checking: 106 | -- 107 | data CheckState = CheckState { 108 | -- | 109 | -- The current @Environment@ 110 | -- 111 | env :: Environment 112 | -- | 113 | -- The next fresh unification variable name 114 | -- 115 | , nextVar :: Number 116 | -- | 117 | -- The next type class dictionary name 118 | -- 119 | , nextDictName :: Number 120 | -- | 121 | -- The current module 122 | -- 123 | , currentModule :: Maybe ModuleName 124 | } 125 | 126 | -- | 127 | -- The type checking monad, which provides the state of the type checker, and error reporting capabilities 128 | -- 129 | data Check a = Check (StateT CheckState (Either ErrorStack) a) 130 | 131 | unCheck :: forall a. Check a -> StateT CheckState (Either ErrorStack) a 132 | unCheck (Check x) = x 133 | 134 | instance functorCheck :: Functor Check where 135 | (<$>) f (Check x) = Check (f <$> x) 136 | 137 | instance applyCheck :: Apply Check where 138 | (<*>) (Check f) (Check x) = Check (f <*> x) 139 | 140 | instance applicativeCheck :: Applicative Check where 141 | pure a = Check (pure a) 142 | 143 | instance bindCheck :: Bind Check where 144 | (>>=) (Check x) f = Check (x >>= unCheck <<< f) 145 | 146 | instance monadCheck :: Monad Check 147 | 148 | instance monadErrorCheck :: MonadError ErrorStack Check where 149 | throwError = Check <<< throwError 150 | catchError e f = Check $ catchError (unCheck e) (unCheck <<< f) 151 | 152 | instance monadStateCheck :: MonadState CheckState Check where 153 | state = Check <<< state 154 | 155 | -- | 156 | -- Get the current @Environment@ 157 | -- 158 | getEnv :: forall m. (Monad m, MonadState CheckState m) => m Environment 159 | getEnv = (\(CheckState st) -> st.env) <$> get 160 | 161 | -- | 162 | -- Update the @Environment@ 163 | -- 164 | putEnv :: forall m. (Monad m, MonadState CheckState m) => Environment -> m Unit 165 | putEnv env = modify $ \(CheckState st) -> CheckState $ st { env = env } 166 | 167 | -- | 168 | -- Modify the @Environment@ 169 | -- 170 | modifyEnv :: forall m. (Monad m, MonadState CheckState m) => (Environment -> Environment) -> m Unit 171 | modifyEnv f = modify (\(CheckState st) -> CheckState $ st { env = f st.env }) 172 | 173 | -- | 174 | -- Get the current module name 175 | -- 176 | getCurrentModule :: forall m. (Monad m, MonadState CheckState m) => m (Maybe ModuleName) 177 | getCurrentModule = (\(CheckState st) -> st.currentModule) <$> get 178 | 179 | -- | 180 | -- Run a computation in the Check monad, starting with an empty @Environment@ 181 | -- 182 | runCheck :: forall a. Options -> Check a -> Either String (Tuple a Environment) 183 | runCheck opts = runCheck' opts initEnvironment 184 | 185 | -- | 186 | -- Run a computation in the Check monad, failing with an error, or succeeding with a return value and the final @Environment@. 187 | -- 188 | runCheck' :: forall a. Options -> Environment -> Check a -> Either String (Tuple a Environment) 189 | runCheck' (Options o) env c = stringifyErrorStack o.verboseErrors $ do 190 | (Tuple a (CheckState st)) <- flip runStateT (CheckState { env: env, nextVar: 0, nextDictName: 0, currentModule: Nothing }) $ unCheck c 191 | return $ Tuple a (st.env) 192 | 193 | -- | 194 | -- Make an assertion, failing with an error message 195 | -- 196 | guardWith :: forall e m. (Monad m, MonadError e m) => e -> Boolean -> m Unit 197 | guardWith _ true = return unit 198 | guardWith e false = throwError e 199 | 200 | -- | 201 | -- Generate new type class dictionary name 202 | -- 203 | freshDictionaryName :: Check Number 204 | freshDictionaryName = do 205 | n <- (\(CheckState st) -> st.nextDictName) <$> get 206 | modify $ \(CheckState st) -> CheckState $ st { nextDictName = st.nextDictName + 1 } 207 | return n 208 | 209 | -- | 210 | -- Lift a computation in the @Check@ monad into the substitution monad. 211 | -- 212 | liftCheck :: forall a t. Check a -> UnifyT t Check a 213 | liftCheck = UnifyT <<< lift 214 | 215 | -- | 216 | -- Run a computation in the substitution monad, generating a return value and the final substitution. 217 | -- 218 | liftUnify :: forall t a. (Partial t) => UnifyT t Check a -> Check (Tuple a (Substitution t)) 219 | liftUnify unify = do 220 | CheckState st <- get 221 | Tuple a (UnifyState ust) <- runUnify (UnifyState $ (unifyStateObj defaultUnifyState) { nextVar = st.nextVar }) unify 222 | modify $ \(CheckState st') -> CheckState $ st' { nextVar = ust.nextVar } 223 | return $ Tuple a ust.currentSubstitution 224 | -------------------------------------------------------------------------------- /src/Language/PureScript/TypeChecker/Synonyms.purs: -------------------------------------------------------------------------------- 1 | module Language.PureScript.TypeChecker.Synonyms (saturateAllTypeSynonyms) where 2 | 3 | import Language.PureScript.Types 4 | import Language.PureScript.Names 5 | 6 | import Data.Either 7 | import Data.Maybe 8 | import Data.Tuple 9 | import Control.Monad (foldM) 10 | import Control.Monad.Writer 11 | import Control.Monad.Error 12 | import Control.Monad.Error.Class 13 | 14 | -- | 15 | -- Build a type substitution for a type synonym 16 | -- 17 | buildTypeSubstitution :: Qualified ProperName -> Number -> Type -> Either String (Maybe Type) 18 | buildTypeSubstitution name n = go n [] 19 | where 20 | go :: Number -> [Type] -> Type -> Either String (Maybe Type) 21 | go 0 args (TypeConstructor ctor) | name == ctor = return (Just $ SaturatedTypeSynonym ctor args) 22 | go m _ (TypeConstructor ctor) | m > 0 && name == ctor = throwError $ "Partially applied type synonym " ++ show name 23 | go m args (TypeApp f arg) = go (m - 1) (arg:args) f 24 | go _ _ _ = return Nothing 25 | 26 | -- | 27 | -- Replace all instances of a specific type synonym with the @SaturatedTypeSynonym@ data constructor 28 | -- 29 | saturateTypeSynonym :: Qualified ProperName -> Number -> Type -> Either String Type 30 | saturateTypeSynonym name n = everywhereOnTypesTopDownM replace 31 | where 32 | replace t = fromMaybe t <$> buildTypeSubstitution name n t 33 | 34 | -- | 35 | -- Replace all type synonyms with the @SaturatedTypeSynonym@ data constructor 36 | -- 37 | saturateAllTypeSynonyms :: [Tuple (Qualified ProperName) Number] -> Type -> Either String Type 38 | saturateAllTypeSynonyms syns d = foldM (\result (Tuple name n) -> saturateTypeSynonym name n result) d syns 39 | -------------------------------------------------------------------------------- /src/Language/PureScript/TypeClassDictionaries.purs: -------------------------------------------------------------------------------- 1 | module Language.PureScript.TypeClassDictionaries where 2 | 3 | import Data.Maybe 4 | import Data.Tuple 5 | 6 | import Language.PureScript.Names 7 | import Language.PureScript.Types 8 | 9 | -- | 10 | -- Data representing a type class dictionary which is in scope 11 | -- 12 | data TypeClassDictionaryInScope = TypeClassDictionaryInScope 13 | { 14 | -- | 15 | -- The identifier with which the dictionary can be accessed at runtime 16 | -- 17 | name :: Qualified Ident 18 | -- | 19 | -- The name of the type class to which this type class instance applies 20 | -- 21 | , className :: Qualified ProperName 22 | -- | 23 | -- The types to which this type class instance applies 24 | -- 25 | , instanceTypes :: [Type] 26 | -- | 27 | -- Type class dependencies which must be satisfied to construct this dictionary 28 | -- 29 | , dependencies :: Maybe [Tuple (Qualified ProperName) [Type]] 30 | -- | 31 | -- The type of this dictionary 32 | -- 33 | , ty :: TypeClassDictionaryType 34 | } 35 | 36 | instance showTCDIS :: Show TypeClassDictionaryInScope where 37 | show (TypeClassDictionaryInScope o) = "TypeClassDictionaryInScope { " ++ 38 | "name: " ++ show o.name ++ ", " ++ 39 | "className: " ++ show o.className ++ "," ++ 40 | "instanceTypes: " ++ show o.instanceTypes ++ ", " ++ 41 | "dependencies:" ++ show o.dependencies ++ ", " ++ " " ++ 42 | "ty:" ++ show o.ty ++ " " ++ 43 | "}" 44 | 45 | -- | 46 | -- The type of a type class dictionary 47 | -- 48 | data TypeClassDictionaryType 49 | -- | 50 | -- A regular type class dictionary 51 | -- 52 | = TCDRegular 53 | -- | 54 | -- A type class dictionary which is an alias for an imported dictionary from another module 55 | -- 56 | | TCDAlias (Qualified Ident) 57 | 58 | instance showTCDT :: Show TypeClassDictionaryType where 59 | show TCDRegular = "TCDRegular" 60 | show (TCDAlias nm) = "TCDAlias (" ++ show nm ++ ")" 61 | 62 | instance eqTCDT :: Eq TypeClassDictionaryType where 63 | (==) TCDRegular TCDRegular = true 64 | (==) (TCDAlias q1) (TCDAlias q2) = true 65 | (==) _ _ = false 66 | (/=) x y = not (x == y) 67 | -------------------------------------------------------------------------------- /src/Make.purs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- 3 | -- Module : Make 4 | -- Copyright : (c) Phil Freeman 2013-14 5 | -- License : MIT 6 | -- 7 | -- Maintainer : Phil Freeman 8 | -- Stability : experimental 9 | -- Portability : 10 | -- 11 | -- | psc-make frontend to the PureScript library 12 | -- 13 | ----------------------------------------------------------------------------- 14 | 15 | module Make where 16 | 17 | import Debug.Trace 18 | 19 | import Data.Maybe 20 | import Data.Tuple 21 | import Data.Array (concat, map) 22 | import Data.Either 23 | 24 | import Data.Traversable (for) 25 | 26 | import Control.Monad.Eff 27 | import Control.Monad.Eff.Unsafe 28 | import Control.Monad.Eff.Exception 29 | import Control.Monad.Eff.Process 30 | import Control.Monad.Eff.FS 31 | 32 | import Control.Apply 33 | import Control.Alt 34 | import Control.Alternative 35 | import Control.Monad.Application 36 | import Control.Monad.Trans 37 | import Control.Monad.Identity 38 | import Control.Monad.State.Class 39 | import Control.Monad.Error.Trans 40 | import Control.Monad.Error.Class 41 | import Control.Monad.Cont.Trans 42 | 43 | import Node.Args 44 | import Node.FS 45 | 46 | import Language.PureScript 47 | import Language.PureScript.Declarations 48 | import Language.PureScript.Options 49 | import Language.PureScript.Prelude 50 | import Language.PureScript.CodeGen.JS 51 | 52 | import qualified Language.PureScript.Parser.Lexer as P 53 | import qualified Language.PureScript.Parser.Common as P 54 | import qualified Language.PureScript.Parser.Declarations as P 55 | 56 | moduleFromText :: String -> Either String Module 57 | moduleFromText text = do 58 | tokens <- P.lex text 59 | P.runTokenParser P.parseModule tokens 60 | 61 | readInput :: forall eff. [String] -> Application [Tuple String Module] 62 | readInput input = 63 | for input (\inputFile -> do 64 | text <- readFileApplication inputFile 65 | case moduleFromText text of 66 | Left err -> throwError err 67 | Right m -> return (Tuple inputFile m)) 68 | 69 | runCompiler :: forall eff. String -> Options -> [String] -> Eff (fs :: FS, trace :: Trace, process :: Process) Unit 70 | runCompiler outputDir opts@(Options optso) input = runApplication do 71 | modules <- readInput allInputFiles 72 | make RequireLocal outputDir opts modules 73 | return unit 74 | where 75 | allInputFiles :: [String] 76 | allInputFiles | optso.noPrelude = input 77 | allInputFiles = preludeFiles ++ input 78 | 79 | flag :: String -> String -> Args Boolean 80 | flag shortForm longForm = maybe false (const true) <$> opt (flagOnly shortForm <|> flagOnly longForm) 81 | 82 | inputFiles :: Args [String] 83 | inputFiles = many argOnly 84 | 85 | outputFile :: Args String 86 | outputFile = flagArg "o" <|> flagArg "output" 87 | 88 | noTco :: Args Boolean 89 | noTco = flagOpt "no-tco" 90 | 91 | performRuntimeTypeChecks :: Args Boolean 92 | performRuntimeTypeChecks = flagOpt "runtime-type-checks" 93 | 94 | noPrelude :: Args Boolean 95 | noPrelude = flagOpt "no-prelude" 96 | 97 | noMagicDo :: Args Boolean 98 | noMagicDo = flagOpt "no-magic-do" 99 | 100 | noOpts :: Args Boolean 101 | noOpts = flagOpt "no-opts" 102 | 103 | verboseErrors :: Args Boolean 104 | verboseErrors = flag "v" "verbose-errors" 105 | 106 | options :: Args Options 107 | options = mkOptions <$> noPrelude 108 | <*> noTco 109 | <*> performRuntimeTypeChecks 110 | <*> noMagicDo 111 | <*> pure Nothing 112 | <*> noOpts 113 | <*> pure Nothing 114 | <*> pure [] 115 | <*> pure [] 116 | <*> verboseErrors 117 | 118 | term :: Args (Eff (fs :: FS, trace :: Trace, process :: Process) Unit) 119 | term = runCompiler <$> outputFile <*> options <*> inputFiles 120 | 121 | main = do 122 | result <- readArgs' term 123 | case result of 124 | Left err -> print err 125 | _ -> return unit 126 | 127 | -------------------------------------------------------------------------------- /tests/Numbers.purs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | nat = 6 4 | hex = 0xF3 5 | hex' = 0xf3 6 | hex'' = 0xFf 7 | float = 0.5 8 | exp = 10e6 9 | exp' = 10e-6 10 | exp'' = 10e+6 11 | exp''' = 1.3e-2 12 | -------------------------------------------------------------------------------- /tests/TestSimple.purs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Debug.Trace 4 | 5 | import Data.Maybe 6 | import Data.Tuple 7 | import Data.Either 8 | 9 | import Control.Apply 10 | import Control.Monad.Identity 11 | import Control.Monad.State.Class 12 | 13 | import Language.PureScript 14 | import Language.PureScript.Declarations 15 | import Language.PureScript.Options 16 | 17 | import qualified Language.PureScript.Parser.Lexer as P 18 | import qualified Language.PureScript.Parser.Common as P 19 | import qualified Language.PureScript.Parser.Declarations as P 20 | 21 | example = 22 | "module Test where\n\ 23 | \\n\ 24 | \ foo :: Number -> Number\n\ 25 | \ foo 0 = 1\n\ 26 | \ foo 1 = 0\n\ 27 | \ foo n = n" 28 | 29 | main = do 30 | trace "Lexing source file" 31 | case P.lex example of 32 | Left err -> trace err 33 | Right tokens -> do 34 | print tokens 35 | trace "Parsing module" 36 | case P.runTokenParser (P.parseModule <* P.eof) tokens of 37 | Left err -> trace err 38 | Right mod -> do 39 | print mod 40 | trace "Compiling module" 41 | case compile options [mod] of 42 | Left err -> trace err 43 | Right (Data.Tuple3.Tuple3 js exts _) -> do 44 | trace js 45 | trace exts 46 | 47 | options :: Options 48 | options = Options { noPrelude: true 49 | , noTco: false 50 | , performRuntimeTypeChecks: false 51 | , noMagicDo: false 52 | , main: Nothing 53 | , noOptimizations: false 54 | , browserNamespace: Just "PS" 55 | , modules: [] 56 | , codeGenModules: [] 57 | , verboseErrors: true 58 | } --------------------------------------------------------------------------------