diff --git a/forml.cabal b/forml.cabal --- a/forml.cabal +++ b/forml.cabal @@ -1,5 +1,5 @@ Name: forml -Version: 0.1.3 +Version: 0.2 Synopsis: A statically typed, functional programming language License: MIT Author: Andrew Stein @@ -36,17 +36,15 @@ base >= 4 && <= 5, bytestring >= 0.9.1 && <0.10, parsec, - indents, + indents == 0.3.3, containers == 0.4.2.1, GraphSCC == 1.0.2, pandoc, - jmacro, + jmacro == 0.6.3, MissingH, interpolatedstring-perl6, - transformers, mtl, text, - wl-pprint-text, ansi-terminal, HTTP, network, @@ -54,8 +52,12 @@ file-embed, process, directory, - utf8-string == 0.3.7 - + utf8-string == 0.3.7, + ghc-prim, + cereal == 0.3.5.2, + zlib == 0.5.4.0, + hslogger == 1.2.1 + if impl(ghc >= 6.12.0) ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -fno-warn-unused-do-bind -threaded diff --git a/lib/js/jasmine-1.0.1/jasmine-html.js b/lib/js/jasmine-1.0.1/jasmine-html.js --- a/lib/js/jasmine-1.0.1/jasmine-html.js +++ b/lib/js/jasmine-1.0.1/jasmine-html.js @@ -1,10 +1,10 @@ jasmine.TrivialReporter=function(a){this.document=a||document;this.suiteDivs={};this.logRunningSpecs=!1};jasmine.TrivialReporter.prototype.createDom=function(a,b,c){for(var d=document.createElement(a),e=2;e> Jasmine Running "+a.suite.description+" "+a.description+"...")}; -jasmine.TrivialReporter.prototype.reportSpecResults=function(a){var b=a.results(),c=b.passed()?"passed":"failed";b.skipped&&(c="skipped");for(var c=this.createDom("div",{className:"spec "+c},this.createDom("a",{className:"run_spec",href:"?spec="+encodeURIComponent(a.getFullName())},"run"),this.createDom("a",{className:"description",href:"?spec="+encodeURIComponent(a.getFullName()),title:a.getFullName()},a.description.split("__::__")[1])),b=b.getItems(),d=this.createDom("div",{className:"messages"}), +jasmine.TrivialReporter.prototype.reportSpecResults=function(a){var b=a.results(),c=b.passed()?"passed":"failed";b.skipped&&(c="skipped");for(var c=this.createDom("div",{className:"spec "+c},this.createDom("a",{className:"run_spec",href:"?spec="+encodeURIComponent(a.getFullName())},""),this.createDom("a",{className:"description",href:"?spec="+encodeURIComponent(a.getFullName()),title:a.getFullName()},a.description.split("__::__")[1])),b=b.getItems(),d=this.createDom("div",{className:"messages"}), e=0;e a | b | f | n | r | t | v | \ | " | ' | & [PR['PR_STRING'], /^\"(?:[^\"\\\n\x0C\r]|\\[\s\S])*(?:\"|$)/, null, '"'], - [PR['PR_STRING'], /^\'(?:[^\'\\\n\x0C\r]|\\[^&])\'?/, - null, "'"], // decimal -> digit{digit} // octal -> octit{octit} // hexadecimal -> hexit{hexit} diff --git a/lib/js/prettify.css b/lib/js/prettify.css --- a/lib/js/prettify.css +++ b/lib/js/prettify.css @@ -1,1 +1,135 @@ .pln{color:#000}@media screen{.str{color:#080}.kwd{color:#008}.com{color:#800}.typ{color:#606}.lit{color:#066}.pun,.opn,.clo{color:#660}.tag{color:#008}.atn{color:#606}.atv{color:#080}.dec,.var{color:#606}.fun{color:red}}@media print,projection{.str{color:#060}.kwd{color:#006;font-weight:bold}.com{color:#600;font-style:italic}.typ{color:#404;font-weight:bold}.lit{color:#044}.pun,.opn,.clo{color:#440}.tag{color:#006;font-weight:bold}.atn{color:#404}.atv{color:#060}}pre.prettyprint{padding:2px;border:1px solid #888}ol.linenums{margin-top:0;margin-bottom:0}li.L0,li.L1,li.L2,li.L3,li.L5,li.L6,li.L7,li.L8{list-style-type:none}li.L1,li.L3,li.L5,li.L7,li.L9{background:#eee} + +/* GitHub Theme */ +/* Pretty printing styles. Used with prettify.js. */ +/* SPAN elements with the classes below are added by prettyprint. */ +/* plain text */ +.pln { + color: #333333; } + +@media screen { + /* string content */ + .str { + color: #dd1144; } + + /* a keyword */ + .kwd { + color: #333333; } + + /* a comment */ + .com { + color: #999988; } + + /* a type name */ + .typ { + color: #445588; } + + /* a literal value */ + .lit { + color: #4455ff; } + + /* punctuation */ + .pun { + color: #333333; } + + /* lisp open bracket */ + .opn { + color: #333333; } + + /* lisp close bracket */ + .clo { + color: #333333; } + + /* a markup tag name */ + .tag { + color: navy; } + + /* a markup attribute name */ + .atn { + color: teal; } + + /* a markup attribute value */ + .atv { + color: #dd1144; } + + /* a declaration */ + .dec { + color: #333333; } + + /* a variable name */ + .var { + color: teal; } + + /* a function name */ + .fun { + color: #990000; } } +/* Use higher contrast and text-weight for printable form. */ +@media print, projection { + .str { + color: #060; } + + .kwd { + color: #006; + font-weight: bold; } + + .com { + color: #600; + font-style: italic; } + + .typ { + color: #404; + font-weight: bold; } + + .lit { + color: #00f; } + + .pun, .opn, .clo { + color: #440; } + + .tag { + color: #006; + font-weight: bold; } + + .atn { + color: #404; } + + .atv { + color: #060; } } +/* Style */ +pre.prettyprint { + background: white; + font-family: Menlo, Monaco, Consolas, monospace; + font-size: 12px; + line-height: 1.5; + border: 1px solid #ccc; + padding: 15px 10px; + border: 1px solid #111111; +border-width: 1px 1px 1px 1px !important;} + } + +/* Specify class=linenums on a pre to get line numbering */ +ol.linenums { + margin-top: 0; + margin-bottom: 0; } + +/* IE indents via margin-left */ +li.L0, +li.L1, +li.L2, +li.L3, +li.L4, +li.L5, +li.L6, +li.L7, +li.L8, +li.L9 { + /* */ } + +/* Alternate shading for lines */ +li.L1, +li.L3, +li.L5, +li.L7, +li.L9 { + /* */ } + diff --git a/src/forml/parsec.forml b/src/forml/parsec.forml --- a/src/forml/parsec.forml +++ b/src/forml/parsec.forml @@ -28,7 +28,7 @@ -- Applies a function to the parse result, only if the parse was -- successful. - inline (<$>): + (<$>): (a -> b) -> Parser a -> Parser b f <$> {parser = z} = diff --git a/src/forml/prelude.forml b/src/forml/prelude.forml --- a/src/forml/prelude.forml +++ b/src/forml/prelude.forml @@ -43,11 +43,11 @@ inline (>>=): JS a -> (a -> JS b) -> JS b - (>>=) x y = y (run x) + (>>=) x y = `y(x())()` inline (>>): JS a -> JS b -> JS b - (>>) x y = `run x; return (run y)` + (>>) x y = `x(); return y();` inline return: @@ -63,8 +63,27 @@ 5 == do! return 5 10 == do! `5 + 5` + do_times 0 _ = `undefined` + do_times n f = + + f >> do_times (n - 1) f + inline fmap: + (a -> b) -> JS a -> JS b + | f js = do + + val <- js + yield f val + + inline clone: a -> JS a | x = + + if array? x + `$.extend(true, [], x)` + else + `$.extend(true, {}, x)` + + inline log: a -> JS {} | x = `console.log(x)` @@ -84,8 +103,8 @@ -- annotated to constrain inferrence - otherwise, these functions would all be -- inferred as `a -> b -> c`. - (&&): Bool -> Bool -> Bool | x y = do! `x && y` - (||): Bool -> Bool -> Bool | x y = do! `x || y` + inline (&&): Bool -> Bool -> Bool | x y = do! `x && y` + inline (||): Bool -> Bool -> Bool | x y = do! `x || y` inline (*): Num -> Num -> Num | x y = do! `x * y` inline (/): Num -> Num -> Num | x y = do! `x / y` @@ -207,7 +226,7 @@ -- Function composition - inline x .: y = λz = x y(z) + x .: y = λz = x y(z) inline id x = x inline flip(f) x y = f(y, x) @@ -218,8 +237,11 @@ id [1, 2, 3] == [1, 2, 3] flip (λx y = x - y) 3 5 == 2 + inline ignore = flip (>>) yield {} + + -- Strings -- ------- @@ -285,9 +307,14 @@ option b {none} = b | _ {some: x} = x - + + {none} == {none} + {some: 2} == {some: 2} option 3 {some: 2} == 2 + -- HTML + -- ------ + module html HTML = { element: a @@ -356,7 +383,7 @@ inline on_key: - Num -> JS {} -> JS {} + Num -> JS _ -> JS {} | key action = `jQuery(window).keydown(function(event) { @@ -435,12 +462,15 @@ var reporter = { reportSpecResults: report reportRunnerResults: `if (typeof phantom != "undefined") { phantom.exit(is_error); }` } - do env <- `jasmine.getEnv()` + var jasmine: a - `env.addReporter(reporter)` - `env.execute()` + do env <- jasmine.getEnv + yield + env.addReporter reporter + env.execute + push : a -> Array a -> JS (Array a) push xs x = `xs.push(x)` @@ -451,54 +481,47 @@ messages = [] - reportSpecResults spec = - - do! results <- `spec.results()` - passed <- `results.passed()` - `console_reporter.total++` - - if not passed then do - `console_reporter.failed++` - push console_reporter.messages spec.description - return {} - else return {} + reportSpecResults spec = do! + results <- `spec.results()` + passed <- `results.passed()` + `console_reporter.total++` - reportRunnerResults = + if not passed then do + `console_reporter.failed++` + push console_reporter.messages spec.description + return {} + return {} - do if console_reporter.failed > 0 - log console_reporter.messages - else - return {} + reportRunnerResults = do + if console_reporter.failed > 0 + log console_reporter.messages - log "`console_reporter.total - console_reporter.failed`/`console_reporter.total` tests passed" + log "`console_reporter.total - console_reporter.failed`/`console_reporter.total` tests passed" } -- This is the initializer for prelude's HTML test suite. - table_of_contents = - - do "code" $. "prettyprint" - "code" $. "lang-hs" + table_of_contents = do - ".test" $| "position" <| "relative" - ".test" $| "left" <| "50px" + let jasmine: a - `prettyPrint()` + ".test" $| "position" <| "relative" + ".test" $| "left" <| "50px" - trivial <- `new jasmine.TrivialReporter()` - forml <- `new jasmine.FormlReporter()` - env <- `jasmine.getEnv()` + trivial <- `new jasmine.TrivialReporter` + forml <- `new jasmine.FormlReporter` + env <- jasmine.getEnv - `env.addReporter trivial` - `env.addReporter forml` - `env.addReporter console_reporter` + `env.addReporter trivial` + `env.addReporter forml` + `env.addReporter console_reporter` - `env.execute()` + env.execute - reporter <- get ".jasmine_reporter" - body <- get "#test_suite" + reporter <- get ".jasmine_reporter" + body <- get "#test_suite" - move reporter body + move reporter body -- Arrays -- ------ @@ -542,17 +565,31 @@ inline sequence: Array (JS a) -> JS (Array a) | xs = `xs.map(run)` - inline (..): Num -> Num -> Array Num - x .. y = do! `var z = []; - for (var i = x; i <= y; i++) z.push(i); - return z` - + (..): Num -> Num -> Array Num + x .. y = + + if x > y + then do! reverse (y .. x) + else do! + + `var z = []; + for (var i = x; i <= y; i++) z.push(i); + return z` + + times: Num -> a -> Array a + | n _ when n < 0 = [] + | n yld = 0 .. (n - 1) 'map \_ = yld + inline put: a -> Array a -> JS (Array a) | x xs = - do y <- `jQuery.extend(true,[],xs)` + do y <- clone xs yield push! x y + all? = reduce (&&) + + sum = reduce (+) + inline for_each: (Num -> _) -> Array _ -> JS {} | f xs = `for (x in xs) { f(parseInt(x)); }` @@ -574,8 +611,13 @@ _ = push! 1 x x == [1] + 1 .. 3 == [1, 2, 3] + 3 .. 1 == [3, 2, 1] + reduce (&&) [true, true, true] + 5 'times 5 == [5, 5, 5, 5, 5] + [1, 2, 3] == do! put 3 [1, 2] map (.x) [{x: 1}, {x: 2}] == [1, 2] @@ -591,6 +633,8 @@ -- A simple implementation of a library for manipulating linked lists. module list + + open option List a = { head: a, tail: List a } | { nil } @@ -661,6 +705,12 @@ | f x when f (head x) = drop_while f (tail x) | _ x = x + inits [:] = [:[:]] + | {head: x, tail: xs} = [:[:]] ++ (map (λy = x::y) (inits xs)) + + tails [:] = [:[:]] + | xxs = xxs :: tails <| tail xxs + not (empty? (1 :: {nil})) empty? [:] @@ -681,6 +731,12 @@ drop_while (λx = x < 0) {nil} == {nil} drop_while (λx = x > 0) [: 2, 1, 0 ] == [: 0 ] + inits [:] is [:[:]] + inits [:1,2,3] is [:[:],[:1],[:1,2],[:1,2,3]] + + tails [:] is [:[:]] + tails [:1,2,3] is [:[:1,2,3],[:2,3],[:3],[:]] + -- Cardinality length @@ -701,22 +757,12 @@ -- List concatenation (++) - | {nil} y = y | {head: y, tail: ys} xs = y :: (ys ++ xs) {nil} ++ (1 :: 2 :: {nil}) == 1 :: 2 :: {nil} [: 1, 2 ] ++ [: 3, 4 ] == [: 1, 2, 3, 4 ] - - -- Filter. - filter: (a -> Bool) -> List a -> List a - | f {nil} = {nil} - | f x when f (head x) = head x :: filter f (tail x) - | f x = filter f <| tail x - - [: 1, 2, 3, 4 ] 'filter (λx = x > 2) == [: 3, 4 ] - -- Map map(f, {nil}) = {nil} @@ -764,38 +810,75 @@ foldr1 _ {nil} = error "Foldr1 called on empty list" | f x = foldr f (head x) (tail x) - - all? f = foldl1 (&&) .: map f - any? f = foldl1 (||) .: map f - sum = foldl1 (+) + foldl (+) 0 [: 1, 2, 3, 4 ] == 10 + foldr (+) 0 [: 1, 2, 3, 4 ] == 10 + + sum = foldl1 (+) + + sum [:1,2,3] == 6 + product = foldl1 (*) + + product [:1,2,4] == 8 + + -- Find + + find: (a -> Bool) -> List a -> Option a + | f {nil} = {none} + | f {head: h, tail: _} when f h = {some = h} + | f {head: _, tail: t} = find f t + + [: 1,2] 'find (λx = x > 2) == {none} + [: 1,2,3,4] 'find (λx = x > 2) == {some: 3} + option 1 <| find (λx = x > 2) [: 1,2,3,4] == 3 - concat = foldl1 λx y = x ++ y - concat_map f xs = concat (map f xs) + -- Filter + + filter: (a -> Bool) -> List a -> List a + | f {nil} = {nil} + | f x when f (head x) = head x :: filter f (tail x) + | f x = filter f <| tail x - maximum = foldl1 λ(x, y) when x > y = x - |(_, y) = y + [: 1, 2, 3, 4 ] 'filter (λx = x > 2) == [: 3, 4 ] + + -- Partition - minimum = foldl1 λx y = if x > y then y else x + partition f = + let s x {head: l1, tail: l2} = + let l2' = head l2 + if f x then [: x::l1,l2'] else [: l1,x::l2'] + foldr s [:[:],[:]] - foldl (+) 0 [: 1, 2, 3, 4 ] == 10 - foldr (+) 0 [: 1, 2, 3, 4 ] == 10 + partition (λx = true) [:] == [: [:],[:]] + partition (λx = x < 3) [:1,2,3,4] == [: [:1,2],[:3,4]] + -- All? & Any? + + all? f = foldl1 (&&) .: map f + any? f = foldl1 (||) .: map f + all? id [:true,true] not (all? id [:true,false]) any? id [:true,false] not (any? id [:false,false]) - sum [:1,2,3] == 6 - product [:1,2,4] == 8 + concat = foldl1 λx y = x ++ y + concat_map f xs = concat (map f xs) + + maximum = foldl1 λ(x, y) when x > y = x + |(_, y) = y + + maximum [: 1, 2, 3 ] == 3 + + minimum = foldl1 λx y = if x > y then y else x + + minimum [: 1, 2, 3 ] == 1 + let x = [:1,2], y = [:3,4] concat [:x,y] == [:1,2,3,4] concat_map (λx = [:x,x+1]) [:1,2] == [:1,2,2,3] - - minimum [: 1, 2, 3 ] == 1 - maximum [: 1, 2, 3 ] == 3 -- Sequences diff --git a/src/forml/readme.forml b/src/forml/readme.forml --- a/src/forml/readme.forml +++ b/src/forml/readme.forml @@ -11,16 +11,15 @@ -- Forml is a contemporary programming language for the discriminating -- programmer, intended to fill a niche -- somewhere between [Haskell](http://www.haskell.org) and --- [Ruby](http://www.ruby.org), should such a niche turn out to exist. +-- [Ruby](http://www.ruby.org), should such a niche turn out to exist. -- Philosophy -- ========== -- 1) Writing software is unnecessarily hard, because syntax is sufficiently --- abstracted from thought process to lose something in the translation. A --- modern programming language should be designed for reading - an API --- exposing the programmer - a philosophy lifted unapologetically --- from [Ruby](http://www.artima.com/intv/ruby4.html). +-- abstracted from thought process to lose something in the translation. +-- A modern programming language should be designed for reading - an +-- [API exposing the programmer](http://www.artima.com/intv/ruby4.html). -- 2) Writing software is unnecessarily hard, because making mistakes is too -- easy. A modern programming language should prevent the programmer from @@ -29,7 +28,8 @@ -- Features -- ======== --- * Buzzwords: functional, strict, expressive, pure(ish), static(y), inferred, fast, fun. +-- * Buzzwords: functional, strict, expressive, pure(ish), static(y), +-- inferred, fast, fun. -- Strong like a gorilla, yet soft and yielding like a Nerf ball. -- * Targets Javascript, but please regard this as an implementation detail - @@ -40,16 +40,20 @@ -- * Type system which is designed to be simple and catch obvious errors, -- not entirely exhaustive, dictatorial and somewhat combative (I'm looking --- at you, Haskell). Strucural types, partials records, arbitrary unions, +-- at you, Haskell). Inferred, strucural types, partials records, -- ability to introduce unrestricted types via FFI. --- * Sugary, flexible syntax. +-- * Fast. Automatic tail call optimization, +-- inline functions, designed for use with +-- [Google Closure Compiler](https://developers.google.com/closure/) +-- advanced optimizations mode. See +-- [Tests]((http://texodus.github.com/forml/prelude.html) for some +-- simple benchmarks. --- * Inline testing, compiles to a separate suite. +-- * Flexible, expressive syntax. Lots of sugar for obvious tasks. --- * Fast. Automatic tail call optimization, --- inline functions, designed for use with [Google Closure Compiler](https://developers.google.com/closure/) --- advanced optimizations mode. +-- * Inline testing, compiles to a +-- [Jasmine](http://pivotal.github.com/jasmine) suite. -- * Heavily inspired by -- [Haskell](http://www.haskell.org/haskellwiki/Haskell) @@ -60,10 +64,15 @@ -- , [JMacro](http://www.haskell.org/haskellwiki/Jmacro) -- , [Ruby](http://www.ruby-lang.org/en/) +-- Examples +-- ======== +-- * [Tetris](http://texodus.github.com/forml/tetris.html) +-- * [Prelude](http://texodus.github.com/forml/prelude.html) +-- * [Parsec](http://texodus.github.com/forml/parsec.html) + -- Installation -- ============ - --- Mac OSX (tested on Snow Leopard & Lion). Note that Forml also requires +-- (tested on Snow Leopard, Lion, Ubuntu). Note that Forml also requires -- [Closure](https://developers.google.com/closure/) for optimizations and -- either [Phantom.js](http://phantomjs.org) or [Node.js](http://nodejs.org) @@ -110,33 +119,31 @@ -- 
$ forml -docs test.forml
+-- Be sure to check out [forml-mode](https://github.com/jvshahid/forml-mode) if you're into EMACS. + -- Tutorial -- ======== -- This is unfortunately not comprehensive, and presumes some working knowledge of --- ML or Haskell. For more examples, see the annotated --- [prelude](http://texodus.github.com/forml/prelude.html), --- [parsec](http://texodus.github.com/forml/parsec.html) and [tetris](http://texodus.github.com/forml/tetris.html). - --- Forml supports a flexible, forgiving syntax that supports many synonymous forms. +-- ML or Haskell. Forml supports a flexible, forgiving syntax that supports many synonymous forms. -- This will be illustrated by adherring to an entirely random, arbitrary style throughout. -- The basic unit of code organization in forml is the `module`, which is simply --- a collection of definitions in a namespace (see [Modules](#)). --- Within a module, the compiler recognizes strictly ordered logical sections divided by --- `open` statements and sub modules; within a section, however, declarations --- can be in any order. +-- a collection of definitions in a namespace. module readme +-- Within a module, the compiler recognizes strictly ordered logical sections divided by +-- `open` statements and sub modules; within a section, however, declarations +-- can be in any order. `open` statements create local aliases for their own public definitions, which will shadow previously defined symbols. + open prelude open prelude.string -- Definitions -- ----------- - - -- Simple function. Forml allows functions to be written in ML style, or - -- in more traditional java style. + -- Simple functions. Forml allows function application via spaces as in + -- ML, or via `()`'s in a more traditional c style - square x = x * x @@ -159,22 +166,10 @@ fib' 1 = 1 fib' n = fib' (n - 1) + fib' (n - 2) - -- Operators can be defined much like in Haskell. Precedence is currently fixed, - -- though you can declare right associative operators by ending them with a `:`. - -- For performance, you can declare functions to be `inline`. This example - -- will compile to a loop, as it is tail recursive. - - inline (**): - - String -> Num -> String - text ** n = - - var f(_, 0, acc) = acc -- `let` and `var` are synonyms - f(text, n, acc) = - f(text, n - 1, acc +++ text) - - in f(text, n, "") -- `in` is optional - + -- Operators can be defined much like in Haskell. Precedence is currently + -- fixed, + -- though you can declare right associative operators by ending them with + -- a `:` character. -- Testing -- ------- @@ -188,8 +183,6 @@ fib' 7 == 13 fib' 0 == 0 - "hello" ** 3 == "hellohellohello" - length ("a" ** 10000) == 10000 -- For example, this file is the result of running the forml compiler with the `-docs` -- flag for [readme.forml](https://github.com/texodus/forml/blob/master/src/forml/readme.forml), @@ -200,7 +193,6 @@ -- Modules -- ------- - -- Namespaces are not symbols, so this won't work: -- 
    prelude.log "Hello, World!"    -- Won't compile!
@@ -213,18 +205,26 @@ open prelude.array as array array.map fib [3,4,5] == [2,3,5] + + -- Notice this means aliased modules can be passed as arguments + + mmap dict f xs = dict.map f xs + + mmap array fib [3,4,5] == [2,3,5] -- Records -- ------- - - -- Forml has the basic primative types from Javascript: Num, String, Bool; plus - -- a record, which is structurally typed and implemented as a simple Javascript object. + -- Forml has the basic primative types from Javascript: Num, String, + -- Bool; plus + -- a record, which is structurally typed (and implemented as a simple + -- Javascript object, for the curious). person name address = { name = name address = address message = "`name` lives at `address`" + say msg = "`name` says '`msg`'" } person("Andrew", "123 Fake St.").message is "Andrew lives at 123 Fake St." @@ -232,30 +232,94 @@ point = {x: 10, y: 10} 20 == point.x + point.y - - -- Also supports partial records. + -- The sugared syntax `.field` represents an anonymous accessor function + -- for convenient piping. + + person "Wilfred" "couch" + |> .say "I'm lazy" + + == "Wilfred says 'I'm lazy'" + + var people = [ + person "Josh" "Jersey" + person "John" "Egypt" + ] in + + people 'map (.name) == [ "Josh", "John" ] + + -- Records can be destructured in function argumentsn and can partially match + -- with the `_` character. This type of function will apply to + -- any record with at least the keys in the partial match. + magnitude {x: x, y: y, _} = sqrt (square x + square y) magnitude {x: 3, y: 4, other: "test"} == 5 magnitude {x: 4, y: 3, test: "other"} == 5 - - -- Anonymous functions also follow Haskell, can be written with `\` or `λ`, and - -- allows pattern seperation via `|` - - -- Note this function mutates its argument, so we name it with an exclamation. + -- Functions + -- --------- + -- Anonymous functions also follow Haskell, can be written with `\` or + -- `λ`, and allows pattern seperation via `|` - map!: (a -> b) -> Array a -> Array b - map! f xs = do! `xs.map(f)` + map: (a -> b) -> Array a -> Array b + map f xs = do! `xs.map(f)` let fil = λ x when x > 5 = x + | 5 = 0 | x = 5 - map! fil [2, 6, 3, 7] is [5, 6, 5, 7] + map fil [2, 6, 3, 7, 5] is [5, 6, 5, 7, 0] + -- All functions are curried, and can be partiall applied - even + -- operators. + + x +* y = (2 * x) + (2 * y) + + [1, 2, 3] 'map ((+*) 2) == [6, 8, 10] + + add_twelve x y = x + y + 12 + + let f = add_twelve 5 + f 10 == 27 + + -- Inlines + -- ------- + -- Function inlining allows for macro like behavior, like lazy + -- & conditional evaluation (the `'` operator here is equivalent + -- is "left-pipe" application, `x |> f == x 'f`). + + inline whenever x f = + if x + then f + else {} + + error "FAILURE" 'whenever (6 < 5) == {} + + -- Tail Call Optimization + -- ---------------------- + -- This example will compile to a `for` loop, as it is + -- [tail recursive](http://en.wikipedia.org/wiki/Tail_call). + -- `var` is a synonym for `let`, and `in` is an optional binding + -- separator. + + (**): + + String -> Num -> String + text ** n = + + var f(_, 0, acc) = acc + f(text, n, acc) = + f(text, n - 1, acc +++ text) + + in f(text, n, "") + + "hello" ** 3 == "hellohellohello" + length ("a" ** 10000) == 10000 + + -- Interop & Side Effects -- ---------------------- -- Forml technically allows unrestricted side effects, but by default @@ -267,7 +331,7 @@ `console.log("Hello World")` -- Calls to Javascript always return type `JS a` x <- `Math.sqrt(9)` -- `x` is inferred to be the unrestricted type `a` let z = x + 1 -- `x` is now restricted to type `Num` - return (z + 1) -- type of `hello_world` is inferred to be `JS Num` + return (z + 1) -- type of `hello_world` is inferred to be `JS Num` 8 == do! hello_world >>= λx = `x + 3` @@ -290,11 +354,10 @@ -- Types, Aliases & Unions -- ----------------------- - - -- Forml lacks algebraic data types in the ML sense, instead opting for - -- only structural typing of records. However, you can add explicit type - -- signatures to tell the Forml compiler it is OK to overload the types - -- of specific symbols. + -- Forml is strong, statically typed, and types are inferred and + -- checked at copmile time. Unlike in traditional Hindley Milner style + -- inferrence, forml allows you to break the rules with some explicit + -- type annotations. num_or_string: @@ -302,29 +365,34 @@ | x when num? x = "Num" | _ = "String" - -- Types may be given a polymorphic alias in much the same way you'd - -- define a function. + -- Structural types look just like the records they represent. - Maybe a = {just: a} | {nothing} + unwrap: {box: a} -> a + unwrap {box: x} = x - -- algebraic data types to be declared in a local scope, for all - -- records which are structurally equivalent to those declared. For instance, - -- we could declare a `Maybe a` ADT in forml via - + -- Algebraic data types and type aliases are declared the same way + -- (where the `type` keyword is optional). `{nothing}` here is + -- shorthand for the record type {nothing: {}}, useful for enum types. - -- ... where `{nothing}` is shorthand for the strucural type `{nothing: {}}`. - -- When `Maybe a` is in scope, any record type with only the `just` or `nothing` - -- keys will be inferred to be a type `Maybe a`. + Maybe a = {just: a} | {nothing} + -- Notice there are no explicit type constructors - in forml, types + -- constructor functions are inferred from the fields of a record + -- and applied automatically. + -- For example, when `Maybe a` is in scope, any record type with the `just` + -- or `nothing` keys will be inferred to be a type `Maybe a`. + maybe x {just: y} = y maybe x {nothing} = x maybe 3 {just: 4} == 4 maybe 3 {nothing} == 3 - -- Once a type such as this has a name, you may even refer to it recursively - -- (note the `type` keyword is always optional). + type Tree a = + {left_tree: Tree a, right_tree: Tree a} + | {leaf: a} + type List a = { head: a, tail: List a } | { nil } sum: List Num -> Num @@ -336,6 +404,10 @@ tail: { nil } } } == 5 + -- Lists have a syntax sugar as well. + + sum [: 3, 4, 5 ] == 12 + -- In case this sort of things floats your boat, you can also declare -- polymorphic types in "java" style, with `< >`. @@ -348,6 +420,19 @@ -- Changes -- ======= + + -- 0.2 + + -- * Incremental compilation, increased compilation speed + -- * Made inlines inline their arguments as well when fully applied, + -- like a macro. Code generator works better with Closure, resulting + -- in smaller, more optimized JS. + -- * One-sided `if` expressions. + -- * `where` expressions. + -- * Silent mode + -- * Fixed namespace rendering error. + -- * Fixed definition ordering in let bindings. + -- * Fixed indentation error -- 0.1.3 diff --git a/src/forml/tests.forml b/src/forml/tests.forml --- a/src/forml/tests.forml +++ b/src/forml/tests.forml @@ -10,16 +10,16 @@ module "Benchmarks for the prelude" - title x = - do log "\r " - log x - return true - open prelude open prelude.speedtest open prelude.list open prelude.string + title x = + do log "\r " + log x + return true + -- Here we have 5 implementations of -- (Project Euler problem #1)[http://projecteuler.net/problem=1]. -- The first is simply a native JS implementation. @@ -152,3 +152,19 @@ var x = do! `[ {x: 1}, {x: 2}, {x: 3} ]` stringify (x !! 0).x == "1" + + +module "Test that definition names dont collide with namespaces" + + open prelude + + module nametest + x = 1 + + nametest = {} + + module "Seperator" + + open nametest + + x == 1 diff --git a/src/hs/Forml/CLI.hs b/src/hs/Forml/CLI.hs --- a/src/hs/Forml/CLI.hs +++ b/src/hs/Forml/CLI.hs @@ -1,7 +1,5 @@ - module Forml.CLI where - import Control.Monad.State hiding (lift) import System.Console.ANSI @@ -12,62 +10,79 @@ import Data.String.Utils - data TestMode = NoTest | Node | Phantom data RunConfig = RunConfig { inputs :: [String] , output :: String , show_types :: Bool , optimize :: Bool + , silent :: Bool + , flush :: Bool , run_tests :: TestMode , write_docs :: Bool + , implicit_prelude :: Bool , watch :: Bool } parseArgs :: [String] -> RunConfig parseArgs = fst . runState argsParser - where argsParser = do args <- get case args of - [] -> return $ RunConfig [] "default" False True Phantom False False + [] -> return $ RunConfig [] "default" False True False False Phantom False True False (x':xs) -> do put xs case x' of - "-w" -> do x <- argsParser - return $ x { watch = True } - "-docs" -> do x <- argsParser - return $ x { write_docs = True } - "-t" -> do x <- argsParser - return $ x { show_types = True } - "-no-opt" -> do x <- argsParser - return $ x { optimize = False } - "-no-test" -> do x <- argsParser - return $ x { run_tests = NoTest } - "-node-test" -> do x <- argsParser - return $ x { run_tests = Node } - "-o" -> do (name:ys) <- get - put ys - RunConfig a _ c d e f g <- argsParser - return $ RunConfig a name c d e f g - ('-':_) -> error "Could not parse options" - z -> do RunConfig a _ c d e f g <- argsParser - let b = last $ split "/" $ head $ split "." z + "-w" -> do x <- argsParser + return $ x { watch = True } + "-docs" -> do x <- argsParser + return $ x { write_docs = True } + "-t" -> do x <- argsParser + return $ x { show_types = True } + "-no-prelude" -> do x <- argsParser + return $ x { implicit_prelude = False } + "-no-opt" -> do x <- argsParser + return $ x { optimize = False } + "-silent" -> do x <- argsParser + return $ x { silent = True } + "-flush" -> do x <- argsParser + return $ x { flush = True } + "-no-test" -> do x <- argsParser + return $ x { run_tests = NoTest } + "-node-test" -> do x <- argsParser + return $ x { run_tests = Node } + "-o" -> do (name:ys) <- get + put ys + RunConfig a _ c d e f g h i j <- argsParser + return $ RunConfig a name c d e f g h i j + ('-':_) -> error "Could not parse options" + z -> do RunConfig a _ c d e f g h i j <- argsParser + let b = last $ split "/" $ head $ split "." z + return $ RunConfig (x':a) b c d e f g h i j - return $ RunConfig (x':a) b c d e f g +type StatusLogger a = String -> a -> IO a +status_logger :: [SGR] -> String -> StatusLogger a +status_logger sgrs rep = + let logger str out = + colors ((putStr $ "[" ++ rep ++ "] " ++ str) >> return out) $ + do putStr "\r[" + setSGR sgrs + putStr rep + setSGR [] + putStrLn$ "] " ++ str + return out in + logger +success :: String -> a -> IO a +success = status_logger [SetColor Foreground Dull Green] "*" warn :: String -> a -> IO a -warn x js = colors ((putStr $ "[-] " ++ x) >> return js) $ - do putStr "\r[" - setSGR [SetColor Foreground Dull Yellow] - putStr "-" - setSGR [] - putStrLn$ "] " ++ x - return js +warn = status_logger [SetColor Foreground Dull Yellow] "-" +failure :: String -> a -> IO a +failure = status_logger [SetColor Foreground Dull Red] "X" + colors :: IO a -> IO a -> IO a colors failure success = - do (_, Just std_out', _, p) <- createProcess (shell "tput colors 2> /dev/null") { std_out = CreatePipe } waitForProcess p @@ -76,36 +91,23 @@ [(x, "")] | x > (2 :: Integer) -> success _ -> failure +type Runner a = String -> IO (Either [String] a) -> IO a +run_silent :: Runner a +run_silent _ d = + do d' <- d + case d' of + Right y -> do return y + Left y -> do exitFailure -monitor :: String -> IO (Either [String] a) -> IO a +monitor :: Runner a monitor x d = do colors (return ()) $ putStr $ "[ ] " ++ x hFlush stdout d' <- d case d' of - Right y -> colors ((putStrLn $ "[*] " ++ x) >> return y) $ - do putStr "\r[" - setSGR [SetColor Foreground Dull Green] - putStr "*" - setSGR [] - putStrLn$ "] " ++ x - return y - Left y -> colors (errors y) $ - do putStr "\r[" - setSGR [SetColor Foreground Dull Red] - putStr "X" - setSGR [] - putStrLn$ "] " ++ x - putStrLn "" - if length y <= 5 + Right y -> success x y + Left y -> do failure x y + if length y <= 5 then mapM putStrLn y >> return () else mapM putStrLn (take 5 y) >> putStrLn ("\n" ++ show (length y - 5) ++ " additional errors") - exitFailure - - where errors y = - do putStrLn ("[X] " ++ x) - if length y <= 5 - then mapM putStrLn y >> return () - else mapM putStrLn (take 5 y) >> putStrLn ("\n" ++ show (length y - 5) ++ " additional errors") - exitFailure - + exitFailure diff --git a/src/hs/Forml/Closure.hs b/src/hs/Forml/Closure.hs --- a/src/hs/Forml/Closure.hs +++ b/src/hs/Forml/Closure.hs @@ -25,18 +25,14 @@ import Data.URLEncoded import Data.Maybe (fromMaybe) - - closure_local :: String -> String -> IO (Either a String) closure_local x y = - do env' <- L.lookup "CLOSURE" <$> getEnvironment case env' of Just env -> do exists' <- doesFileExist env if exists' - then do putStr "[local]" - hFlush stdout + then do hFlush stdout writeFile "temp.js" x system$ "java -jar $CLOSURE --compilation_level " ++ y @@ -46,10 +42,8 @@ system "rm temp.js" system "rm temp.compiled.js" return $ Right js - else putStr " remote]" >> hFlush stdout >> closure x y - Nothing -> putStr " remote]" >> hFlush stdout >> closure x y - - + else closure x y + Nothing -> closure x y closure :: String -> String -> IO (Either a String) closure x z = do let uri = fromMaybe undefined $ parseURI "http://closure-compiler.appspot.com/compile" @@ -65,7 +59,4 @@ rsp <- simpleHTTP (Request uri POST args y) txt <- getResponseBody rsp - putStr "[remote]" - hFlush stdout - - return$ Right txt + return $ Right txt diff --git a/src/hs/Forml/Doc.hs b/src/hs/Forml/Doc.hs --- a/src/hs/Forml/Doc.hs +++ b/src/hs/Forml/Doc.hs @@ -38,8 +38,8 @@ to_literate :: String -> String -> String to_literate "(Prelude)" = id to_literate filename - | (head . tail . split "." $ filename) == "forml" = unlines . map l . lines - | otherwise = id + | (head . reverse . split "." $ filename) == "lformal" = id + | otherwise = unlines . map l . lines where l (lstrip -> '-':'-':xs) = lstrip xs l x = " " ++ x diff --git a/src/hs/Forml/Javascript.hs b/src/hs/Forml/Javascript.hs --- a/src/hs/Forml/Javascript.hs +++ b/src/hs/Forml/Javascript.hs @@ -5,14 +5,14 @@ module Forml.Javascript (render, render_spec) where -import Language.Javascript.JMacro -import Prelude hiding (curry, (++)) - -import Forml.Types.Statement +import Prelude hiding (curry, (++)) import qualified Data.Map as M +import Language.Javascript.JMacro + import Forml.Javascript.Backend +import Forml.Types.Statement import Forml.Parser @@ -23,9 +23,6 @@ instance (Compress a, Compress b) => Compress (a, b) where comp (a, b) = (comp a, comp b) -instance (Compress a) => Compress [a] where - comp x = map comp x - instance (Functor m, Compress a) => Compress (m a) where comp x = fmap comp x @@ -41,29 +38,15 @@ comp (PPostStat a b c) = PPostStat a b (comp c) comp (AssignStat a b) = AssignStat (comp a) (comp b) comp (UnsatBlock a) = UnsatBlock (comp a) - comp x = x - -- comp (DeclStat Ident (Maybe JLocalType) - -- comp (UnsatBlock (IdentSupply JStat) - -- comp (AntiStat String - -- comp (ForeignStat Ident JLocalType - -- comp (BreakStat - instance Compress JVal where comp (JList xs) = JList (comp xs) comp (JHash m) = JHash (M.map comp m) comp (JFunc xs x) = JFunc xs (comp x) comp (UnsatVal x) = UnsatVal (comp x) - comp x = x - -- comp x@(JVar _) = x - -- comp x@(JDouble _) = x - -- comp x@(JInt _) = x - -- comp x@(JStr _) = x - -- comp x@(JRegEx _) = x - instance Compress JExpr where comp (SelExpr e (StrI i)) = IdxExpr (comp e) (ValExpr (JStr i)) -- Closure fix - advanced mode nukes these comp (IdxExpr a b) = IdxExpr (comp a) (comp b) @@ -71,9 +54,6 @@ comp (PPostExpr a b c) = PPostExpr a b (comp c) comp (IfExpr a b c) = IfExpr (comp a) (comp b) (comp c) comp (NewExpr a) = NewExpr (comp a) - - -- comp (ApplExpr (ValExpr (UnsatVal (JFunc [z] y))) [x]) - comp (ApplExpr a b) = ApplExpr (comp a) (map comp b) comp (TypeExpr a b c) = TypeExpr a (comp b) c comp (ValExpr a) = ValExpr (comp a) @@ -81,10 +61,12 @@ comp _ = error "Compression" render :: Program -> String -> Program -> String -render (Program ys) src (Program xs) = show . renderJs $ (comp . runJS src . toJS . map (empty_meta Library ys) $ xs) +render (Program ys) src (Program xs) = + show . renderJs . comp . runJS src . toJS . map (empty_meta Library ys) $ xs render_spec :: Program -> String -> Program -> String -render_spec (Program ys) src (Program xs) = show . renderJs . wrap . runJS src . toJS . map (empty_meta Test ys) $ xs +render_spec (Program ys) src (Program xs) = + show . renderJs . wrap . runJS src . toJS . map (empty_meta Test ys) $ xs where wrap x = [jmacro| describe("", function() { `(x)`; }); |] diff --git a/src/hs/Forml/Javascript/Test.hs b/src/hs/Forml/Javascript/Test.hs --- a/src/hs/Forml/Javascript/Test.hs +++ b/src/hs/Forml/Javascript/Test.hs @@ -21,9 +21,10 @@ import Forml.Static test :: RunConfig -> String -> String -> String -> IO () -test RunConfig { run_tests = Node } js title tests = +test rc @ RunConfig { run_tests = Node } js title tests = + let runner = if silent rc then run_silent else monitor in - monitor [qq|Testing {title}.js [Node.js]|] $ + runner [qq|Testing {title}.js [Node.js]|] $ do (Just std_in, Just std_out, _, p) <- createProcess (proc "node" []) { std_in = CreatePipe, std_out = CreatePipe } @@ -43,8 +44,9 @@ ExitSuccess -> return$ Right () test rc @ RunConfig { run_tests = Phantom } js title tests = + let runner = if silent rc then run_silent else monitor in - monitor [qq|Testing {title}.js [Phantom.js]|] $ + runner [qq|Testing {title}.js [Phantom.js]|] $ do writeFile (output rc ++ ".phantom.js") (jquery ++ jasmine ++ js ++ tests ++ console) @@ -57,10 +59,10 @@ z <- waitForProcess p - system$ "rm " ++ output rc ++ ".phantom.js" + system $ " rm " ++ output rc ++ ".phantom.js" case z of ExitFailure _ -> return$ Left [] ExitSuccess -> return$ Right () -test _ _ _ _ = warn "Testing" () +test rc _ _ _ = if silent rc then do return () else warn "Testing" () diff --git a/src/hs/Forml/Optimize.hs b/src/hs/Forml/Optimize.hs --- a/src/hs/Forml/Optimize.hs +++ b/src/hs/Forml/Optimize.hs @@ -14,19 +14,23 @@ {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DeriveGeneric #-} module Forml.Optimize where import System.IO.Unsafe () -import Language.Javascript.JMacro +import Control.Applicative +import Control.Monad import qualified Data.Map as M +import qualified Data.List as L -import Control.Applicative -import Control.Monad import Data.Char import Data.Monoid +import Data.Serialize +import Language.Javascript.JMacro + import Forml.Types.Axiom import Forml.Types.Definition import Forml.Types.Expression @@ -34,19 +38,19 @@ import Forml.Types.Pattern import Forml.Types.Statement hiding (Test, find, modules, namespace) import Forml.Types.Symbol - +import Forml.Javascript.Utils hiding ((++)) +import Forml.Deps import Forml.TypeCheck.Types hiding (get_namespace) - import Forml.Parser import Forml.Parser.Utils - import qualified Forml.Javascript.Utils as J import Prelude hiding (curry) import Text.Parsec.Pos (newPos) +import GHC.Generics -data Inlineable = InlineSymbol Symbol | InlineRecord (Expression Definition) deriving (Eq) +data Inlineable = InlineSymbol Symbol | InlineRecord (Expression Definition) deriving (Eq, Generic) type Inlines = [((Namespace, Inlineable), (Match (Expression Definition), Expression Definition))] type Inline = [(Inlineable, (Match (Expression Definition), Expression Definition))] @@ -55,10 +59,13 @@ , assumptions :: [(Namespace, [Assumption])] , inlines :: Inlines , tco :: [String] - , env :: Inline } + , env :: Inline } deriving (Eq, Generic) data Optimizer a = Optimizer (OptimizeState -> (OptimizeState, a)) +instance Serialize Inlineable +instance Serialize OptimizeState + instance Monad Optimizer where fail x = Optimizer (\y -> error x) @@ -113,56 +120,189 @@ get_addr :: Addr a -> a get_addr (Addr _ _ x) = x + +afmap d f (EqualityAxiom (Match pss cond) expr) = + EqualityAxiom (Match pss (fmap (replace_expr d f) cond)) (fmap (replace_expr d f) expr) + +afmap _ _ t = t + +dfmap d f (Definition a b c as) = + Definition a b c (fmap (afmap d f) as) + +replace_expr d f (ApplyExpression a b) = + ApplyExpression (replace_expr d f a) (replace_expr d f `map` b) +replace_expr d f (IfExpression a b Nothing) = + IfExpression (replace_expr d f a) (replace_expr d f b) Nothing +replace_expr d f (IfExpression a b (Just c)) = + IfExpression (replace_expr d f a) (replace_expr d f b) (Just (replace_expr d f c)) +replace_expr d f (LiteralExpression x) = + LiteralExpression x +replace_expr d f (JSExpression j) = + JSExpression (replace_jexpr d j) +replace_expr d f (LazyExpression a b) = + LazyExpression (fmap (replace_expr d f) a) b +replace_expr d f (FunctionExpression as) = + FunctionExpression (map (afmap d f) as) +replace_expr d f (RecordExpression vs) = + RecordExpression (fmap (replace_expr d f) vs) +replace_expr d f (LetExpression ds e) = + LetExpression (dfmap d f `map` ds) (replace_expr d f e) +replace_expr d f (ListExpression xs) = + ListExpression (map (replace_expr d f) xs) +replace_expr d f (AccessorExpression a ss) = + AccessorExpression (fmap (replace_expr d f) a) ss +replace_expr d f (SymbolExpression (Symbol s)) = f (Symbol s) +replace_expr d f (SymbolExpression s) = SymbolExpression s + +replace_expr _ _ s = s + + + +replace_stat dict (ReturnStat x) = ReturnStat (replace_jexpr dict x) +replace_stat dict (IfStat a b c) = IfStat (replace_jexpr dict a) (replace_stat dict b) (replace_stat dict c) +replace_stat dict (WhileStat a b c) = WhileStat a (replace_jexpr dict b) (replace_stat dict c) +replace_stat dict (ForInStat a b c d) = ForInStat a b (replace_jexpr dict c) (replace_stat dict d) +replace_stat dict (SwitchStat a b c) = SwitchStat (replace_jexpr dict a) b (replace_stat dict c) +replace_stat dict (TryStat a b c d) = TryStat (replace_stat dict a) b (replace_stat dict c) (replace_stat dict d) +replace_stat dict (BlockStat xs) = BlockStat (replace_stat dict `map` xs) +replace_stat dict (ApplStat a b) = ApplStat (replace_jexpr dict a) (replace_jexpr dict `map` b) +replace_stat dict (PPostStat a b c) = PPostStat a b (replace_jexpr dict c) +replace_stat dict (AssignStat a b) = AssignStat (replace_jexpr dict a) (replace_jexpr dict b) +replace_stat dict (UnsatBlock a) = UnsatBlock (replace_stat dict `fmap` a) + +replace_stat dict (DeclStat v t) = DeclStat v t +replace_stat dict (UnsatBlock ident_supply) = UnsatBlock (replace_stat dict `fmap` ident_supply) +replace_stat dict (AntiStat s) = AntiStat s +replace_stat dict (ForeignStat s t) = ForeignStat s t +replace_stat dict (BreakStat s) = (BreakStat s) + +replace_jval dict (JList xs) = JList (replace_jexpr dict `map` xs) +replace_jval dict (JHash m) = JHash (M.map (replace_jexpr dict) m) +replace_jval dict (JFunc xs x) = JFunc xs (replace_stat dict x) +replace_jval dict (UnsatVal x) = UnsatVal (replace_jval dict `fmap` x) +replace_jval dict x@(JDouble _) = x +replace_jval dict x@(JInt _) = x +replace_jval dict x@(JStr _) = x +replace_jval dict x@(JRegEx _) = x +replace_jval dict (JVar (StrI y)) = + case y `lookup` dict of + Just y' -> JVar . StrI . show . renderJs . toJExpr $ y' + Nothing -> JVar (StrI y) +replace_jval _ (JVar x) = JVar x + + +replace_jexpr dict (SelExpr e (StrI i)) = IdxExpr (replace_jexpr dict e) (ValExpr (JStr i)) -- Closure fix - advanced mode nukes these +replace_jexpr dict (IdxExpr a b) = IdxExpr (replace_jexpr dict a) (replace_jexpr dict b) +replace_jexpr dict (InfixExpr a b c) = InfixExpr a (replace_jexpr dict b) (replace_jexpr dict c) +replace_jexpr dict (PPostExpr a b c) = PPostExpr a b (replace_jexpr dict c) +replace_jexpr dict (IfExpr a b c) = IfExpr (replace_jexpr dict a) (replace_jexpr dict b) (replace_jexpr dict c) +replace_jexpr dict (NewExpr a) = NewExpr (replace_jexpr dict a) +replace_jexpr dict (ApplExpr a b) = ApplExpr (replace_jexpr dict a) (replace_jexpr dict `map` b) +replace_jexpr dict (TypeExpr a b c) = TypeExpr a (replace_jexpr dict b) c +replace_jexpr dict (ValExpr a) = ValExpr (replace_jval dict a) +replace_jexpr dict (UnsatExpr a) = UnsatExpr (replace_jexpr dict `fmap` a) + + +instance (Optimize a) => Optimize (Maybe a) where + + optimize (Just x) = Just <$> optimize x + optimize Nothing = return Nothing + instance (Optimize a) => Optimize (Addr a) where optimize (Addr s e a) = Addr s e <$> optimize a instance Optimize (Expression Definition) where - optimize (ApplyExpression f' @ (SymbolExpression f) args) = + optimize (ApplyExpression (ApplyExpression a b) c) = + optimize (ApplyExpression a (b ++ c)) + optimize (ApplyExpression (SymbolExpression s) args) = do + + is <- get_env + case (InlineSymbol s) `lookup` is of + Just ((Match pss _), ex) | length pss == length args -> do + args' <- mapM optimize args + optimize $ replace_expr (concat $ zipWith gen_expr pss args') (gen_exprs args pss) ex + _ -> ApplyExpression <$> optimize (SymbolExpression s) <*> mapM optimize args + + where + + gen_exprs args' pats (Symbol s) = + case s `lookup` (concat $ zipWith gen_expr pats args') of + Just ex -> ex + Nothing -> (SymbolExpression (Symbol s)) + + gen_exprs _ _ s = SymbolExpression s + + gen_expr (VarPattern x) y = + [(x, y)] + gen_expr (RecordPattern xs _) y = + concat $ zipWith gen_expr (M.elems xs) (map (to_accessor y) $ M.keys xs) + gen_expr (ListPattern xs) y = + concat $ zipWith gen_expr xs (map (to_array y) [0..]) + gen_expr (AliasPattern xs) y = + concatMap (flip gen_expr y) xs + gen_expr _ _ = + [] + + to_array expr idx = + JSExpression [jmacroE| `(expr)`[idx] |] + + to_accessor expr sym = + AccessorExpression (Addr undefined undefined expr) [sym] + + optimize (ApplyExpression f' args ) = + ApplyExpression <$> optimize f' <*> mapM optimize args + + optimize a @ (AccessorExpression x xs) = + do is <- get_env - case (InlineSymbol f) `lookup` is of - Just (m @ (Match pss _), ex) | length pss == length args -> + case (InlineRecord a) `lookup` is of + Just (m @ (Match pss _), ex) -> - do args' <- mapM optimize args - ex' <- optimize ex + do ex' <- optimize ex m' <- optimize m - return $ ApplyExpression (FunctionExpression [EqualityAxiom m' (Addr undefined undefined ex')]) args' + return $ FunctionExpression [EqualityAxiom m' (Addr undefined undefined ex')] - _ -> ApplyExpression <$> optimize f' <*> mapM optimize args + _ -> flip AccessorExpression xs <$> optimize x - optimize (ApplyExpression a @ (AccessorExpression x xs) args) = - + optimize (SymbolExpression f) = + do is <- get_env - case (InlineRecord a) `lookup` is of - Just (m @ (Match pss _), ex) | length pss == length args -> + case (InlineSymbol f) `lookup` is of + Just (m @ (Match pss _), ex) -> - do args' <- mapM optimize args - ex' <- optimize ex + do ex' <- optimize ex m' <- optimize m - return $ ApplyExpression (FunctionExpression [EqualityAxiom m' (Addr undefined undefined ex')]) args' + return $ FunctionExpression [EqualityAxiom m' (Addr undefined undefined ex')] - _ -> ApplyExpression <$> optimize a <*> mapM optimize args + _ -> return $ SymbolExpression f optimize (ApplyExpression f args) = ApplyExpression <$> optimize f <*> mapM optimize args optimize (IfExpression a b c) = IfExpression <$> optimize a <*> optimize b <*> optimize c optimize (LazyExpression x l) = flip LazyExpression l <$> optimize x optimize (FunctionExpression xs) = FunctionExpression <$> mapM optimize xs - optimize (AccessorExpression x xs) = flip AccessorExpression xs <$> optimize x optimize (ListExpression ex) = ListExpression <$> mapM optimize ex - optimize (LetExpression ds ex) = + optimize (LetExpression ds ex) = do - do ds' <- mapM optimize ds - LetExpression ds' <$> optimize ex + stmts' <- mapM optimize (sorted_defs . map DefinitionStatement $ ds) + let stmts = map (\(DefinitionStatement d) -> d) stmts' + LetExpression (filter is_inline stmts) <$> optimize ex + where + + is_inline (Definition _ True _ _) = False + is_inline _ = True + optimize (RecordExpression (M.toList -> xs)) = let (keys, vals) = unzip xs in RecordExpression . M.fromList . zip keys <$> mapM optimize vals - optimize x = return x + optimize (JSExpression x) = return $ JSExpression x + optimize (LiteralExpression x) = return $ LiteralExpression x -- TODO wrong @@ -182,15 +322,15 @@ instance Optimize Definition where - optimize (Definition a True name [eq @ (EqualityAxiom _ _)]) = + optimize (Definition a True name [eq @ (EqualityAxiom m ex)]) = - do (EqualityAxiom m ex) <- optimize eq + do eq <- optimize eq is <- get_inline e <- get_env ns <- get_namespace set_inline (((ns, (InlineSymbol name)), (m, get_addr ex)) : is) set_env ((InlineSymbol name, (m, get_addr ex)) : e) - return (Definition a True name [EqualityAxiom m ex]) + return (Definition a True name [eq]) optimize (Definition a True c (TypeAxiom _ : x)) = optimize (Definition a True c x) optimize (Definition _ True name _) = fail$ "Illegal inline definition '" ++ show name ++ "'" @@ -207,7 +347,8 @@ is_recursive' (ApplyExpression (SymbolExpression x) _) | name == x = True is_recursive' (LetExpression _ e) = is_recursive' e - is_recursive' (IfExpression _ a b) = is_recursive' a || is_recursive' b + is_recursive' (IfExpression _ a (Just b)) = is_recursive' a || is_recursive' b + is_recursive' (IfExpression _ a _) = is_recursive' a is_recursive' _ = False axioms (t @ (TypeAxiom _): xs) = t : axioms xs @@ -263,7 +404,7 @@ })() |] replace pss (LetExpression x e) = LetExpression x (replace pss e) - replace pss (IfExpression x a b) = IfExpression x (replace pss a) (replace pss b) + replace pss (IfExpression x a b) = IfExpression x (replace pss a) (replace pss `fmap` b) replace _ x = x bind_local :: ToJExpr a => [String] -> [a] -> JStat @@ -281,14 +422,20 @@ optimize (DefinitionStatement d) = DefinitionStatement <$> optimize d optimize (ExpressionStatement (Addr s e x)) = ExpressionStatement . Addr s e <$> optimize x - optimize (ModuleStatement x xs) = + optimize (ModuleStatement x xs) = do - do ns <- get_namespace - set_namespace$ ns `mappend` x - xs' <- with_env$ optimize xs - set_namespace ns - return$ ModuleStatement x xs' + ns <- get_namespace + set_namespace$ ns `mappend` x + xs' <- with_env$ optimize xs + set_namespace ns + return$ ModuleStatement x xs' + where + + get_defs [] = [] + get_defs (DefinitionStatement d : xs) = [d] : get_defs xs + get_defs (_ : xs) = get_defs xs + optimize ss @ (ImportStatement (Namespace x) (Just alias)) = do is <- get_inline @@ -356,21 +503,24 @@ instance Optimize [Statement] where - optimize [] = return [] - optimize (x:xs) = + optimize xs = do + let (tests, defs) = L.partition is_expression xs + xs <- mapM optimize (sorted_defs defs) + ys <- mapM optimize tests + return (xs ++ ys) - do x <- optimize x - xs <- optimize xs - return (x:xs) + where + is_expression (ExpressionStatement _) = True + is_expression _ = False instance Optimize Program where optimize (Program xs) = Program <$> optimize xs -run_optimizer :: [Program] -> [(Namespace, [Assumption])] -> [Program] -run_optimizer ps as = g ps as gen_state +gen_state as = OptimizeState (Namespace []) as [] [] [] - where g ps @ (optimize . head -> Optimizer f) as st = case f st of (st', p) -> p : g (tail ps) as st' +run_optimizer :: Program -> OptimizeState -> (OptimizeState, Program) +run_optimizer p @ (optimize -> Optimizer f) as = f as - gen_state = OptimizeState (Namespace []) as [] [] [] + diff --git a/src/hs/Forml/Parser.hs b/src/hs/Forml/Parser.hs --- a/src/hs/Forml/Parser.hs +++ b/src/hs/Forml/Parser.hs @@ -5,11 +5,14 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveGeneric #-} module Forml.Parser where import Control.Applicative import Data.String.Utils +import qualified Data.Serialize as S +import GHC.Generics import Forml.Parser.Utils hiding (spaces) import Text.Parsec hiding (State, label, many, parse, (<|>)) @@ -17,7 +20,7 @@ -- Parsing -- ----------------------------------------------------------------------------- --- A Sonnet program is represented by a set of statements +-- A Forml program is represented by a set of statements parseForml :: String -> String -> Either ParseError Program parseForml name src = case parse ((comment <|> return "\n") `manyTill` eof) "Cleaning comments" src of @@ -105,7 +108,9 @@ highlight ((a, b):xs) y = highlight xs (replace ("--" ++ serial a b) ("") (replace (serial a b ++ "--") "" y)) -newtype Program = Program [Statement] +newtype Program = Program [Statement] deriving (Generic) + +instance S.Serialize Program instance Show Program where show (Program ss) = sep_with "\n\n" ss diff --git a/src/hs/Forml/Parser/Utils.hs b/src/hs/Forml/Parser/Utils.hs --- a/src/hs/Forml/Parser/Utils.hs +++ b/src/hs/Forml/Parser/Utils.hs @@ -10,8 +10,11 @@ {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE StandaloneDeriving #-} + module Forml.Parser.Utils where import Control.Applicative @@ -19,6 +22,7 @@ import Control.Monad.State hiding (lift) import Text.Parsec hiding ((<|>), State, many, spaces, parse, label) +import Text.Parsec.Pos import qualified Text.Parsec as P import Text.Parsec.Indent hiding (same) @@ -26,7 +30,9 @@ import qualified Data.List as L import Data.String.Utils +import qualified Data.Serialize as S +import GHC.Generics import qualified Data.Text as T import System.IO.Unsafe (unsafePerformIO) @@ -34,8 +40,15 @@ -data Addr a = Addr SourcePos SourcePos a deriving (Eq) +data Addr a = Addr SourcePos SourcePos a deriving (Eq, Generic) +instance (S.Serialize a) => S.Serialize (Addr a) +instance S.Serialize SourcePos where + + get = return $ newPos "Serialized Optimization" 0 0 + put _ = return () + + instance Functor Addr where fmap f (Addr s e a) = Addr s e $ f a @@ -94,7 +107,7 @@ same = spaces >> do pos <- getPosition s <- get if (sourceColumn pos) /= (sourceColumn s) - then parserFail $ "not indented to exactly " ++ show (sourceColumn s) + then parserFail $ "indented to exactly " ++ show (sourceColumn s + 1) else do put $ setSourceLine s (sourceLine pos) return () @@ -111,7 +124,7 @@ in_block = do pos <- getPosition s <- get if (sourceColumn pos) < (sourceColumn s) - then parserFail $ "not indented to at least " ++ show (sourceColumn s) + then parserFail $ "indented to at least " ++ show (sourceColumn s + 1) else do put $ setSourceLine s (sourceLine pos) return () @@ -121,14 +134,18 @@ where markdown_comment = anyChar `manyTill` newline *> return "\n" empty_line = whitespace *> newline *> return "\n" - code = (\x y -> x ++ rstrip y ++ "\n") <$> string " " <*> (anyChar `manyTill` newline) - commented_code = do string " " - x <- noneOf "\n" `manyTill` try (string "--") - anyChar `manyTill` newline - return $ if length (strip x) > 0 - then " " ++ rstrip x ++ "\n" - else "\n" + code = (\x y -> x ++ rstrip y ++ "\n") + <$> string " " <*> (anyChar `manyTill` newline) + commented_code = do + + string " " + x <- noneOf "\n" `manyTill` try (string "--") + anyChar `manyTill` newline + return $ if length (strip x) > 0 + then " " ++ rstrip x ++ "\n" + else "\n" + sep_with :: Show a => String -> [a] -> String sep_with x = concat . L.intersperse x . fmap show @@ -173,7 +190,7 @@ else return y where reserved_words = [ "if", "then", "else", "let", "when", "with", "and", "or", "do", "do!", "var", - "module", "open", "yield", "lazy", "inline", "in", "is", "isnt", + "module", "open", "yield", "lazy", "inline", "in", "is", "isnt", "where", "|", "\\", "=", ":", ",", "->", "<-" ] not_system :: Parser String -> Parser String @@ -195,10 +212,10 @@ where reserved_words = [ ".", "," ] -type_sep :: Parser Char -indentPairs :: String -> Parser a -> String -> Parser a -not_comma :: Parser () -comma :: Parser () +type_sep :: Parser Char +indentPairs :: String -> Parser a -> String -> Parser a +not_comma :: Parser () +comma :: Parser () optional_sep :: ParsecT T.Text () (StateT SourcePos Identity) () type_sep = try (spaces *> char '|' <* whitespace) @@ -206,7 +223,7 @@ comma = P.spaces *> string "," *> P.spaces optional_sep = try (try comma <|> not_comma) -indentPairs a p b = string a *> P.spaces *> withPosTemp p <* P.spaces <* string b +indentPairs a p b = string a *> P.spaces *> (try p <|> withPosTemp p) <* P.spaces <* string b indentAsymmetricPairs :: String -> Parser a -> Parser b -> Parser a indentAsymmetricPairs a p b = string a *> P.spaces *> withPosTemp p <* P.spaces <* b @@ -216,8 +233,8 @@ p' <- try (Just <$> withPos p) <|> return Nothing put x case p' of - Just p' -> return p' - Nothing -> parserFail ("expression continuation indented to " ++ show x) + Just p' -> return p' + Nothing -> parserFail ("expression continuation indented to " ++ show x) db :: Show a => a -> a diff --git a/src/hs/Forml/Static.hs b/src/hs/Forml/Static.hs --- a/src/hs/Forml/Static.hs +++ b/src/hs/Forml/Static.hs @@ -13,14 +13,17 @@ import Text.InterpolatedString.Perl6 import qualified Data.ByteString.UTF8 as B +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString as BS import Data.FileEmbed import Data.Monoid +import qualified Codec.Compression.GZip as G jasmine :: String header :: String css :: String -prelude' :: String +prelude' :: B.ByteString jquery :: String footer :: String report :: String @@ -30,10 +33,11 @@ scripts :: String css' :: String -htmljs = "$('code').addClass('prettyprint lang-hs');prettyPrint();$('#run_tests').bind('click', prelude.html.table_of_contents)" -console = "prelude.html.console_runner()" +htmljs = "$('pre').addClass('prettyprint lang-hs');prettyPrint();$('#run_tests').bind('click', $prelude.$html.table_of_contents)" +console = "$prelude.$html.console_runner()" -prelude' = B.toString $(embedFile "src/forml/prelude.forml") +prelude' = BS.concat . BL.toChunks . G.decompress $ BL.fromChunks [$(embedFile "prelude.obj")] + jquery = B.toString $(embedFile "lib/js/jquery.js") header = B.toString $(embedFile "src/html/header.html") footer = B.toString $(embedFile "src/html/footer.html") @@ -50,5 +54,7 @@ `mappend` B.toString $(embedFile "lib/js/lang-hs.js") css = B.toString $(embedFile "lib/js/jasmine-1.0.1/jasmine.css") - `mappend` B.toString $(embedFile "src/html/styles.css") `mappend` B.toString $(embedFile "lib/js/prettify.css") + `mappend` B.toString $(embedFile "src/html/styles.css") + + diff --git a/src/hs/Forml/TypeCheck.hs b/src/hs/Forml/TypeCheck.hs --- a/src/hs/Forml/TypeCheck.hs +++ b/src/hs/Forml/TypeCheck.hs @@ -43,6 +43,9 @@ import Forml.Parser.Utils import Forml.TypeCheck.Types + +import Forml.Deps + import Data.Graph (graphFromEdges, SCC(..)) import Data.Graph.SCC (sccList) @@ -63,7 +66,7 @@ infer (ApplyExpression e (x:xs)) = infer (ApplyExpression (ApplyExpression e (x:[])) xs) - infer (IfExpression a b c) = + infer (IfExpression a b (Just c)) = do ta <- infer a tb <- infer b @@ -74,6 +77,20 @@ unify t tc return t + infer (IfExpression a b Nothing) = + + do ta <- infer a + tb <- infer b + t <- newTVar Star + unify ta bool_type + unify t tb + is_js <- t `can_unify` TypeRecord (TRecord M.empty TComplete Star) + if is_js + then t `unify` TypeRecord (TRecord M.empty TComplete Star) + else t `unify` TypeApplication (Type (TypeConst "JS" (KindFunction Star Star))) (TypeRecord (TRecord M.empty TComplete Star)) + return t + + infer (LiteralExpression s) = infer s infer (SymbolExpression i) = @@ -139,37 +156,18 @@ t <- freshInst (quantify (tv t''' \\ tv t'') t''') unify t r unify t' t'' - s <- get_substitution - let t''' = apply s t - r''' = apply s r - qt = quantify (tv t''') t''' - rt = quantify (tv r''') r''' - sct' = apply s t'' - if qt /= rt - then do add_error$ "Record does not match expected signature for " ++ show sct' ++ "\n" - ++ " Expected: " ++ show qt ++ "\n" - ++ " Actual: " ++ show rt - return t' - else return t' + return t' where f (Symbol x) = x f (Operator x) = x infer (LetExpression xs x) = - with_scope$ do infer' defs + with_scope$ do mapM_ ((>>= assume) . infer) defs infer x where defs = to_group (map DefinitionStatement xs) - infer' [] = return [] - infer' (x:xs) = - - do a <- infer x - assume a - as <- infer' xs - return$ a ++ as - infer (ListExpression x) = do t <- newTVar Star @@ -260,20 +258,6 @@ f _ = error "Fatal error occurred while reticulating splines" -data BindGroup = - - Scope { - imports :: [(Namespace, Maybe String)], - statements :: [Statement], - explicits :: [Definition], - implicits :: [[Definition]], - tests :: [Addr (Expression Definition)] - } - - | Module String [BindGroup] - - deriving (Show) - instance Infer Definition () where infer (Definition _ _ name axs) = @@ -485,40 +469,7 @@ infer (_ : xs) = infer xs -sort_dep :: [[Definition]] -> [[Definition]] -sort_dep [] = [] -sort_dep (concat -> xs) = unwrap `map` sccList graph - where (graph, reverse_lookup, _) = graphFromEdges . map to_node $ xs - - unwrap (AcyclicSCC v) = [ get_node . reverse_lookup $ v ] - unwrap (CyclicSCC v) = map (get_node . reverse_lookup) v - - get_node (d, _, _) = d - - to_node :: Definition -> (Definition, String, [String]) - to_node def @ (Definition _ _ n as) = - (def, show n, concat . map get_symbols . get_expressions $ as) - - get_expressions [] = [] - get_expressions (TypeAxiom _: xs') = get_expressions xs' - get_expressions (EqualityAxiom (Match _ (Just y)) (Addr _ _ x): xs') = y : x : get_expressions xs' - get_expressions (EqualityAxiom _ (Addr _ _ x): xs') = x : get_expressions xs' - - get_symbols (RecordExpression (unzip . M.toList -> (_, xs))) = concat (map get_symbols xs) - get_symbols (AccessorExpression (Addr _ _ x) _) = get_symbols x - get_symbols (ApplyExpression a b) = get_symbols a ++ concat (map get_symbols b) - get_symbols (IfExpression a b c) = get_symbols a ++ get_symbols b ++ get_symbols c - get_symbols (LiteralExpression _) = [] - get_symbols (SymbolExpression x) = [show x] - get_symbols (JSExpression _) = [] - get_symbols (LazyExpression (Addr _ _ x) _) = get_symbols x - get_symbols (FunctionExpression as) = concat$ map get_symbols$ get_expressions as - get_symbols (LetExpression _ x) = get_symbols x - get_symbols (ListExpression x) = concat (map get_symbols x) - get_symbols _ = error "Unimplemented TypeCheck 544" - - js_type :: Type js_type = Type (TypeConst "JS" (KindFunction Star Star)) @@ -543,34 +494,4 @@ assume a infer' xs - - - -to_group :: [Statement] -> [BindGroup] -to_group [] = [] -to_group xs = - - case takeWhile not_module xs of - [] -> to_group' xs - yx -> sort_deps (foldl f (Scope [] [] [] [] []) yx) - : to_group' (dropWhile not_module xs) - - where to_group' [] = [] - to_group' (ModuleStatement x y:ys) = Module (show x) (to_group y) : to_group ys - to_group' _ = error "Unexpected" - - sort_deps s @ Scope { implicits = b } = s { implicits = sort_dep b } - - not_module (ModuleStatement _ _) = False - not_module _ = True - - f s @ Scope { implicits = b} (DefinitionStatement x @ (Definition _ _ _ (EqualityAxiom _ _:_))) = - s { implicits = b ++ [[x]] } - f s @ Scope { explicits = a} (DefinitionStatement x @ (Definition _ _ _ (TypeAxiom _:_))) = - s { explicits = a ++ [x] } - f s @ Scope { tests = c } (ExpressionStatement x) = s { tests = c ++ [x] } - f s @ Scope { imports = i } (ImportStatement ns Nothing) = s { imports = i ++ [(ns, Nothing)] } - f s @ Scope { imports = i } (ImportStatement ns (Just alias)) = s { imports = i ++ [(ns, Just alias)] } - f s @ Scope { statements = t } x @ (TypeStatement _ _) = s { statements = t ++ [x] } - f x _ = x diff --git a/src/hs/Forml/TypeCheck/Types.hs b/src/hs/Forml/TypeCheck/Types.hs --- a/src/hs/Forml/TypeCheck/Types.hs +++ b/src/hs/Forml/TypeCheck/Types.hs @@ -10,7 +10,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE UndecidableInstances, KindSignatures #-} +{-# LANGUAGE UndecidableInstances, KindSignatures, DeriveGeneric #-} module Forml.TypeCheck.Types where @@ -25,7 +25,10 @@ import Control.Monad import Control.Arrow import Data.Monoid +import Data.Serialize +import GHC.Generics + import Forml.Types.Namespace hiding (Module) type Id = String @@ -33,7 +36,7 @@ enumId :: Int -> Id enumId n = 'v' : show n -data Kind = Star | KindFunction Kind Kind deriving (Show, Eq, Ord) +data Kind = Star | KindFunction Kind Kind deriving (Show, Eq, Ord, Generic) type Key = String @@ -42,19 +45,26 @@ | TypeApplication Type Type | TypeRecord TypeRecord | TypeGen Int - deriving Eq + deriving (Eq, Generic) -data TPartial = TComplete | TPartial Type deriving (Eq, Show) +data TPartial = TComplete | TPartial Type deriving (Eq, Show, Generic) data TypeRecord = TRecord (M.Map Key Type) TPartial Kind - deriving (Show, Eq) + deriving (Show, Eq, Generic) data TypeVar = TVar Id Kind - deriving (Show, Eq, Ord) + deriving (Show, Eq, Ord, Generic) data TypeConst = TypeConst Id Kind -- (?) - deriving (Show, Eq, Ord) + deriving (Show, Eq, Ord, Generic) +instance Serialize Kind +instance Serialize Type +instance Serialize TPartial +instance Serialize TypeRecord +instance Serialize TypeVar +instance Serialize TypeConst + instance Show Type where show (TypeVar (TVar i _)) = i show (Type (TypeConst i _)) = i @@ -310,8 +320,10 @@ -- Type Schemes -- -------------------------------------------------------------------------------- -data Scheme = Forall [Kind] Type deriving Eq +data Scheme = Forall [Kind] Type deriving (Eq, Generic) +instance Serialize Scheme + instance Show Scheme where show (Forall [] t) = show t show (Forall xs t) = show t --"∀" ++ vars ++ " ⇒ " ++ show t @@ -335,7 +347,9 @@ -- Assumptions -- -------------------------------------------------------------------------------- -data Assumption = Id :>: Scheme | Scheme :>>: Scheme deriving (Eq) +data Assumption = Id :>: Scheme | Scheme :>>: Scheme deriving (Eq, Generic) + +instance Serialize Assumption newtype A = A [Assumption] diff --git a/src/hs/Forml/Types/Axiom.hs b/src/hs/Forml/Types/Axiom.hs --- a/src/hs/Forml/Types/Axiom.hs +++ b/src/hs/Forml/Types/Axiom.hs @@ -10,6 +10,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveGeneric #-} module Forml.Types.Axiom where @@ -24,7 +25,9 @@ import Forml.Types.Type import Forml.Types.Pattern +import GHC.Generics +import Data.Serialize import Data.Monoid import Prelude hiding (curry, (++)) @@ -35,7 +38,9 @@ data Axiom a = TypeAxiom UnionType | EqualityAxiom (Match a) (Addr a) - deriving (Eq) + deriving (Eq, Generic) + +instance (Serialize a) => Serialize (Axiom a) instance (Show a) => Show (Axiom a) where show (TypeAxiom x) = ": " ++ show x diff --git a/src/hs/Forml/Types/Definition.hs b/src/hs/Forml/Types/Definition.hs --- a/src/hs/Forml/Types/Definition.hs +++ b/src/hs/Forml/Types/Definition.hs @@ -9,6 +9,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ScopedTypeVariables, MultiParamTypeClasses #-} module Forml.Types.Definition where @@ -19,6 +20,7 @@ import Control.Applicative import Control.Monad import Data.Monoid +import Data.Serialize import Text.Parsec hiding ((<|>), State, many, spaces, parse, label) import qualified Text.Parsec as P @@ -36,15 +38,20 @@ import Prelude hiding (curry, (++)) +import GHC.Generics + -- Definition -- -------------------------------------------------------------------------------- -data Visibility = Public | Private deriving (Eq) +data Visibility = Public | Private deriving (Eq, Generic) -data Definition = Definition Visibility Bool Symbol [Axiom (Expression Definition)] deriving (Eq) +data Definition = Definition Visibility Bool Symbol [Axiom (Expression Definition)] deriving (Eq, Generic) +instance Serialize Definition +instance Serialize Visibility + instance Show Definition where show (Definition Public _ name ax) =[qq|$name {sep_with "\\n" ax}|] show (Definition Private _ name ax) =[qq|private $name {sep_with "\\n" ax}|] @@ -57,8 +64,20 @@ (x, y) <- try prefix <|> try infix'' return $ Definition vis inl x y - where infix'' = + where where' = do + string "where" + whitespace1 + P.spaces + Just <$> withPosTemp (syntax `sepBy1` (try comma <|> try (spaces *> same))) + where_clause ex = do + where'' <- option Nothing (try where') + return $ case where'' of + Just defs -> LetExpression defs ex + Nothing -> ex + + infix'' = + do whitespace first_arg <- try syntax whitespace @@ -72,8 +91,10 @@ where no_args_eq_axiom patterns = do whitespace *> string "=" *> spaces *> indented - ex <- withPos (addr syntax) - return $ EqualityAxiom patterns ex + (Addr a b ex') <- withPosTemp (addr syntax) + P.spaces + ex <- where_clause ex' + return $ EqualityAxiom patterns (Addr a b ex) prefix = @@ -118,8 +139,10 @@ no_args_eq_axiom patterns = do P.spaces *> string "=" *> P.spaces - ex <- withPos (addr syntax) - return $ EqualityAxiom patterns ex + (Addr a b ex') <- withPosTemp (addr syntax) + P.spaces + ex <- where_clause ex' + return $ EqualityAxiom patterns (Addr a b ex) infix_axiom = diff --git a/src/hs/Forml/Types/Expression.hs b/src/hs/Forml/Types/Expression.hs --- a/src/hs/Forml/Types/Expression.hs +++ b/src/hs/Forml/Types/Expression.hs @@ -9,6 +9,8 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE StandaloneDeriving #-} module Forml.Types.Expression where @@ -28,7 +30,8 @@ import qualified Data.Map as M import Data.Monoid import Data.String.Utils hiding (join) - +import Data.Serialize as S +import qualified Data.ByteString as B import Forml.Javascript.Utils import Forml.Parser.Utils @@ -38,6 +41,8 @@ import Forml.Types.Symbol import Forml.Types.Type +import qualified GHC.Generics as G + import Prelude hiding (curry, (++)) @@ -48,10 +53,10 @@ class ToLocalStat a where toLocal :: a -> JStat -data Lazy = Once | Every deriving (Eq) +data Lazy = Once | Every deriving (Eq, G.Generic) data Expression d = ApplyExpression (Expression d) [Expression d] - | IfExpression (Expression d) (Expression d) (Expression d) + | IfExpression (Expression d) (Expression d) (Maybe (Expression d)) | LiteralExpression Literal | SymbolExpression Symbol | JSExpression JExpr @@ -62,26 +67,38 @@ | LetExpression [d] (Expression d) | ListExpression [Expression d] | AccessorExpression (Addr (Expression d)) [Symbol] - deriving (Eq) + deriving (Eq, G.Generic) +instance (Serialize d) => Serialize (Expression d) +instance Serialize Lazy + +instance Serialize JExpr where + + get = do result <- S.get + return $ case parseJM result of + Left x -> error (show x ++ "\n\n" ++ result) + Right (BlockStat [ _, AssignStat _ x]) -> x + put x = S.put . replace "jmId_" "x" . show . renderJs $ [jmacro| var xxx = `(x)`; |] + instance (Show d) => Show (Expression d) where show (ApplyExpression x @ (SymbolExpression (show -> f : _)) y) | f `elem` "abcdefghijklmnopqrstuvwxyz" = [qq|$x {sep_with " " y}|] | length y == 2 = [qq|{y !! 0} $x {y !! 1}|] - show (ApplyExpression x y) = [qq|$x {sep_with " " y}|] - show (IfExpression a b c) = [qq|if $a then $b else $c|] - show (LiteralExpression x) = show x - show (SymbolExpression x) = show x - show (ListExpression x) = [qq|[ {sep_with ", " x} ]|] - show (FunctionExpression as) = replace "\n |" "\n |" $ [qq|(λ{sep_with "| " as})|] - show (JSExpression x) = "`" ++ show (renderJs x) ++ "`" - show (LazyExpression x Once) = "lazy " ++ show x - show (LazyExpression x Every) = "do " ++ show x - show (LetExpression ax e) = replace "\n |" "\n |" $ [qq|let {sep_with "\\n| " ax} in ($e)|] - show (RecordExpression m) = [qq|\{ {unsep_with " = " m} \}|] - show (InheritExpression x m) = [qq|\{ $x with {unsep_with " = " m} \}|] + show (IfExpression a b (Just c)) = [qq|if $a then $b else $c|] + show (IfExpression a b Nothing) = [qq|if $a then $b|] + show (ApplyExpression x y) = [qq|$x {sep_with " " y}|] + show (LiteralExpression x) = show x + show (SymbolExpression x) = show x + show (ListExpression x) = [qq|[ {sep_with ", " x} ]|] + show (FunctionExpression as) = replace "\n |" "\n |" $ [qq|(λ{sep_with "| " as})|] + show (JSExpression x) = "`" ++ show (renderJs x) ++ "`" + show (LazyExpression x Once) = "lazy " ++ show x + show (LazyExpression x Every) = "do " ++ show x + show (LetExpression ax e) = replace "\n |" "\n |" $ [qq|let {sep_with "\\n| " ax} in ($e)|] + show (RecordExpression m) = [qq|\{ {unsep_with " = " m} \}|] + show (InheritExpression x m) = [qq|\{ $x with {unsep_with " = " m} \}|] show (AccessorExpression x m) = [qq|$x.{sep_with "." m}|] @@ -148,7 +165,7 @@ let' = withPosTemp $ do string "var" <|> string "let" whitespace1 - defs <- withPos def + defs <- withPosTemp def spaces try (do string "in" spaces @@ -159,7 +176,7 @@ where def = try syntax `sepBy1` (try comma <|> try (spaces *> same)) do' = do s <- getPosition - string "do" + _ <- string "do" i <- try (string "!") <|> return "" P.spaces l <- withPosTemp line @@ -190,7 +207,7 @@ option v $ try $ unit_bind v unit_bind v = do P.spaces *> same - f v AnyPattern <$> addr line + f' v <$> line f ex pat zx = ApplyExpression (SymbolExpression (Operator ">>=")) @@ -199,6 +216,10 @@ (Match [pat] Nothing) zx ]) ] + f' ex zx = ApplyExpression + (SymbolExpression (Operator ">>")) + [ ex, zx ] + lazy = do string "lazy" whitespace1 LazyExpression <$> withPosTemp (addr syntax) <*> return Once @@ -207,32 +228,41 @@ whitespace1 LazyExpression <$> withPosTemp (addr syntax) <*> return Every - if' = withPos $ do string "if" - whitespace1 - e <- withPos$ try infix' <|> other - spaces - try (jStyle e) <|> hStyle e + if' = do - where jStyle e = do indented - cont e + string "if" + whitespace1 + e <- syntax + P.spaces + hStyle e <|> jStyle e - hStyle e = do string "then" - whitespace1 - cont e + where - cont e = do t <- withPos$ try infix' <|> other - P.spaces - string "else" - whitespace1 - IfExpression e t <$> withPos (try infix' <|> other) + hStyle e = do + string "then" + whitespace1 + P.spaces + jStyle e + jStyle e = do + (Addr a b t) <- addr syntax + P.spaces + IfExpression e t <$> (else' <|> return Nothing) + + else' = do + string "else" + whitespace1 + P.spaces + Just <$> syntax + infix' = buildExpressionParser table term where table = [ [ix "^"] , [ix "*", ix "/"] , [ Prefix neg ] , [ix "+", ix "-"] - , [ Infix user_op_right AssocRight, Infix user_op_left AssocLeft ] + , [ Infix user_op_left AssocLeft ] + , [ Infix user_op_right AssocRight ] , [ix "<", ix "<=", ix ">=", ix ">", ix "==", ix "!=", ix "isnt", ix "is"] , [ix "&&", ix "||", ix "and", ix "or" ] ] @@ -250,7 +280,6 @@ return (\x -> ApplyExpression (SymbolExpression (Operator "-")) [LiteralExpression (IntLiteral 0), x]) - px s = Prefix (try neg) where neg = do spaces @@ -260,10 +289,12 @@ term = try other - user_op_left = try $ do spaces - op' <- not_system (many1 operator) - spaces - return $ f op' + user_op_left = try $ do spaces + op' @ (end -> x : _) <- g operator + spaces + if x /= ':' + then return $ f op' + else parserFail "Operator" user_op_right = try $ do spaces op' @ (end -> x : _) <- g operator @@ -339,7 +370,7 @@ eq_axiom = do patterns <- syntax string "=" P.spaces - ex <- withPosTemp $ withPos (addr syntax) + ex <- withPosTemp (addr syntax) return $ EqualityAxiom patterns ex js = g <$> indentPairs "`" (many $ noneOf "`") "`" @@ -362,7 +393,7 @@ record = indentPairs "{" (try inherit <|> (RecordExpression . M.fromList <$> pairs')) "}" - where pairs' = withPos $ (try key_eq_val <|> try function') + where pairs' = withPosTemp $ (try key_eq_val <|> try function') `sepBy` optional_sep function' = do n <- syntax @@ -374,7 +405,7 @@ string "=" spaces indented - ex <- withPos (addr syntax) + ex <- withPosTemp (addr syntax) return $ EqualityAxiom patterns ex inherit = do ex <- syntax @@ -388,7 +419,7 @@ whitespace string "=" <|> string ":" spaces - value <- withPos syntax + value <- withPosTemp syntax return (key, value) literal = do (sourceColumn -> x) <- getPosition @@ -422,12 +453,12 @@ list = ListExpression <$> indentPairs "[" v "]" where v = do whitespace - withPos (syntax `sepBy` optional_sep) + withPosTemp (syntax `sepBy` optional_sep) array = f <$> indentAsymmetricPairs "[:" v (try (string ":]") <|> string "]") where v = do whitespace - withPos (syntax `sepBy` optional_sep) + withPosTemp (syntax `sepBy` optional_sep) f [] = RecordExpression (M.fromList [(Symbol "nil", SymbolExpression (Symbol "true"))]) f (x:xs) = RecordExpression (M.fromList [(Symbol "head", x), (Symbol "tail", f xs)]) @@ -495,13 +526,9 @@ instance (Show d, ToLocalStat d) => ToJExpr (Expression d) where toJExpr (ApplyExpression (SymbolExpression (Symbol "run")) [x]) = [jmacroE| `(x)`() |] - toJExpr (ApplyExpression (SymbolExpression (Operator "&&")) [x, y]) = [jmacroE| `(x)` && `(y)` |] - toJExpr (ApplyExpression (SymbolExpression f @ (Operator _)) [x, y]) = - toJExpr (ApplyExpression (SymbolExpression (Symbol (to_name f))) [x,y]) - - toJExpr (ApplyExpression (SymbolExpression (Operator _)) x) = - error $ "Operator with " ++ show (length x) ++ " params" + toJExpr (ApplyExpression (SymbolExpression f @ (Operator _)) xs) = + toJExpr (ApplyExpression (SymbolExpression (Symbol (to_name f))) xs) toJExpr (ApplyExpression (SymbolExpression f) []) = ref (to_name f) toJExpr (ApplyExpression f []) = [jmacroE| `(f)` |] @@ -546,7 +573,7 @@ [jmacroE| (function() { `(foldl1 mappend $ map toLocal bs)`; return `(ex)` })() |] - toJExpr (IfExpression x y z) = + toJExpr (IfExpression x y (Just z)) = [jmacroE| (function(){ if (`(x)`) { @@ -555,6 +582,17 @@ return `(z)` } })() |] + + toJExpr (IfExpression x y Nothing) = + + [jmacroE| (function(){ + if (`(x)`) { + return `(y)`; + } else { + return (function() { return {}; }); + } + })() |] + toJExpr x = error $ "Unimplemented " ++ show x diff --git a/src/hs/Forml/Types/Literal.hs b/src/hs/Forml/Types/Literal.hs --- a/src/hs/Forml/Types/Literal.hs +++ b/src/hs/Forml/Types/Literal.hs @@ -1,5 +1,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE DeriveGeneric #-} + module Forml.Types.Literal where import Language.Javascript.JMacro @@ -10,7 +12,12 @@ import Forml.Parser.Utils import Forml.TypeCheck.Types -data Literal = StringLiteral String | IntLiteral Int | DoubleLiteral Double deriving (Eq) +import GHC.Generics +import Data.Serialize + +data Literal = StringLiteral String | IntLiteral Int | DoubleLiteral Double deriving (Eq, Generic) + +instance Serialize Literal instance Show Literal where show (StringLiteral x) = show x diff --git a/src/hs/Forml/Types/Namespace.hs b/src/hs/Forml/Types/Namespace.hs --- a/src/hs/Forml/Types/Namespace.hs +++ b/src/hs/Forml/Types/Namespace.hs @@ -9,6 +9,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveGeneric #-} module Forml.Types.Namespace where @@ -19,14 +20,19 @@ import Text.Parsec hiding ((<|>), State, many, spaces, parse, label) import Data.Monoid import qualified Data.List as L +import Data.Serialize +import GHC.Generics + import Forml.Parser.Utils import Forml.Javascript.Utils import Prelude hiding (curry, (++)) -newtype Namespace = Namespace [String] deriving (Eq) +newtype Namespace = Namespace [String] deriving (Eq, Ord, Generic) +instance Serialize Namespace + instance Monoid Namespace where mempty = Namespace [] mappend (Namespace x) (Namespace y) = Namespace (x ++ y) @@ -40,10 +46,7 @@ instance ToJExpr Namespace where toJExpr (Namespace []) = [jmacroE| (typeof global == "undefined" ? window : global) |] - toJExpr (Namespace (end -> x : xs)) = [jmacroE| `(Namespace xs)`[`(x)`] |] - - - + toJExpr (Namespace (end -> x : xs)) = [jmacroE| `(Namespace xs)`["$" ++ `(x)`] |] data Module = Module Namespace [Module] | Var String diff --git a/src/hs/Forml/Types/Pattern.hs b/src/hs/Forml/Types/Pattern.hs --- a/src/hs/Forml/Types/Pattern.hs +++ b/src/hs/Forml/Types/Pattern.hs @@ -9,6 +9,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ScopedTypeVariables, MultiParamTypeClasses #-} module Forml.Types.Pattern where @@ -38,15 +39,18 @@ import Prelude hiding (curry, (++)) import System.IO.Unsafe (unsafePerformIO) import Data.Monoid (mappend) +import qualified Data.Serialize as S +import GHC.Generics + -- Pattern -- -------------------------------------------------------------------------------- -data Match a = Match [Pattern a] (Maybe a) deriving (Eq) +data Match a = Match [Pattern a] (Maybe a) deriving (Eq, Generic) data Pattern a = VarPattern String | AnyPattern | LiteralPattern Literal @@ -54,8 +58,10 @@ | ListPattern [Pattern a] | ViewPattern a (Pattern a) | AliasPattern [Pattern a] - deriving (Eq) + deriving (Eq, Generic) +instance (S.Serialize a) => S.Serialize (Match a) +instance (S.Serialize a) => S.Serialize (Pattern a) instance (Show a) => Show (Match a) where show (Match p Nothing) = sep_with " " p @@ -75,11 +81,10 @@ conditional = do x <- try jStyle <|> try hStyle string "when" + whitespace1 spaces - indented - ex <- withPos syntax + ex <- syntax spaces - indented return $ Match x (Just ex) newtype Condition = Condition JExpr @@ -118,8 +123,10 @@ in [jmacroE| `(x)` && `(ref n)`.length == `(length xs)` |] toJExpr (PM _ x) = error $ "Unimplemented " ++ show x -data Partial = Partial | Complete deriving (Eq, Show) +data Partial = Partial | Complete deriving (Eq, Show, Generic) +instance S.Serialize Partial + instance (Show a) => Show (Pattern a) where show (VarPattern x) = x show AnyPattern = "_" @@ -192,7 +199,7 @@ array = f <$> indentAsymmetricPairs "[:" v (try (string ":]") <|> string "]") where v = do whitespace - withPos (syntax `sepBy` optional_sep) + withPosTemp (syntax `sepBy` optional_sep) f [] = RecordPattern (M.fromList [(Symbol "nil", AnyPattern)]) Complete f (x:xs) = RecordPattern (M.fromList [(Symbol "head", x), (Symbol "tail", f xs)]) Complete diff --git a/src/hs/Forml/Types/Statement.hs b/src/hs/Forml/Types/Statement.hs --- a/src/hs/Forml/Types/Statement.hs +++ b/src/hs/Forml/Types/Statement.hs @@ -13,7 +13,9 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE UndecidableInstances, KindSignatures #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DeriveGeneric #-} module Forml.Types.Statement where @@ -28,8 +30,11 @@ import Data.String.Utils import Data.Monoid +import qualified Data.Serialize as S import qualified Data.List as L +import GHC.Generics + import Forml.Parser.Utils import Forml.Types.Type @@ -57,7 +62,10 @@ | ExpressionStatement (Addr (Expression Definition)) | ImportStatement Namespace (Maybe String) | ModuleStatement Namespace [Statement] + deriving (Generic) +instance S.Serialize Statement + instance Show Statement where show (TypeStatement t c) = [qq|type $t = $c|] show (DefinitionStatement d) = show d @@ -78,7 +86,7 @@ (type_statement "Type Definition") <|> (try import_statement "Import Statement") <|> (module_statement "Module Declaration") - <|> (try def_statement "Symbol Definition") + <|> (def_statement "Symbol Definition") <|> (expression_statement "Assertion") def_statement = DefinitionStatement <$> syntax @@ -171,10 +179,10 @@ return $ open target_namespace y toJS (Meta { modules, - expr = ImportStatement target_namespace (Just alias), + expr = ImportStatement target_namespace @ (Namespace ns) (Just alias), namespace = (find modules . (++ target_namespace) -> Just y) }) = - return $ declare alias target_namespace + return $ declare alias (Namespace $ ns) toJS meta @ (Meta { expr = ImportStatement _ _, .. }) = @@ -187,7 +195,7 @@ toJS meta @ (Meta { target = Library, namespace = Namespace [], expr = ModuleStatement ns xs, .. }) = do xs' <- toJS $ fmap (\z -> meta { namespace = ns, expr = z }) xs - return $ declare_window (show ns) + return $ declare_window (render_ns ns) [jmacroE| new (function() { `(xs')`; }) |] @@ -195,7 +203,7 @@ toJS meta @ (Meta { target = Library, expr = ModuleStatement ns xs, .. }) = do xs' <- toJS $ fmap (\z -> meta { namespace = namespace ++ ns, expr = z }) xs - return $ declare_this (show ns) + return $ declare_this (render_ns ns) [jmacroE| new (function() { `(xs')`; }) |] @@ -265,7 +273,7 @@ open ns (DefinitionStatement (Definition _ _ _ (TypeAxiom _: [])) : xs) = open ns xs open ns (DefinitionStatement (Definition _ _ n _) : xs) = - let f = ref . replace " " "_" . show + let f = ref . render_ns x = [jmacroE| `(f ns)`[`(n)`] |] in [jmacro| `(declare (replace " " "_" $ to_name n) x)`; @@ -273,21 +281,29 @@ open nss (ModuleStatement ns @ (Namespace (n:_)) _:xs) = - [jmacro| `(declare n (ref . replace " " "_" . show $ nss ++ ns))`; + [jmacro| `(declare (clean_ns n) (ref . render_ns $ nss ++ ns))`; `(open nss xs)`; |] open ns (_ : xs) = open ns xs instance Open String where open _ [] = mempty - open (Namespace (map (replace " " "_") -> ns)) (x:xs) = + open (Namespace ns) (x:xs) = let print' [] = error "Empty Namespace" - print' (y:[]) = [jmacroE| `(ref y)` |] - print' (y:ys) = [jmacroE| `(print' ys)`[`(y)`] |] + print' (y:[]) = [jmacroE| `(ref $ clean_ns y)` |] + print' (y:ys) = [jmacroE| `(print' ys)`[`(clean_ns y)`] |] in declare x [jmacroE| `(print' $ reverse ns)`[`(x)`] || (typeof global == "undefined" ? window : global)[`(x)`] |] ++ open (Namespace ns) xs +render_ns :: Namespace -> String +render_ns (Namespace xs) = + + concat . L.intersperse "." . map clean_ns $ xs + + +clean_ns = ("$" ++) . replace " " "_" + diff --git a/src/hs/Forml/Types/Symbol.hs b/src/hs/Forml/Types/Symbol.hs --- a/src/hs/Forml/Types/Symbol.hs +++ b/src/hs/Forml/Types/Symbol.hs @@ -1,17 +1,26 @@ +{-# LANGUAGE DeriveGeneric #-} module Forml.Types.Symbol where import Language.Javascript.JMacro import Control.Applicative + import Text.Parsec hiding ((<|>), State, many, spaces, parse, label) -import qualified Data.Map as M + import Forml.Parser.Utils + +import qualified Data.Map as M import Data.String.Utils +import Data.Serialize +import GHC.Generics + data Symbol = Symbol String | Operator String - deriving (Ord, Eq) + deriving (Ord, Eq, Generic) + +instance Serialize Symbol instance Show Symbol where show (Symbol s) = s diff --git a/src/hs/Forml/Types/Type.hs b/src/hs/Forml/Types/Type.hs --- a/src/hs/Forml/Types/Type.hs +++ b/src/hs/Forml/Types/Type.hs @@ -1,12 +1,12 @@ {-# LANGUAGE FlexibleContexts, NamedFieldPuns, OverlappingInstances, QuasiQuotes, RankNTypes, RecordWildCards, TemplateHaskell, - ViewPatterns #-} + ViewPatterns, DeriveGeneric #-} module Forml.Types.Type where import Control.Applicative -import Text.InterpolatedString.Perl6 +import Text.InterpolatedString.Perl6 import Text.Parsec hiding (State, label, many, parse, spaces, (<|>)) import Text.Parsec.Indent hiding (same) @@ -14,23 +14,29 @@ import qualified Data.Set as S import Forml.Parser.Utils - import Forml.Types.Symbol +import Data.Serialize +import GHC.Generics + data UnionType = UnionType (S.Set ComplexType) - deriving (Ord, Eq) + deriving (Ord, Eq, Generic) data ComplexType = RecordType (M.Map Symbol UnionType) | InheritType SimpleType (M.Map Symbol UnionType) | FunctionType UnionType UnionType | SimpleType SimpleType - deriving (Eq, Ord) + deriving (Eq, Ord, Generic) data SimpleType = PolymorphicType SimpleType [UnionType] | SymbolType Symbol | VariableType String - deriving (Ord, Eq) + deriving (Ord, Eq, Generic) + +instance Serialize SimpleType +instance Serialize UnionType +instance Serialize ComplexType instance Show UnionType where show (UnionType xs) = [qq|{sep_with " | " $ S.toList xs}|] diff --git a/src/hs/Forml/Types/TypeDefinition.hs b/src/hs/Forml/Types/TypeDefinition.hs --- a/src/hs/Forml/Types/TypeDefinition.hs +++ b/src/hs/Forml/Types/TypeDefinition.hs @@ -5,6 +5,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveGeneric #-} module Forml.Types.TypeDefinition where @@ -16,10 +17,15 @@ import Text.Parsec hiding (State, label, many, parse, spaces, (<|>)) +import GHC.Generics +import Data.Serialize + import Forml.Parser.Utils -data TypeDefinition = TypeDefinition String [String] +data TypeDefinition = TypeDefinition String [String] deriving (Generic) + +instance Serialize TypeDefinition instance Show TypeDefinition where diff --git a/src/hs/Main.hs b/src/hs/Main.hs --- a/src/hs/Main.hs +++ b/src/hs/Main.hs @@ -7,6 +7,8 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} module Main(main) where @@ -18,11 +20,18 @@ import System.Directory import System.Environment import System.IO - +import System.IO.Unsafe +import System.Log.Logger +import System.Log.Handler.Syslog import Data.String.Utils (split) import Data.List as L +import qualified Data.Serialize as S +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import GHC.Generics + import Forml.CLI import Forml.Closure import Forml.Doc @@ -35,6 +44,8 @@ import Forml.Static import Forml.TypeCheck +import qualified Codec.Compression.GZip as G + to_parsed :: Title -> Source -> TypeSystem -> Either [Error] (TypeSystem, Program) to_parsed name src env = case parseForml name src of Left x -> Left [show x] @@ -44,99 +55,146 @@ to_filename = head . split "." . last . split "/" -parse_forml :: [Filename] -> IO ([Filename], TypeSystem, [(Program, Source)], [Title]) -parse_forml filenames = +data Compiled = Compiled { filename :: Filename + , types :: TypeSystem + , program :: Program + , source :: Source + , title :: Title + , js :: String + , opt_st :: O.OptimizeState + , tests :: String } deriving (Generic) +instance S.Serialize Compiled + +parse_forml :: [Filename] -> Compiled -> Runner (TypeSystem, Program) -> IO [Compiled] +parse_forml filenames compiled runner = + do sources <- mapM get_source filenames - (_, a, b, c) <- foldM parse' ("prelude.forml" : filenames, [], [], []) (prelude' : sources) - return $ (to_filename `fmap` ("prelude.forml" : filenames), a, b, c) + foldM parse' + [compiled] + (sources `zip` filenames) - where parse' :: ([Filename], TypeSystem, [(Program, Source)], [Title]) -> String -> IO ([Filename], TypeSystem, [(Program, Source)], [Title]) - parse' (zs, ts, as, titles) src'' = + where parse' :: [Compiled] + -> (Source, Filename) + -> IO [Compiled] - do let (title, src) = get_title (head . split "." . last . split "/" . head $ zs) src'' - let src' = to_literate (head zs) . (++ "\n") $ src - (ts', as') <- monitor [qq|Loading {head zs}|] $ return$ to_parsed (head zs) src' ts - return (tail zs, ts ++ ts', as ++ [(as', src')], titles ++ [title]) + parse' acc (src'', filename) = do - get_source filename = - do hFile <- openFile filename ReadMode - hGetContents hFile + let Compiled { types = ts, opt_st = opt } = last acc + let (title, src) = get_title (to_filename filename) src'' + let src' = to_literate filename . (++ "\n") $ src -gen_js :: [Source] -> [Program] -> (String, [String]) -gen_js src p = (g, h) + (ts', ast) <- runner [qq|Loading {filename}|] $ return $ to_parsed filename src' ts - where g = unserialize $ zipWith (render whole_program) src p - h = map (unserialize . (:[])) $ zipWith (render_spec whole_program) src p + let (opt', opt_ast) = O.run_optimizer ast (opt { O.assumptions = ts'}) + let (js', tests') = gen_js src' (opt_ast) (whole_program $ map program acc ++ [opt_ast]) - unserialize x = compress $ read' prelude ++ "\n" ++ (unlines $ map read' x) + return $ acc ++ [Compiled (to_filename filename) ts' opt_ast src' title js' opt' tests'] - read' xs @ ('"':_) = read xs - read' x = x - - whole_program = Program $ get_program p + get_source filename = + do hFile <- openFile filename ReadMode + hGetContents hFile + + whole_program p = Program $ get_program p get_program (Program ss: ps) = ss ++ get_program ps get_program [] = [] +gen_js :: Source -> Program -> Program -> (String, String) +gen_js src p whole_program = (g, h) + + where g = unserialize $ render whole_program src p + h = unserialize $ render_spec whole_program src p + + unserialize x = compress $ read' x + +read' xs @ ('"':_) = read xs +read' x = x + main :: IO () -main = do args <- getArgs - main' args +main = do args <- getArgs + if silent $ parseArgs args + then updateGlobalLogger "Global" (setLevel ERROR) + else updateGlobalLogger "Global" (setLevel INFO) + main' $ parseArgs args -main' :: [String] -> IO () -main' (parseArgs -> rc') = - if watch rc' - then watch' rc' - else compile rc' +main' :: RunConfig -> IO () +main' rc' = + if watch rc' + then watch' rc' + else compile rc' where f (x, y) = show x ++ "\n " ++ concat (L.intersperse "\n " (map show y)) ++ "\n\n " - watch' rc = + runner = if silent rc' then run_silent else monitor - do x <- mapM getModificationTime . inputs $ rc - compile rc - putStr "Waiting ..." - hFlush stdout - wait rc x + watch' rc = + do x <- mapM getModificationTime . inputs $ rc + compile rc + infoM "Global" "Waiting ..." + wait rc x wait rc x = - do threadDelay 1000 x' <- mapM getModificationTime . inputs $ rc - if x /= x' then do putStr "\r" + if x /= x' then do infoM "Global" "\r" watch' rc else wait rc x compile rc = + let empty_state = + Compiled "" [] (Program []) "" "" [] (O.gen_state []) [] in - do (filenames, types, src', titles) <- parse_forml$ inputs rc - let src'' = O.run_optimizer (fmap fst src') types - let (js', tests') = gen_js (fmap snd src') src'' + do state <- if implicit_prelude rc + then return $ case S.decode prelude' of + Left x -> error x + Right x -> x + else return $ empty_state - -- writeFile "prelude.types" (B.toString $ S.encode as) + compiled <- drop 1 `fmap` parse_forml (inputs rc) state runner + + _ <- mapM (\ c @ (Compiled { .. }) -> + runner [qq|Compiling {filename}.obj |] $ fmap Right $ + B.writeFile (filename ++ ".obj") $ B.concat $ BL.toChunks $ G.compress $ BL.fromChunks [S.encode c]) + compiled - js <- if optimize rc - then monitor [qq|Closure {output rc}.js |]$ closure_local js' "ADVANCED_OPTIMIZATIONS" - else do warn "Closure [libs]" js' + let js'' = read' prelude ++ "\n" + ++ if implicit_prelude rc then js state ++ (concatMap js compiled) else concatMap js compiled - tests <- case rc of + js' <- case rc of RunConfig { optimize = True } -> - zipWithM (\title t -> monitor [qq|Closure {title}.spec.js |]$ closure_local t "SIMPLE_OPTIMIZATIONS") (drop 1 filenames) (drop 1 tests') - _ -> warn "Closure [tests]" (drop 1 tests') + runner [qq|Closure {output rc}.js |] $ closure_local js'' "ADVANCED_OPTIMIZATIONS" + RunConfig { silent = False } -> + do warn "Closure [libs]" js'' + _ -> do return js'' + tests' <- case rc of + RunConfig { optimize = True } -> + zipWithM (\title t -> runner [qq|Closure {title}.spec.js |] $ closure_local t "SIMPLE_OPTIMIZATIONS") + (map filename compiled) + (map ((read' prelude ++) . tests) compiled) + RunConfig { silent = False } -> + warn "Closure [tests]" (map tests compiled) + _ -> do return (map tests compiled) - writeFile (output rc ++ ".js") js - zipWithM writeFile (map (++ ".spec.js") titles) tests + if flush rc + then putStr js' >> hFlush stdout + else writeFile (output rc ++ ".js") js' + + _ <- zipWithM writeFile (map (++ ".spec.js") (map filename compiled)) tests' if write_docs rc - then let programs = map fst (drop 1 src') - sources = map snd (drop 1 src') - in do docs js tests (drop 1 filenames) (drop 1 titles) programs sources - else monitor "Docs" $ return $ Right () + then docs js' + tests' + (map filename compiled) + (map title compiled) + (map program compiled) + (map source compiled) + else runner "Docs" $ return $ Right () - sequence (zipWith (test rc js) (drop 1 filenames) tests) + _ <- sequence (zipWith (test rc js') (map filename compiled) tests') if (show_types rc) - then putStrLn ("\nTypes\n\n " ++ concat (map f types)) + then putStrLn $ ("\nTypes\n\n " ++ concatMap (concatMap f . types) compiled) else return () diff --git a/src/html/styles.css b/src/html/styles.css --- a/src/html/styles.css +++ b/src/html/styles.css @@ -46,14 +46,14 @@ } a { - color:#39c; + color:#E53007; font-weight:400; text-decoration:none; } a small { font-size:11px; - color:#777; + color:#E53007; margin-top:-0.6em; display:block; } @@ -73,14 +73,11 @@ code, pre { font-family:Monaco, Bitstream Vera Sans Mono, Lucida Console, Terminal; color:#333; - font-size:12px; + font-size:14px; } pre { - padding:8px 15px; - background: #f8f8f8; - border-radius:5px; - border:1px solid #e5e5e5; + padding: 8px 25px; overflow-x: auto; }