forml 0.1.3 → 0.2
raw patch · 31 files changed
+1195/−612 lines, 31 filesdep +cerealdep +ghc-primdep +hsloggerdep −transformersdep −wl-pprint-textdep ~indentsdep ~jmacro
Dependencies added: cereal, ghc-prim, hslogger, zlib
Dependencies removed: transformers, wl-pprint-text
Dependency ranges changed: indents, jmacro
Files
- forml.cabal +9/−7
- lib/js/jasmine-1.0.1/jasmine-html.js +3/−3
- lib/js/lang-hs.js +0/−2
- lib/js/prettify.css +134/−0
- src/forml/parsec.forml +1/−1
- src/forml/prelude.forml +159/−76
- src/forml/readme.forml +161/−76
- src/forml/tests.forml +21/−5
- src/hs/Forml/CLI.hs +60/−58
- src/hs/Forml/Closure.hs +4/−13
- src/hs/Forml/Doc.hs +2/−2
- src/hs/Forml/Javascript.hs +8/−26
- src/hs/Forml/Javascript/Test.hs +7/−5
- src/hs/Forml/Optimize.hs +198/−48
- src/hs/Forml/Parser.hs +7/−2
- src/hs/Forml/Parser/Utils.hs +35/−18
- src/hs/Forml/Static.hs +11/−5
- src/hs/Forml/TypeCheck.hs +20/−99
- src/hs/Forml/TypeCheck/Types.hs +23/−9
- src/hs/Forml/Types/Axiom.hs +6/−1
- src/hs/Forml/Types/Definition.hs +30/−7
- src/hs/Forml/Types/Expression.hs +91/−53
- src/hs/Forml/Types/Literal.hs +8/−1
- src/hs/Forml/Types/Namespace.hs +8/−5
- src/hs/Forml/Types/Pattern.hs +14/−7
- src/hs/Forml/Types/Statement.hs +27/−11
- src/hs/Forml/Types/Symbol.hs +11/−2
- src/hs/Forml/Types/Type.hs +12/−6
- src/hs/Forml/Types/TypeDefinition.hs +7/−1
- src/hs/Main.hs +114/−56
- src/html/styles.css +4/−7
forml.cabal view
@@ -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
lib/js/jasmine-1.0.1/jasmine-html.js view
@@ -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<arguments.length;e++){var f=arguments[e];"string"===typeof f?d.appendChild(document.createTextNode(f)):f&&d.appendChild(f)}for(var g in b)"className"==g?d[g]=b[g]:d.setAttribute(g,b[g]);return d}; jasmine.TrivialReporter.prototype.reportRunnerStarting=function(a){var b,c;this.outerDiv=this.createDom("div",{className:"jasmine_reporter"},this.createDom("div",{className:"banner"},this.createDom("div",{className:"logo"},this.createDom("a",{href:"http://pivotal.github.com/jasmine/",target:"_blank"},"Jasmine"),this.createDom("span",{className:"version"},a.env.versionString())),this.createDom("div",{className:"options"},"Show ",b=this.createDom("input",{id:"__jasmine_TrivialReporter_showPassed__",-type:"checkbox"}),this.createDom("label",{"for":"__jasmine_TrivialReporter_showPassed__"}," passed "),c=this.createDom("input",{id:"__jasmine_TrivialReporter_showSkipped__",type:"checkbox"}),this.createDom("label",{"for":"__jasmine_TrivialReporter_showSkipped__"}," skipped"))),this.runnerDiv=this.createDom("div",{className:"runner running"},this.createDom("a",{className:"run_spec",href:"?"},"run all"),this.runnerMessageSpan=this.createDom("span",{},"Running..."),this.finishedAtSpan=this.createDom("span",-{className:"finished-at"},"")));this.document.body.appendChild(this.outerDiv);for(var a=a.suites(),d=0;d<a.length;d++){var e=a[d],f=this.createDom("div",{className:"suite"},this.createDom("a",{className:"run_spec",href:"?spec="+encodeURIComponent(e.getFullName())},"run"),this.createDom("a",{className:"description",href:"?spec="+encodeURIComponent(e.getFullName())},e.description));this.suiteDivs[e.id]=f;var g=this.outerDiv;e.parentSuite&&(g=this.suiteDivs[e.parentSuite.id]);g.appendChild(f)}this.startedAt=+type:"checkbox"}),this.createDom("label",{"for":"__jasmine_TrivialReporter_showPassed__"}," passed "),c=this.createDom("input",{id:"__jasmine_TrivialReporter_showSkipped__",type:"checkbox"}),this.createDom("label",{"for":"__jasmine_TrivialReporter_showSkipped__"}," skipped"))),this.runnerDiv=this.createDom("div",{className:"runner running"},this.createDom("a",{className:"run_spec",href:"?"},""),this.runnerMessageSpan=this.createDom("span",{},"Running..."),this.finishedAtSpan=this.createDom("span",+{className:"finished-at"},"")));this.document.body.appendChild(this.outerDiv);for(var a=a.suites(),d=0;d<a.length;d++){var e=a[d],f=this.createDom("div",{className:"suite"},this.createDom("a",{className:"run_spec",href:"?spec="+encodeURIComponent(e.getFullName())},""),this.createDom("a",{className:"description",href:"?spec="+encodeURIComponent(e.getFullName())},e.description));this.suiteDivs[e.id]=f;var g=this.outerDiv;e.parentSuite&&(g=this.suiteDivs[e.parentSuite.id]);g.appendChild(f)}this.startedAt= new Date;var h=this;b.onclick=function(){h.outerDiv.className=b.checked?h.outerDiv.className+" show-passed":h.outerDiv.className.replace(/ show-passed/,"")};c.onclick=function(){h.outerDiv.className=c.checked?h.outerDiv.className+" show-skipped":h.outerDiv.className.replace(/ show-skipped/,"")}}; jasmine.TrivialReporter.prototype.reportRunnerResults=function(a){var b=a.results(),c=0<b.failedCount?"runner failed":"runner passed";this.runnerDiv.setAttribute("class",c);this.runnerDiv.setAttribute("className",c);for(var a=a.specs(),d=c=0;d<a.length;d++)this.specFilter(a[d])&&c++;b=""+c+" spec"+(1==c?"":"s")+", "+b.failedCount+" failure"+(1==b.failedCount?"":"s");b+=" in "+((new Date).getTime()-this.startedAt.getTime())/1E3+"s";this.runnerMessageSpan.replaceChild(this.createDom("a",{className:"description", href:"?"},b),this.runnerMessageSpan.firstChild);this.finishedAtSpan.appendChild(document.createTextNode("Finished at "+(new Date).toString()))};jasmine.TrivialReporter.prototype.reportSuiteResults=function(a){var b=a.results(),c=b.passed()?"passed":"failed";0==b.totalCount&&(c="skipped");this.suiteDivs[a.id].className+=" "+c};jasmine.TrivialReporter.prototype.reportSpecStarting=function(a){this.logRunningSpecs&&this.log(">> 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<b.length;e++){var f=b[e];"log"==f.type?d.appendChild(this.createDom("div",{className:"resultMessage log"},f.toString())):"expect"==f.type&&f.passed&&!f.passed()&&(d.appendChild(this.createDom("div",{className:"resultMessage fail"},f.message)),f.trace.stack&&d.appendChild(this.createDom("div",{className:"stackTrace"},f.trace.stack)))}0<d.childNodes.length&&c.appendChild(d);this.suiteDivs[a.suite.id].appendChild(c)}; jasmine.TrivialReporter.prototype.log=function(){var a=jasmine.getGlobal().console;a&&a.log&&(a.log.apply?a.log.apply(a,arguments):a.log(arguments))};jasmine.TrivialReporter.prototype.getLocation=function(){return this.document.location};jasmine.TrivialReporter.prototype.specFilter=function(a){for(var b={},c=this.getLocation().search.substring(1).split("&"),d=0;d<c.length;d++){var e=c[d].split("=");b[decodeURIComponent(e[0])]=decodeURIComponent(e[1])}return!b.spec?!0:0==a.getFullName().indexOf(b.spec)};
lib/js/lang-hs.js view
@@ -54,8 +54,6 @@ // charesc -> 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}
lib/js/prettify.css view
@@ -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 {+ /* */ }+
src/forml/parsec.forml view
@@ -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} =
src/forml/prelude.forml view
@@ -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
src/forml/readme.forml view
@@ -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 @@ -- <pre><code>$ forml -docs test.forml</pre></code> +-- 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: -- <pre><code> prelude.log "Hello, World!" -- Won't compile!</pre></code>@@ -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
src/forml/tests.forml view
@@ -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
src/hs/Forml/CLI.hs view
@@ -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
src/hs/Forml/Closure.hs view
@@ -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
src/hs/Forml/Doc.hs view
@@ -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
src/hs/Forml/Javascript.hs view
@@ -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)`; }); |]
src/hs/Forml/Javascript/Test.hs view
@@ -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" ()
src/hs/Forml/Optimize.hs view
@@ -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 [] [] []+
src/hs/Forml/Parser.hs view
@@ -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) ("<span class='test' id='test_" ++ serial a b ++ "'>") (replace (serial a b ++ "--") "</span>" 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
src/hs/Forml/Parser/Utils.hs view
@@ -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
src/hs/Forml/Static.hs view
@@ -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") ++
src/hs/Forml/TypeCheck.hs view
@@ -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
src/hs/Forml/TypeCheck/Types.hs view
@@ -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]
src/hs/Forml/Types/Axiom.hs view
@@ -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
src/hs/Forml/Types/Definition.hs view
@@ -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 =
src/hs/Forml/Types/Expression.hs view
@@ -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
src/hs/Forml/Types/Literal.hs view
@@ -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
src/hs/Forml/Types/Namespace.hs view
@@ -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
src/hs/Forml/Types/Pattern.hs view
@@ -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
src/hs/Forml/Types/Statement.hs view
@@ -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 " " "_"+
src/hs/Forml/Types/Symbol.hs view
@@ -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
src/hs/Forml/Types/Type.hs view
@@ -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}|]
src/hs/Forml/Types/TypeDefinition.hs view
@@ -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
src/hs/Main.hs view
@@ -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 ()
src/html/styles.css view
@@ -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; }