on master help sign in
Initial commit.
commita587ff513220bf608b38ce139534ecf0fba6438c authorevancz <info@elm-lang.org> dateThu 19 Apr 2012, 02:32 (15 years ago) parentc336a40
27 files changed+1490
Elm.cabal+65 LICENSE+30 README+1 Setup.hs+2 elm-mini.js+43 src/Ast.hs+37 src/CompileToJS.hs+88 src/Elm.hs+45 src/ExtractNoscript.hs+43 src/FreeVar.hs+30 src/GenerateHtml.hs+32 src/Initialize.hs+154 src/Parse/Binop.hs+63 src/Parse/Combinators.hs+82 src/Parse/Lexer.hs+73 src/Parse/ParsePatterns.hs+31 src/Parse/ParseTypes.hs+56 src/Parse/Parser.hs+116 src/Parse/ParserLib.hs+36 src/Parse/Tokens.hs+17 src/Rename.hs+73 src/Replace.hs+50 src/Server.hs+65 src/ToHtml.hs+19 src/Types/TypeCheck.hs+175 src/Types/TypeHints.hs+30 src/Types/Types.hs+34
Elm.cabalnew file+65
@@ -0,0 +1,65 @@
1+-- Elm.cabal auto-generated by cabal init. For additional options, see
2+-- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr.
3+-- The name of the package.
4+Name: Elm
5+
6+-- The package version. See the Haskell package versioning policy
7+-- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for
8+-- standards guiding when and how versions should be incremented.
9+Version: 0.1
10+
11+-- A short (one-line) description of the package.
12+Synopsis: The Elm compiler: compiles a statically/strongly typed, functional reactive language to HTML, CSS, and JS.
13+
14+-- A longer description of the package.
15+-- Description:
16+
17+-- URL for the project homepage or repository.
18+Homepage: http://elm-lang.org
19+
20+-- The license under which the package is released.
21+License: BSD3
22+
23+-- The file containing the license text.
24+License-file: LICENSE
25+
26+-- The package author(s).
27+Author: Evan Czaplicki
28+
29+-- An email address to which users can send suggestions, bug reports,
30+-- and patches.
31+Maintainer: info@elm-lang.org
32+
33+-- A copyright notice.
34+-- Copyright:
35+
36+Category: Compiler
37+
38+Build-type: Simple
39+
40+-- Extra files to be distributed with the package, such as examples or
41+-- a README.
42+Extra-source-files: README, elm-mini.js
43+
44+-- Constraint on the version of Cabal needed to build this package.
45+Cabal-version: >=1.2
46+
47+
48+Executable elm
49+ -- .hs or .lhs file containing the Main module.
50+ Main-is: Elm.hs
51+ Hs-Source-Dirs: src, src/Parse, src/Types
52+
53+ -- Packages needed in order to build this package.
54+ Build-depends: base, containers, transformers, mtl, parsec, blaze-html
55+
56+ -- Modules not exported by this package.
57+ -- Other-modules:
58+
59+ -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.
60+ -- Build-tools:
61+
62+Executable elm-server
63+ Main-is: Server.hs
64+ Hs-Source-Dirs: src, src/Parse, src/Types
65+ Build-depends: base, containers, transformers, mtl, blaze-html, HTTP, happstack-server
LICENSEnew file+30
@@ -0,0 +1,30 @@
1+Copyright (c)2012, Evan Czaplicki
2+
3+All rights reserved.
4+
5+Redistribution and use in source and binary forms, with or without
6+modification, are permitted provided that the following conditions are met:
7+
8+ * Redistributions of source code must retain the above copyright
9+ notice, this list of conditions and the following disclaimer.
10+
11+ * Redistributions in binary form must reproduce the above
12+ copyright notice, this list of conditions and the following
13+ disclaimer in the documentation and/or other materials provided
14+ with the distribution.
15+
16+ * Neither the name of Evan Czaplicki nor the names of other
17+ contributors may be used to endorse or promote products derived
18+ from this software without specific prior written permission.
19+
20+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
READMEnew file+1
@@ -0,0 +1 @@
1+TODO.
Setup.hsnew file+2
@@ -0,0 +1,2 @@
1+import Distribution.Simple
2+main = defaultMain
elm-mini.jsnew file+43
@@ -0,0 +1,43 @@
1+var Guid=function(){var c=0;return{guid:function(){return c+=1}}}(),Value=function(){var c=function(a){if("boolean"===typeof a)return a?"True":"False";if("number"!==typeof a&&a[0]){if("Tuple"===a[0].substring(0,5)){for(var d="",b=a.length;--b;)d=","+c(a[b])+d;","===d[0]&&(d=d.substring(1));return"("+d+")"}if("Cons"===a[0])for(var b="string"===typeof a[1]?'"':"]",e="string"===typeof a[1]?"":",",d=("string"===typeof a[1]?'"':"[")+c(a[1]),a=a[2];;)if("Cons"===a[0])d+=e+c(a[1]),a=a[2];else return d+b;
2+else{if("Nil"===a[0])return"[]";d="";for(b=a.length;--b;)d=" "+c(a[b])+d;d=a[0]+d;return 1<a.length?"("+d+")":d}}return a+""};return{show:function(a){return Text.monospace(String.properEscape(c(a)))},Tuple:function(){var a=arguments.length,d=Array(a+1);for(d[0]="Tuple"+arguments.length;a--;)d[a+1]=arguments[a];return d},append:function(a,d){if("string"===typeof a&&"string"===typeof d)return a.concat(d);if("Nil"===a[0])return d;for(var b=["Cons",a[1],["Nil"]],c=b,a=a[2];"Cons"===a[0];)c[2]=["Cons",
3+a[1],["Nil"]],a=a[2],c=c[2];c[2]=d;return b}}}(),String=function(){return{toText:function(c){for(var a=[];"Cons"===c[0];)a.push(c[1]),c=c[2];return String.properEscape(a.join(""))},properEscape:function(c){c.replace('"',"&#34;");c.replace("&","&#38;");c.replace("'","&#39;");c.replace("<","&#60;");c.replace(">","&#62;");return c}}}(),Color=function(){var c=function(a,d,b,c){return{r:Math.round(255*a),g:Math.round(255*d),b:Math.round(255*b),a:c}};return{black:c(0,0,0,1),white:c(1,1,1,1),red:c(1,0,0,
4+1),green:c(0,1,0,1),blue:c(0,0,1,1),rgba:function(a){return function(d){return function(b){return function(e){return c(a,d,b,e)}}}},rgb:function(a){return function(d){return function(b){return c(a,d,b,1)}}},Internal:{extract:function(a){return 1===a.a?"rgb("+a.r+","+a.g+","+a.b+")":"rgba("+a.r+","+a.g+","+a.b+","+a.a+")"}}}}(),Element=function(){var c=function(b){b=document.createElement(b);b.id=Guid.guid();return b},a=function(b){var a=c("div");a.appendChild(b);return a},d=function(b){return function(a){return function(d){var e=
5+c("div");e.isElmText=!0;e.innerHTML=d;e.style.textAlign=a;0<b&&(e.style.width=b+"px");e.isElmLeaf=!0;e.style.visibility="hidden";e.style.styleFloat="left";e.style.cssFloat="left";document.body.appendChild(e);d=window.getComputedStyle(e);0>=b&&(e.style.width=d.getPropertyValue("width"));e.style.height=d.getPropertyValue("height");document.body.removeChild(e);e.style.visibility="visible";e.style.styleFloat="none";e.style.cssFloat="none";return e}}},b=d(0)("left"),e=d(0)("justify"),f=d(0)("center"),
6+g=function(b){return"DIV"===b.tagName?b:a(b)},h=function(b){b.style.styleFloat="left";b.style.cssFloat="left";return b},k=function(b){b.style.position="absolute";return b},i=function(b,a,d){for(var e=c("div"),f=d.length;f--;){var h=a(d[f]);e.appendChild(h)}e.elmFlowDirection=b;return e},j=function(b){return function(a){for(var d=[];"Cons"===a[0];)d.push(a[1]),a=a[2];3<=b&&d.reverse();a=b%3;if(0==a)return i("Y",g,d);if(1==a)return i("X",h,d);if(2==a)return i("Z",k,d)}},l=function(b){return function(a){if("A"===
7+a.tagName)return l(b)(a.firstChild),a;if(a.hasOwnProperty("isElmText")){var e=d(b)(a.style.textAlign)(a.innerHTML);a.style.height=e.style.height}a.style.width=b+"px";return a}};return{text:b,image:function(b){var a=c("img");a.isElmLeaf=!0;a.onload=function(){""===a.style.width&&0<this.width&&(a.style.width=a.width=this.width+"px");""===a.style.height&&0<this.height&&(a.style.height=a.height=this.height+"px");Dispatcher.adjust()};a.src=String.toText(b);a.name=a.src;return a},video:function(a){var a=
8+String.toText(a),b=c("video");b.controls="controls";var d=c("source");d.src=a;d.type="video/"+a.substring(a.length-3,a.length);b.appendChild(d);b.isElmLeaf=!0;return b},audio:function(a){var a=String.toString(a),b=c("video");b.controls="controls";var d=c("source");d.src=a;d.type="audio/"+a.substring(a.length-3,a.length);b.appendChild(d);b.isElmLeaf=!0;return b},collage:function(a){return function(b){return function(d){var e=c("canvas");e.style.width=a+"px";e.style.height=b+"px";e.width=a;e.height=
9+b;if(e.getContext){var f=e.getContext("2d");for(f.clearRect(0,0,e.width,e.height);"Cons"===d[0];)f=d[1](f),d=d[2];return e}e.innerHTML="Your browser does not support the canvas element.";e.isElmLeaf=!0;return e}}},flow:j,layers:j(2),beside:function(a){return function(b){return j(1)(["Cons",a,["Cons",b,["Nil"]]])}},above:function(a){return function(b){return j(0)(["Cons",a,["Cons",b,["Nil"]]])}},below:function(a){return function(b){return j(3)(["Cons",a,["Cons",b,["Nil"]]])}},box:function(a){return function(b){b.style.position=
10+"absolute";b.style.margin="auto";var d=(a-1)%3,e=(a-1)/3;2>d&&(b.style.left=0);0<d&&(b.style.right=0);2>e&&(b.style.top=0);0<e&&(b.style.bottom=0);d=c("div");d.style.position="relative";d.appendChild(b);return d}},width:l,height:function(a){return function(b){("A"===b.tagName?b.firstChild:b).style.height=a+"px";return b}},size:function(b){return function(a){return function(d){var e="A"===d.tagName?d.firstChild:d;e.style.width=b+"px";e.style.height=a+"px";return d}}},color:function(b){return function(a){a.style.backgroundColor=
11+Color.Internal.extract(b);return a}},opacity:function(a){return function(b){b.style.opacity=a;return b}},link:function(b){return function(d){var e=c("a");e.href=Text.fromString(b);e.appendChild(d);return a(e)}},asText:function(b){return d(0)("left")(Value.show(b))},plainText:function(b){return d(0)("left")(String.toText(b))},justifiedText:e,centeredText:f,up:0,left:1,inward:2,down:3,right:4,outward:5}}(),Text=function(){var c=function(b){for(var a=[];"Cons"===b[0];)a.push(b[1]),b=b[2];return String.properEscape(a.join(""))},
12+a=function(b){return function(a){return"<"+b+">"+a+"</"+b+">"}},d=function(b,a){return function(d){return"<span style='"+b+":"+a+"'>"+d+"</span>"}},b=a("h1"),e=d("font-style","italic"),a=a("b"),f=d("text-decoration","underline"),g=d("text-decoration","overline"),h=d("text-decoration","line-through");return{fromString:c,toText:c,header:b,height:function(b){return d("font-size",b+"em")},italic:e,bold:a,underline:f,overline:g,strikeThrough:h,monospace:d("font-family","monospace"),color:function(b){return d("color",
13+Color.Internal.extract(b))},link:function(b){return function(a){return"<a href='"+c(b)+"'>"+a+"</a>"}}}}(),Shape=function(){var c=function(a,b,e,c){return{center:a,points:b,theta:e,scale:c}},a=function(a){return function(b){return function(e){return function(c){c.save();c.translate(e.center[0],e.center[1]);c.rotate(e.theta);c.scale(e.scale,e.scale);c.beginPath();var g=e.points;c.moveTo(g[0][0],g[0][1]);for(var h=g.length;h--;)c.lineTo(g[h][0],g[h][1]);c.closePath();a?(c.fillStyle=Color.Internal.extract(b),
14+c.fill()):(c.strokeStyle=Color.Internal.extract(b),c.stroke());c.restore();return c}}}};return{polygon:function(a){return function(b){for(var e=[];"Cons"===a[0];)e.push([a[1][1],a[1][2]]),a=a[2];b=[b[1],b[2]];return c(b,e,0,1)}},ngon:function(a){return function(b){return function(e){for(var f=[],g=a;g--;)f.push([b*Math.cos(2*Math.PI*g/a),b*Math.sin(2*Math.PI*g/a)]);e=[e[1],e[2]];return c(e,f,0,1)}}},rect:function(a){return function(b){return function(e){var f=[[-a/2,-b/2],[a/2,-b/2],[a/2,b/2],[-a/
15+2,b/2]],e=[e[1],e[2]];return c(e,f,0,1)}}},oval:function(a){return function(b){return function(e){for(var f=[],g=2*Math.PI;0<g;g-=Math.PI/50)f.push([a/2*Math.cos(g),b/2*Math.sin(g)]);e=[e[1],e[2]];return c(e,f,0,1)}}},move:function(a){return function(b){return function(e){return c([a+e.center[0],b+e.center[1]],e.points,e.theta,e.scale)}}},rotate:function(a){return function(b){return c(b.center,b.points,b.theta+2*Math.PI*a,b.scale)}},scale:function(a){return function(b){return c(b.center,b.points,
16+b.theta,b.scale*a)}},filled:a(!0),outlined:a(!1),customOutline:function(a){return function(b){return function(e){e.points.push(e.points[0]);return Line.customLine(a)(b)(e)}}}}}(),Line=function(){var c=function(a){return function(c){return function(b){if("string"===typeof a[0]){for(var e=[];"Cons"===a[0];)e.push(a[1]),a=a[2];a=e}0===a.length&&(a=[8,4]);return function(e){e.save();e.beginPath();e.translate(b.center[0],b.center[1]);e.rotate(b.theta);e.scale(b.scale,b.scale);var g=a,h=b.points,k=h.length-
17+1,i=h[k][0],j=h[k][1],l=0,m=0,n=0,o=0,p=0,r=0,t=g.length,s=!0,q=g[0];for(e.moveTo(i,j);k--;){l=h[k][0];m=h[k][1];n=l-i;o=m-j;for(p=Math.sqrt(n*n+o*o);q<=p;)i+=n*q/p,j+=o*q/p,e[s?"lineTo":"moveTo"](i,j),n=l-i,o=m-j,p=Math.sqrt(n*n+o*o),s=!s,r=(r+1)%t,q=g[r];0<p&&(e[s?"lineTo":"moveTo"](l,m),q-=p);i=l;j=m}e.strokeStyle=Color.Internal.extract(c);e.stroke();e.restore();return e}}}};return{line:function(a){for(var c=[];"Cons"===a[0];)c.push([a[1][1],a[1][2]]),a=a[2];return{center:[0,0],points:c,theta:0,
18+scale:1}},customLine:c,solid:function(a){return function(c){return function(b){b.save();b.beginPath();b.translate(c.center[0],c.center[1]);b.rotate(c.theta);b.scale(c.scale,c.scale);var e=c.points,f=e.length;for(b.moveTo(e[f-1][0],e[f-1][1]);f--;)b.lineTo(e[f][0],e[f][1]);b.strokeStyle=Color.Internal.extract(a);b.stroke();b.restore();return b}}},dashed:c([8,4]),dotted:c([3,3])}}(),Elm=function(){var c=function(a){this.id=Guid.guid();this.value=a;this.step=function(a,b){var c=a===this.id;c&&(this.value=
19+b);return c}},a=function(a,e){this.id=Guid.guid();this.value=null;e.reverse();this.recalc=function(){for(var c=a,d=e.length;d--;)c=c(e[d].value);this.value=c};this.recalc();this.step=function(a,b){if(this.hasOwnProperty(a))return!1;for(var c=!1,d=e.length;d--;)c=c||e[d].step(a,b);c?this.recalc():this[a]=!0;return c}},d=function(a,c,d){this.id=Guid.guid();this.value=c;this.step=function(c,e){if(this.hasOwnProperty(c))return!1;var k=d.step(c,e);k?this.value=a(d.value)(this.value):this[c]=!0;return k}};
20+return{Input:function(a){return new c(a)},Lift:function(b,c){return new a(b,c)},Fold:function(a,c,f){return new d(a,c,f)}}}(),Dispatcher=function(){var c=null,a=function(b,c,d){d.style&&c.style&&(d.style.width=c.style.width,d.style.height=c.style.height);if(c.hasOwnProperty("isElmLeaf")&&d.hasOwnProperty("isElmLeaf"))c.id=d.id,c.isEqualNode(d)||b.replaceChild(c,d);else if("CANVAS"===c.nodeName)b.replaceChild(c,d);else{var g=c.childNodes,h=d.childNodes;if(g.length!==h.length)b.replaceChild(c,d);else for(b=
21+g.length;b--;)a(d,g[b],h[b])}},d=function(a){var c=a.childNodes,f=c.length;if(a.hasOwnProperty("isElmLeaf")){var c=""===a.style.width?0:a.style.width.slice(0,-2)-0,g=""===a.style.height?0:a.style.height.slice(0,-2)-0;return[c,g]}if(1===f){var h=d(c[0]);""!==a.style.width&&(h[0]=a.style.width.slice(0,-2)-0);""!==a.style.height&&(h[1]=a.style.height.slice(0,-2)-0);0!==h[0]&&(a.style.width=h[0]+"px");0!==h[1]&&(a.style.height=h[1]+"px");return h}for(var k=0,i=g=0,j=0,l=!0,m=!0;f--;)h=d(c[f]),k=Math.max(k,
22+h[0]),g=Math.max(g,h[1]),i+=h[0],j+=h[1],l=l&&0<h[0],m=m&&0<h[1];c=k;f=a.elmFlowDirection;"X"===f&&(c=l?i:0);"Y"===f&&(g=m?j:0);0<c&&(a.style.width=c+"px");0<g&&(a.style.height=g+"px");return[c,g]};return{initialize:function(){c=main();c.hasOwnProperty("step")||(c=Elm.Input(c));var a=document.getElementById("content");a.appendChild(c.value);d(a);a=document.getElementById("widthChecker").offsetWidth;a!==window.innerWidth&&Dispatcher.notify(Window.dimensions.id,Value.Tuple(a,window.innerHeight))},notify:function(b,
23+e){if(c.step(b,e)){var f=document.getElementById("content");a(f,c.value,f.children[0]);d(f)}},adjust:function(){var a=document.getElementById("content");d(a)}}}(),Signal=function(){var c=function(){return document.addEventListener?function(a,b,c){a.addEventListener(b,c,!1)}:function(a,b,c){a.attachEvent("on"+b,c)}}(),a=function(){function a(b){var c=0,d=0;b||(b=window.event);if(b.pageX||b.pageY)c=b.pageX,d=b.pageY;else if(b.clientX||b.clientY)c=b.clientX+document.body.scrollLeft+document.documentElement.scrollLeft,
24+d=b.clientY+document.body.scrollTop+document.documentElement.scrollTop;return Value.Tuple(c,d)}var b=Elm.Input(Value.Tuple(0,0)),d=Elm.Input(!1),e=Elm.Input(!1);c(document,"click",function(){Dispatcher.notify(e.id,!0);Dispatcher.notify(e.id,!1)});c(document,"mousedown",function(){Dispatcher.notify(d.id,!0)});c(document,"mouseup",function(){Dispatcher.notify(d.id,!1)});c(document,"mousemove",function(c){Dispatcher.notify(b.id,a(c))});return{position:b,x:Elm.Lift(function(a){return a[1]},[b]),y:Elm.Lift(function(a){return a[2]},
25+[b]),isClicked:e,isDown:d}}(),d=function(){return{every:function(a){var a=1E3*a,b=Elm.Input(0),c=0;setInterval(function(){c+=a;Dispatcher.notify(b.id,c/1E3)},a);return b},after:function(a){var a=1E3*a,b=Elm.Input(!1);setTimeout(function(){Dispatcher.notify(b.id,!0)},a);return b},before:function(a){var a=1E3*a,b=Elm.Input(!0);setTimeout(function(){Dispatcher.notify(b.id,!1)},a);return b}}}(),b=function(){var a=Elm.Input(Value.Tuple(window.innerWidth,window.innerHeight));c(window,"resize",function(){var b=
26+document.getElementById("widthChecker").offsetWidth;Dispatcher.notify(a.id,Value.Tuple(b,window.innerHeight))});return{dimensions:a,width:Elm.Lift(function(a){return a[1]},[a]),height:Elm.Lift(function(a){return a[2]},[a])}}(),e=function(){var a=function(a){return function(b){var c=Elm.Input("Requesting Data...");window.XMLHttpRequest?request=new XMLHttpRequest:window.ActiveXObject&&(request=new ActiveXObject("Microsoft.XMLHTTP"));request.onreadystatechange=function(){var a="",a=4===request.readyState?
27+200===request.status?request.responseText:request.statusText:"Request Failed";Dispatcher.notify(c.id,a)};request.open(a,String.toText(b),!0);request.send(null);return c}};return{get:a("GET"),post:a("POST")}}(),f=function(){return{inRange:function(a){return function(b){return Elm.Input(Math.floor(Math.random()*(b-a+1))+a)}},randomize:function(a){return function(b){return function(c){return Elm.Lift(function(){return Math.floor(Math.random()*(b-a+1))+a},[c])}}}}}(),g=function(){function a(b){for(var c=
28+["Nil"],d=b.length;d--;)c=["Cons",b[d],c];return c}var b=function(b){b.isElmLeaf=!0;var d=Elm.Input(["Nil"]);c(b,"keyup",function(){Dispatcher.notify(d.id,a(b.value));b.focus()});return Value.Tuple(b,d)},d=function(a){a=document.createElement(a);a.id=Guid.guid();return a},e=function(a){for(var b=d("select"),e=[];"Cons"===a[0];){var f=d("option"),g=Text.toText(a[1][1]);f.value=g;f.innerHTML=g;b.appendChild(f);e.push(a[1][2]);a=a[2]}var h=Elm.Input(e[0]);c(b,"change",function(){Dispatcher.notify(h.id,
29+e[b.selectedIndex])});return Value.Tuple(b,h)};return{textArea:function(a){return function(c){var e=d("textarea");e.rows=c;e.cols=a;return b(e,"")}},textField:function(a){var c=d("input");c.type="text";return b(c,a)},password:function(a){var c=d("input");c.type="password";return b(c,a)},checkbox:function(a){var b=d("input");b.type="checkbox";b.checked=a;var e=Elm.Input(a);console.log(a,b);c(b,"change",function(){Dispatcher.notify(e.id,b.checked)});return Value.Tuple(b,e)},dropDown:e,stringDropDown:function(a){return e(List.map(function(a){return Value.Tuple(a,
30+a)})(a))}}}();return{Mouse:a,Time:d,Window:b,HTTP:e,Random:f,Input:g}}(),List=function(){function c(a){return function(b){if("Nil"===b[0])return b;"Cons"!==b[0]&&i();for(var c=["Cons",a(b[1]),["Nil"]],d=c,b=b[2];"Cons"===b[0];)d[2]=["Cons",a(b[1]),["Nil"]],b=b[2],d=d[2];return c}}function a(a){return function(b){return function(c){var d=b;if("Nil"===c[0])return d;for("Cons"!==c[0]&&i();"Cons"===c[0];)d=a(c[1])(d),c=c[2];return d}}}function d(a){return function(b){return function(c){var d=b;if("Nil"===
31+c[0])return d;"Cons"!==c[0]&&i();for(var e=[];"Cons"===c[0];)e.push(c[1]),c=c[2];for(c=e.length;c--;)d=a(e[c])(d);return d}}}function b(b){return function(c){var d;"Cons"!==c[0]?d=void 0:(d=c[1],c=c[2],d=a(b)(d)(c));return d}}function e(a){return function(b){return function(c){if("Nil"===c[0])return["Cons",b,["Nil"]];"Cons"!==c[0]&&i();for(var d=[b];"Cons"===c[0];)b=a(c[1])(b),d.push(b),c=c[2];for(var c=["Nil"],e=d.length;e--;)c=["Cons",d[e],c];return c}}}function f(a){return function(b){return function(){for(var c=
32+[function(a){return"Nil"!==a[0]?void 0:["Tuple2",["Nil"],["Nil"]]},function(b){if("Cons"===b[0]){var c=b[1],b=b[2];var d=f(a)(b);"Tuple2"!==d[0]?c=void 0:(b=d[1],d=d[2],c=a(c)?["Tuple2",["Cons",c,b],d]:["Tuple2",b,["Cons",c,d]]);return c}}],d=c.length;d--;){var e=c[d](b);if(void 0!==e)return e}}()}}function g(a){return function(){for(var b=[function(a){return"Nil"!==a[0]?void 0:["Tuple2",["Nil"],["Nil"]]},function(a){if("Cons"!==a[0])a=void 0;else if(a=["Tuple2",a[1],g(a[2])],"Tuple2"!==a[0]||"Tuple2"!==
33+a[1][0])a=void 0;else var b=a[1][1],c=a[1][2],a="Tuple2"!==a[2][0]?void 0:["Tuple2",["Cons",b,a[2][1]],["Cons",c,a[2][2]]];return a}],c=b.length;c--;){var d=b[c](a);if(void 0!==d)return d}}()}function h(a){return function(b){return function(){for(var c=[function(a){return"Nil"!==a[0]?void 0:["Nil"]},function(a){if("Cons"===a[0]){var b=a[1];return"Nil"!==a[2][0]?void 0:["Cons",b,["Nil"]]}},function(b){if("Cons"===b[0]){var c=b[1];if("Cons"===b[2][0]){var d=b[2][1],b=b[2][2];return["Cons",c,["Cons",
34+a,h(a)(["Cons",d,b])]]}}}],d=c.length;d--;){var e=c[d](b);if(void 0!==e)return e}}()}}function k(a){return function(b){return function(){for(var c=[function(a){return"Nil"!==a[0]?void 0:["Nil"]},function(a){if("Cons"===a[0]){var b=a[1];return"Nil"!==a[2][0]?void 0:b}},function(b){if("Cons"===b[0]){var c=b[1];if("Cons"===b[2][0]){var d=b[2][1],b=b[2][2];return Value.append(c,Value.append(a,k(a)(["Cons",d,b])))}}}],d=c.length;d--;){var e=c[d](b);if(void 0!==e)return e}}()}}var i=function(){throw"Function expecting a list!";
35+},j=a(function(a){return function(b){return["Cons",a,b]}})(["Nil"]),l=d(function(a){return function(b){return Value.append(a,b)}})(["Nil"]),m=a(function(a){return function(b){return a&&b}})(!0),n=a(function(a){return function(b){return a||b}})(!1),o=a(function(a){return function(b){return a+b}})(0),p=a(function(a){return function(b){return a*b}})(1),r=b(function(a){return function(b){return Math.max(a,b)}}),t=b(function(a){return function(b){return Math.min(a,b)}});return{head:function(a){if("Cons"!==
36+a[0])throw"Error: 'head' only accepts lists of length greater than one.";return a[1]},tail:function(a){if("Cons"!==a[0])throw"Error: 'tail' only accepts lists of length greater than one.";return a[2]},map:c,foldl:a,foldr:d,foldl1:b,foldr1:function(a){return function(b){var c;"Cons"!==b[0]?c=void 0:(c=b[1],b=b[2],c=d(a)(c)(b));return c}},scanl:e,scanl1:function(a){return function(b){if("Cons"!==b[0])throw"Error: 'scanl1' requires a list of at least length 1.";return e(a)(b[1])(b[2])}},filter:function(a){return function(b){if("Nil"===
37+b[0])return b;"Cons"!==b[0]&&i();for(var c=[];"Cons"===b[0];)a(b[1])&&c.push(b[1]),b=b[2];for(var b=["Nil"],d=c.length;d--;)b=["Cons",c[d],b];return b}},length:function(a){for(var b=0;"Cons"===a[0];)b+=1,a=a[2];return b},reverse:j,concat:l,concatMap:function(a){return function(b){return l(c(a)(b))}},and:m,or:n,forall:function(b){return a(function(a){return function(c){return c&&b(a)}})(!0)},exists:function(b){return a(function(a){return function(c){return c||b(a)}})(!1)},sum:o,product:p,maximum:r,
38+minimum:t,partition:f,zipWith:function(a){return function(b){return function(c){if("Nil"===b[0]||"Nil"===c[0])return b;("Cons"!==b[0]||"Cons"!==c[0])&&i();for(var d=[];"Cons"===b[0]&&"Cons"===c[0];)d.push(a(b[1])(c[1])),b=b[2],c=c[2];for(var c=["Nil"],e=d.length;e--;)c=["Cons",d[e],c];return c}}},zip:function(a){return function(b){if("Nil"===a[0]||"Nil"===b[0])return a;("Cons"!==a[0]||"Cons"!==b[0])&&i();for(var c=[];"Cons"===a[0]&&"Cons"===b[0];)c.push(["Tuple2",a[1],b[1]]),a=a[2],b=b[2];for(var b=
39+["Nil"],d=c.length;d--;)b=["Cons",c[d],b];return b}},unzip:g,intersperse:h,intercalate:k,sort:function(a){if("Nil"===a[0])return a;"Cons"!==a[0]&&i();for(var b=[];"Cons"===a[0];)b.push(a[1]),a=a[2];b.sort(function(a,b){return a-b});for(var a=["Nil"],c=b.length;c--;)a=["Cons",b[c],a];return a}}}(),id=function(c){return c},not=function(c){return!c},sqrt=function(c){return Math.sqrt(c)},mod=function(c){return function(a){return c%a}},abs=function(c){return Math.abs(c)},logBase=function(c){return function(a){return Math.log(a)/
40+Math.log(c)}},min=function(c){return function(a){return Math.min(c,a)}},max=function(c){return function(a){return Math.max(c,a)}},clamp=function(c){return function(a){return function(d){return Math.min(a,Math.max(c,d))}}},sin=Math.sin,cos=Math.cos,tan=Math.tan,asin=Math.asin,acos=Math.acos,atan=Math.atan,flip=function(c){return function(a){return function(d){return c(d)(a)}}};function constant(c){return Elm.Input(c)}function lift(c){return function(a){return Elm.Lift(c,[a])}}
41+function lift2(c){return function(a){return function(d){return Elm.Lift(c,[a,d])}}}function lift3(c){return function(a){return function(d){return function(b){return Elm.Lift(c,[a,d,b])}}}}function lift4(c){return function(a){return function(d){return function(b){return function(e){return Elm.Lift(c,[a,d,b,e])}}}}}function foldp(c){return function(a){return function(d){return Elm.Fold(c,a,d)}}}var includeGlobal=this;
42+(function(){var c=function(a){for(var b in a)if("Internal"!==b)try{includeGlobal[b]=a[b]}catch(c){"length"===b&&(includeGlobal.execScript("var length;"),length=a[b])}},a=function(a){return function(b){includeGlobal[a]=includeGlobal[a]||{};for(var c in b)"Internal"!==c&&(includeGlobal[a][c]=b[c])}};c(Element);c(Text);color=Element.color;height=Element.height;show=Value.show;a("Time")(Signal.Time);a("Mouse")(Signal.Mouse);a("Window")(Signal.Window);a("HTTP")(Signal.HTTP);a("Input")(Signal.Input);a("Random")(Signal.Random);
43+c(Color);c(Shape);c(Line)})();
src/Ast.hsnew file+37
@@ -0,0 +1,37 @@
1+module Ast where
2+
3+data Pattern = PData String [Pattern] | PVar String | PAnything
4+ deriving (Show, Eq)
5+
6+data Expr = Number Int
7+ | Chr Char
8+ | Boolean Bool
9+ | Range Expr Expr
10+ | Access Expr String
11+ | Binop String Expr Expr
12+ | Lambda String Expr
13+ | App Expr Expr
14+ | If Expr Expr Expr
15+ | Lift Expr [Expr]
16+ | Fold Expr Expr Expr
17+ | Async Expr
18+ | Input String
19+ | Let [(String,Expr)] Expr
20+ | Var String
21+ | Case Expr [(Pattern,Expr)]
22+ | Data String [Expr]
23+ deriving (Show, Eq)
24+
25+cons h t = Data "Cons" [h,t]
26+nil = Data "Nil" []
27+list = foldr cons nil
28+tuple es = Data ("Tuple" ++ show (length es)) es
29+
30+delist (Data "Cons" [h,t]) = h : delist t
31+delist _ = []
32+
33+
34+pcons h t = PData "Cons" [h,t]
35+pnil = PData "Nil" []
36+plist = foldr pcons pnil
37+ptuple es = PData ("Tuple" ++ show (length es)) es
src/CompileToJS.hsnew file+88
@@ -0,0 +1,88 @@
1+
2+module CompileToJS (compile, compileToJS) where
3+
4+import Ast
5+import Control.Monad (liftM,(<=<),join)
6+import Data.Char (isAlpha)
7+import Data.List (intercalate,sortBy)
8+import Data.Map (toList)
9+
10+import Initialize
11+
12+
13+compile = (return . addMain . toJS) <=< initialize
14+compileToJS = addMain . either (\err -> "text('"++err++"')") toJS . initialize
15+addMain body = "function main(){return " ++ body ++ ";}"
16+
17+parens = ("("++) . (++")")
18+braces = ("{"++) . (++"}")
19+jsList = ("["++) . (++"]") . intercalate ","
20+jsFunc args body = "function(" ++ args ++ "){" ++ body ++ "}"
21+assign x e = "var " ++ x ++ "=" ++ e ++ ";"
22+ret e = "return "++ e ++";"
23+iff a b c = a ++ "?" ++ b ++ ":" ++ c
24+
25+toJS expr =
26+ case expr of
27+ Number n -> show n
28+ Var x -> x
29+ Chr c -> show c
30+ Boolean b -> if b then "true" else "false"
31+ Range lo hi -> jsRange (toJS lo) (toJS hi)
32+ Access e lbl -> toJS e ++ "." ++ lbl
33+ Binop op e1 e2 -> binop op (toJS e1) (toJS e2)
34+ If eb et ef -> parens $ iff (toJS eb) (toJS et) (toJS ef)
35+ Lambda v e -> jsFunc v $ ret (toJS e)
36+ App e1 e2 -> toJS e1 ++ parens (toJS e2)
37+ Let defs e -> jsLet defs e
38+ Case e cases -> jsCase e cases
39+ Data name es -> jsList $ show name : map toJS es
40+
41+jsLet defs e' = jsFunc "" (defs' ++ ret (toJS e')) ++ "()"
42+ where defs' = concatMap toDef $ sortBy f defs
43+ f a b = compare (isLambda a) (isLambda b)
44+ isLambda (_, Lambda _ _) = 1
45+ isLambda _ = 0
46+ toDef (f, Lambda x e) =
47+ "function " ++ f ++ parens x ++ braces (ret $ toJS e) ++ ";"
48+ toDef (x, e) = assign x (toJS e)
49+
50+jsCase e [c] = jsMatch c ++ parens (toJS e)
51+jsCase e cases = "(function(){" ++
52+ assign "v" (toJS e) ++
53+ assign "c" jsCases ++
54+ "for(var i=c.length;i--;){" ++
55+ assign "r" "c[i](v)" ++
56+ "if(r!==undefined){return r;}}}())"
57+ where jsCases = jsList $ map jsMatch (reverse cases)
58+
59+jsMatch (p,e) = jsFunc "v" . match p "v" . ret $ toJS e
60+match p v hole =
61+ case p of
62+ PAnything -> hole
63+ PVar x -> assign x v ++ hole
64+ PData name ps ->
65+ "if(" ++ show name ++ "!==" ++ v ++
66+ "[0]){return undefined;}else{"++body++"}"
67+ where matches = zipWith match ps vs
68+ vs = map (\i -> v++"["++show (i+1)++"]") [0..length ps-1]
69+ body = foldr ($) hole matches
70+
71+jsNil = "[\"Nil\"]"
72+jsCons e1 e2 = jsList [ show "Cons", e1, e2 ]
73+jsRange e1 e2 = (++"()") . jsFunc "" $
74+ assign "lo" e1 ++ assign "hi" e2 ++ assign "lst" jsNil ++
75+ "do{" ++ assign "lst" (jsCons "hi" "lst") ++ "}while(hi-->lo)" ++
76+ ret "lst"
77+
78+binop (o:p) e1 e2
79+ | (o:p) == "mod" = e1 ++ "%" ++ e2
80+ | isAlpha o || '_' == o = (o:p) ++ parens e1 ++ parens e2
81+ | otherwise = case o:p of
82+ ":" -> jsCons e1 e2
83+ "++" -> append e1 e2
84+ "$" -> e1 ++ parens e2
85+ "." -> jsFunc "x" . ret $ e1 ++ parens (e2 ++ parens "x")
86+ _ -> e1 ++ (o:p) ++ e2
87+
88+append e1 e2 = "Value.append" ++ parens (e1 ++ "," ++ e2)
src/Elm.hsnew file+45
@@ -0,0 +1,45 @@
1+
2+module Main where
3+
4+import System.Environment
5+import CompileToJS
6+import Data.List (isPrefixOf)
7+import GenerateHtml
8+import Text.Blaze.Renderer.String
9+
10+main = getArgs >>= parse
11+
12+parse ("--help":_) = putStrLn usage
13+parse ("--version":_) = putStrLn "The Elm Compiler 0.1"
14+parse [loc,file]
15+ | "--runtime-location=" `isPrefixOf` loc =
16+ produceHtml (tail $ dropWhile (/='=') loc) file
17+ | otherwise = putStrLn usageMini
18+parse [file] = produceHtml "elm-mini.js" file
19+parse _ = putStrLn usageMini
20+
21+produceHtml libLoc file = do
22+ code <- readFile file
23+ let name = takeWhile (/='.') file
24+ case compile code of
25+ Left err -> putStrLn err
26+ Right jsCode -> writeFile (name ++ ".html") . renderHtml $
27+ generateHtml libLoc name jsCode
28+
29+usageMini =
30+ "Usage: elm [OPTIONS] FILE\n\
31+ \Try `elm --help' for more information."
32+
33+usage =
34+ "Usage: elm [OPTIONS] FILE\n\
35+ \Compile .elm files to .html files.\n\
36+ \Example: elm main.elm\n\
37+ \\n\
38+ \Resource Locations:\n\
39+ \ --runtime-location set the location of the Elm runtime (elm-mini.js)\n\
40+ \\n\
41+ \Compiler Information:\n\
42+ \ --version print the version information and exit\n\
43+ \ --help display this help and exit\n\
44+ \\n\
45+ \Elm home page: <http://elm-lang.org>"
src/ExtractNoscript.hsnew file+43
@@ -0,0 +1,43 @@
1+
2+module ExtractNoscript (extract) where
3+
4+import Ast
5+import List (isPrefixOf)
6+
7+extract = extract'
8+
9+extract' expr = makeLinks terms where
10+ terms =
11+ case expr of
12+ Number _ -> []
13+ Chr _ -> []
14+ Boolean _ -> []
15+ Range _ _ -> []
16+ Access _ _ -> []
17+ Binop op e1 e2 -> case (op, extract' e1, extract' e2) of
18+ ("++", [s1], [s2]) -> [ s1 ++ s2 ]
19+ (_ , ss1 , ss2 ) -> ss1 ++ ss2
20+ Lambda v e -> extract' e
21+ App e1 e2 -> extract' e1 ++ extract' e2
22+ If eb et ef -> extract' et ++ extract' ef
23+ Lift f es -> extract' f ++ concatMap extract es
24+ Fold e1 e2 e3 -> concatMap extract' [e1,e2,e3]
25+ Async e -> extract' e
26+ Input _ -> []
27+ Let defs e -> concatMap (extract' . snd) defs ++ extract' e
28+ Var _ -> []
29+ Case e cases -> concatMap (extract' . snd) cases
30+ Data _ _ -> [toString expr]
31+
32+toString (Data "Cons" [Chr c, t]) = c : toString t
33+toString _ = []
34+
35+makeLinks (a:b:[]) = linkify a b
36+makeLinks xs = xs
37+
38+linkish s = not (isPrefixOf "<a" s) && all (/=' ') s && any (=='/') s
39+
40+linkify a b
41+ | linkish a = [ "<a href=\"" ++ a ++ "\">" ++ b ++ "</a>" ]
42+ | linkish b = [ "<a href=\"" ++ b ++ "\">" ++ a ++ "</a>" ]
43+ | otherwise = [a,b]
src/FreeVar.hsnew file+30
@@ -0,0 +1,30 @@
1+module FreeVar (freeIn) where
2+
3+import Ast
4+import Data.Set hiding (map)
5+
6+x `freeIn` expr = member x $ freeVars expr
7+
8+freeVars expr =
9+ let f = freeVars in
10+ case expr of
11+ Range e1 e2 -> union (f e1) (f e2)
12+ Binop op e1 e2 -> union (f e1) (f e2)
13+ Lambda x e -> delete x (f e)
14+ App e1 e2 -> union (f e1) (f e2)
15+ If e1 e2 e3 -> unions $ map f [e1,e2,e3]
16+ Lift e es -> unions $ map f es
17+ Fold e1 e2 e3 -> unions $ map f [e1,e2,e3]
18+ Async e -> f e
19+ Let defs e -> foldr delete (unions (f e : map f es)) vs
20+ where (vs,es) = unzip defs
21+ Var x -> singleton x
22+ Data name es -> unions (map f es)
23+ Case e cases -> union (f e) (unions $ map caseFreeVars cases)
24+ _ -> empty
25+
26+caseFreeVars (p,e) = difference (freeVars e) (pvars p)
27+ where pvars p = case p of
28+ PAnything -> empty
29+ PVar x -> singleton x
30+ PData _ ps -> unions (map pvars ps)
src/GenerateHtml.hsnew file+32
@@ -0,0 +1,32 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module GenerateHtml (generateHtml) where
3+
4+import Text.Blaze.Html5 hiding (map)
5+import qualified Text.Blaze.Html5 as H
6+import Text.Blaze.Html5.Attributes
7+import qualified Text.Blaze.Html5.Attributes as A
8+
9+css = preEscapedString "* { padding:0; margin:0; \
10+ \hyphens: auto; -moz-hyphens: auto;\
11+ \ -webkit-hyphens: auto; -ms-hyphens: auto; }\
12+ \body { font-family: Arial; }\
13+ \a:link {text-decoration: none}\
14+ \a:visited {text-decoration: none}\
15+ \a:active {text-decoration: none}\
16+ \a:hover {text-decoration: underline; color: #ff8f12;}"
17+
18+makeScript :: String -> Html
19+makeScript s = script ! type_ "text/javascript" ! src (toValue s) $ ""
20+
21+generateHtml libLoc title source =
22+ docTypeHtml $ do
23+ H.head $ do
24+ meta ! charset "UTF-8"
25+ H.title . toHtml $ title
26+ makeScript libLoc
27+ (script ! type_ "text/javascript") . preEscapedString $ source
28+ H.style ! type_ "text/css" $ css
29+ body $ do
30+ H.div ! A.id "widthChecker" ! A.style "width:100%; height:1px; position:absolute; top:-1px;" $ ""
31+ H.span ! A.id "content" $ ""
32+ script ! type_ "text/javascript" $ "Dispatcher.initialize()"
src/Initialize.hsnew file+154
@@ -0,0 +1,154 @@
1+module Initialize (initialize) where
2+
3+import Ast
4+import Control.Arrow (first)
5+import Control.Monad
6+import Data.Char (isAlpha)
7+import Data.Maybe (mapMaybe)
8+import Data.Either (rights)
9+import FreeVar
10+import Lexer
11+import Parser (toExpr,toDefs)
12+import Rename (rename)
13+import Replace
14+import System.IO.Unsafe
15+
16+initialize str = do
17+ expr <- toDefs =<< tokenize str
18+-- let rexpr = rename expr
19+-- let init = simp_loop rexpr
20+-- return $ if depth init < depth rexpr then init else rexpr
21+ return $ rename expr
22+{--
23+simp_loop exp = if exp == exp' then exp' else simp_loop exp'
24+ where exp' = simp exp
25+
26+simp expr =
27+ let f = simp in
28+ case expr of
29+ Range e1 e2 -> simp_range (f e1) (f e2)
30+ Binop op e1 e2 -> simp_binop op (f e1) (f e2)
31+ Lambda x e -> Lambda x (f e)
32+ App e1 e2 -> simp_app (f e1) (f e2)
33+ If e1 e2 e3 -> simp_if (f e1) (f e2) (f e3)
34+ Lift e es -> Lift (f e) $ map f es
35+ Fold e1 e2 e3 -> Fold (f e1) (f e2) (f e3)
36+ Async e -> Async (f e)
37+ Let x e1 e2 -> simp_let x (f e1) (f e2)
38+ Data name es -> Data name (map f es)
39+ Case e cases -> simp_case (f e) cases
40+ _ -> expr
41+
42+data Status = NoMatch | Quit deriving (Show,Eq)
43+
44+simp_case v cases =
45+ case v of
46+ Data _ _ -> case rights $ map (\(p,e) -> match p v e) cases of
47+ { v:_ -> v; _ -> Case v cases }
48+ _ -> Case v cases
49+
50+match p v hole =
51+ case p of PAnything -> return hole
52+ PVar x -> return $ Let x v hole
53+ PData pn ps ->
54+ case v of
55+ Data vn vs -> if pn /= vn then Left NoMatch else
56+ foldM (flip ($)) hole (zipWith match ps vs)
57+ _ -> Left Quit
58+
59+simp_let x e1 e2
60+ | not (x `freeIn` e2) = e2
61+ | isValue e1 = Let x e1 (replace x e1 e2)
62+ | otherwise = Let x e1 e2
63+
64+simp_app e1 e2 =
65+ case e1 of
66+ Let x s e -> if x `freeIn` e2 then error "Overlapping names!" else
67+ Let x s (App e e2)
68+ Lambda x e -> Let x e2 e
69+{--
70+ Var "constant" -> App (Lambda "v" (Lift (Var "v") [])) e2
71+ Var "async" -> Async e2
72+ Var "foldp" -> Lambda "b" . Lambda "s" $ (Fold e2 (Var "b") (Var "s"))
73+ Var "lift" -> Lambda "s" (Lift e2 [Var "s"])
74+ Var "lift2" -> Lambda "s1" . Lambda "s2" $ (Lift e2 [Var "s1",Var "s2"])
75+--}
76+ _ -> App e1 e2
77+
78+simp_if (Boolean b) e2 e3 = if b then e2 else e3
79+simp_if a b c = If a b c
80+
81+isValue expr =
82+ case expr of
83+ Number _ -> True
84+ Chr _ -> True
85+ Boolean _ -> True
86+ Range _ _ -> True
87+ Lambda _ _ -> True
88+ Data _ _ -> True
89+ Var _ -> True
90+ _ -> False
91+
92+simp_range lo hi = toAST (parse code)
93+ where toAST = either (error "Compilation Failure") (\f -> App (App f lo) hi)
94+ parse str = toExpr =<< tokenize str
95+ code = "let range xs lo hi = \
96+ \if hi < lo then xs else range (hi:xs) lo (hi-1) in\
97+ \ \\x y -> range [] x y"
98+
99+simp_binop "mod" (Number n) (Number m) = Number (mod n m)
100+simp_binop "mod" e1 e2 = Binop "mod" e1 e2
101+simp_binop str e1 e2
102+ | isAlpha (head str) || '_' == head str =
103+ App (App (Var str) e1) e2
104+ | otherwise = binop str e1 e2
105+
106+binop op (Number n) (Number m) = f n m
107+ where f a b = case op of
108+ { "+" -> Number $ (+) a b
109+ ; "-" -> Number $ (-) a b
110+ ; "*" -> Number $ (*) a b
111+ --; "/" -> Number $ div a b
112+ ; "<" -> Boolean $ a < b
113+ ; ">" -> Boolean $ a < b
114+ ; "<=" -> Boolean $ a <= b
115+ ; ">=" -> Boolean $ a >= b
116+ ; "==" -> Boolean $ a == b
117+ ; "/=" -> Boolean $ a /= b
118+ ; _ -> Binop op (Number n) (Number m) }
119+
120+binop "-" e (Number 0) = e
121+binop "+" (Number 0) e = e
122+binop "+" (Number n) (Binop "+" (Number m) e) = binop "+" (Number (n+m)) e
123+binop "+" (Number n) (Binop "+" e (Number m)) = binop "+" (Number (n+m)) e
124+
125+binop "/" e (Number 1) = e
126+binop "*" (Number 0) e = Number 0
127+binop "*" (Number 1) e = e
128+binop "*" (Number n) (Binop "*" (Number m) e) = binop "*" (Number (n*m)) e
129+binop "*" (Number n) (Binop "*" e (Number m)) = binop "*" (Number (n*m)) e
130+
131+binop "+" e (Number n) = binop "+" (Number n) e
132+binop "*" e (Number n) = binop "*" (Number n) e
133+
134+binop op (Boolean n) (Boolean m) = f n m
135+ where f a b = case op of { "&&" -> Boolean $ (&&) n m
136+ ; "||" -> Boolean $ (||) n m
137+ ; _ -> Binop op (Boolean n) (Boolean m) }
138+
139+binop "&&" (Boolean True) e = e
140+binop "&&" (Boolean False) e = Boolean False
141+binop "||" (Boolean True) e = Boolean True
142+binop "||" (Boolean False) e = e
143+
144+binop op e (Boolean n) = binop op (Boolean n) e
145+
146+binop ":" h t = cons h t
147+binop "++" (Data "Nil" []) e = e
148+binop "++" e (Data "Nil" []) = e
149+binop "++" (Data "Cons" [h,t]) e = Data "Cons" [h, binop "++" t e]
150+
151+binop "$" e1 e2 = App e1 e2
152+
153+binop op e1 e2 = Binop op e1 e2
154+--}
src/Parse/Binop.hsnew file+63
@@ -0,0 +1,63 @@
1+module Binop (binops) where
2+
3+import Ast
4+import Combinators
5+import Control.Monad (liftM,guard)
6+import Data.List (foldl',splitAt,elemIndices,group,groupBy,sortBy,find)
7+import Data.Map as Map
8+import Data.Maybe (mapMaybe)
9+
10+data Assoc = L | Non | R deriving (Eq,Show)
11+
12+table = [ (9, R, ".")
13+ , (7, L, "*"), (7, L, "/"), (7, L, "mod")
14+ , (6, L, "+"), (6, L, "-")
15+ , (5, R, ":" ), (5, R, "++")
16+ , (4, Non, "<="), (4, Non, ">="), (4, Non, "<")
17+ , (4, Non, "=="), (4, Non, "/="), (4, Non, ">")
18+ , (3, R, "&&")
19+ , (2, R, "||")
20+ , (0, R, "$")
21+ ]
22+
23+sortOps = sortBy (\(i,_,_) (j,_,_) -> compare i j)
24+
25+binops term anyOp = do
26+ e <- term
27+ (ops,es) <- liftM unzip $ star (do { op <- anyOp; e <- term; return (op,e) })
28+ case binopOf (Map.empty) (sortOps table) ops (e:es) of
29+ Right e -> return e
30+ Left msg -> zero
31+
32+binopSplit seen opTable i ops es =
33+ case (splitAt i ops, splitAt (i+1) es) of
34+ ((befores, op:afters), (pres, posts)) ->
35+ do e1 <- binopOf seen opTable befores pres
36+ e2 <- binopOf seen opTable afters posts
37+ return $ Binop op e1 e2
38+
39+binopOf _ _ _ [e] = return e
40+binopOf _ [] ops es =
41+ return $ foldl (flip ($)) (head es) $ zipWith Binop ops (tail es)
42+
43+binopOf seen (tbl@((lvl, L, op):rest)) ops es =
44+ case elemIndices op ops of
45+ [] -> binopOf seen rest ops es
46+ is -> case Map.lookup lvl seen of
47+ Nothing -> binopSplit (insert lvl (L,op) seen) tbl (last is) ops es
48+ Just (L,_) -> binopSplit seen tbl (last is) ops es
49+ Just (assoc,op') -> Left $ errorMessage lvl op L op' assoc
50+binopOf seen (tbl@((lvl, assoc, op):rest)) ops es =
51+ case elemIndices op ops of
52+ [] -> binopOf seen rest ops es
53+ i:_ -> case Map.lookup lvl seen of
54+ Nothing -> binopSplit (insert lvl (R,op) seen) tbl i ops es
55+ Just (assoc',op') ->
56+ if assoc == assoc' && assoc /= Non then
57+ binopSplit seen tbl i ops es
58+ else Left $ errorMessage lvl op assoc op' assoc'
59+
60+errorMessage lvl op1 assoc1 op2 assoc2 =
61+ "Cannot have (" ++ op1 ++ ") with [" ++ show assoc1 ++ " " ++
62+ show lvl ++ "] and (" ++ op2 ++ ") with [" ++ show assoc2 ++ " " ++
63+ show lvl ++ "]"
src/Parse/Combinators.hsnew file+82
@@ -0,0 +1,82 @@
1+module Combinators where
2+import Control.Monad
3+import Data.Char
4+import Data.List (sortBy)
5+
6+newtype Parser from to = Parser ([from] -> [(to,[from])])
7+--newtype Parser a = Parser (String -> [(a,String)])
8+
9+parse (Parser p) = p
10+
11+instance Monad (Parser from) where
12+ return a = Parser (\cs -> [(a,cs)])
13+ p >>= f = Parser (\cs -> concat [parse (f a) cs' | (a,cs') <- parse p cs])
14+
15+instance MonadPlus (Parser from) where
16+ mzero = Parser (\cs -> [])
17+ mplus p q = Parser (\cs -> parse p cs ++ parse q cs)
18+
19+-- True recursive descent, tries everything.
20+p +++ q = mplus p q
21+
22+-- Get the first parse.
23+p +|+ q = Parser (\cs -> case parse (mplus p q) cs of
24+ [] -> []
25+ (x:xs) -> [x])
26+
27+zero = Parser (\cs -> [])
28+
29+item = Parser (\cs -> case cs of
30+ [] -> []
31+ (c:cs) -> [(c,cs)])
32+
33+sat p = do {c <- item; if p c then return c else mzero}
34+
35+char c = sat (c ==)
36+
37+string "" = return ""
38+string (c:cs) = do {char c; string cs; return (c:cs)}
39+
40+star p = plus p +++ return []
41+plus p = do {a <- p; as <- star p; return (a:as)}
42+
43+optional p = do { p >>= return . Just } +++ return Nothing
44+
45+nospace = guard . (==0) . length =<< space
46+space = star $ sat isSpace
47+space1 = plus $ sat isSpace
48+newline = do
49+ star $ char ' ' +++ char '\t'
50+ char '\n'
51+ space
52+ return ""
53+
54+digit = do {x <- sat isDigit; return (ord x - ord '0')}
55+integer = do {i <- plus digit; return $ foldl (\a d -> 10 * a + d) 0 i}
56+
57+variable = do
58+ shd <- sat isLower;
59+ stl <- star $ sat (\c -> isAlphaNum c || c == '_')
60+ return $ shd:stl
61+
62+sepBy sep p = sepBy1 sep p +++ return []
63+
64+sepBy1 sep p = do
65+ x <- p
66+ xs <- star (sep >> p)
67+ return $ x:xs
68+
69+select ps = foldl1 (+|+) ps
70+
71+chainl p op a = (chainl1 p op) +++ return a
72+chainl1 p op = do {a <- p; rest a}
73+ where
74+ rest a = (do f <- op
75+ b <- p
76+ rest (f a b)) +++ return a
77+
78+extractResult err parse =
79+ case parse of
80+ (r,[]) : _ -> Right r
81+ _ : rest -> extractResult err rest
82+ [] -> Left err
src/Parse/Lexer.hsnew file+73
@@ -0,0 +1,73 @@
1+
2+module Lexer (tokenize) where
3+
4+import Data.Char (isSymbol)
5+import Text.Parsec.Char
6+import Text.Parsec.Combinator
7+import Text.ParserCombinators.Parsec.Prim (parse,(<|>),many,try)
8+import Tokens
9+
10+token = do { integer >>= return . NUMBER }
11+ <|> whitespace
12+ <|> chrs [ ('(',LPAREN) , (')',RPAREN)
13+ , ('{',LBRACE) , ('}',RBRACE)
14+ , ('[',LBRACKET), (']',RBRACKET)
15+ , (',',COMMA) , (';',SEMI), ('_',UNDERSCORE)
16+ , ('\\',LAMBDA) , ('\x03BB',LAMBDA) ]
17+ <|> reserveds [ ("True",TRUE), ("False",FALSE)
18+ , ("if",IF), ("then",THEN), ("else",ELSE)
19+ , ("case",CASE), ("of",OF), ("data", DATA)
20+ , ("let",LET), ("in",IN) ]
21+ <|> do { char '`'; v <- variable; char '`'; return $ OP v }
22+ <|> anyOp
23+ <|> do { char '"'; s <- many $ backslashed <|> satisfy (/='"'); char '"'
24+ ; return $ STRING s}
25+ <|> do { char '\''; c <- backslashed <|> satisfy (/='\''); char '\''
26+ ; return $ CHAR c}
27+ <|> do { variable >>= return . ID }
28+ <|> typeVar
29+ <|> do { try $ string "\r\n" <|> string "\n"; return NEWLINE }
30+
31+str s t = do { try $ string s; return t }
32+chrs = choice . map (uncurry chr)
33+chr c t = do { char c; return t }
34+reserveds = choice . map (uncurry reserved)
35+reserved str token =
36+ try $ do {string str; notFollowedBy $ alphaNum <|> char '_'; return token }
37+anyOp = do op <- many1 (satisfy isSymbol <|> oneOf "+-/*=.$<>:&|^?%#@~!")
38+ case op of { ".." -> return DOT2
39+ ; "->" -> return ARROW; "\8594" -> return ARROW
40+ ; _ -> return $ OP op }
41+
42+backslashed = do { char '\\'; c <- satisfy (\x -> True)
43+ ; return . read $ ['\'','\\',c,'\''] }
44+
45+integer = return . read =<< many1 digit
46+variable = do
47+ shd <- letter <|> char '_'
48+ stl <- many $ alphaNum <|> char '_' <|> char '\''
49+ return $ shd:stl
50+typeVar = do
51+ shd <- upper
52+ stl <- many $ alphaNum <|> char '_' <|> char '\''
53+ return . TYPE $ shd:stl
54+
55+
56+---- White Space and comments ----
57+
58+whitespace = (lineComment >> return NEWLINE) <|>
59+ (many1 (multiComment <|> many1 (char ' ')) >> return SPACES)
60+lineComment = do try $ string "--"
61+ manyTill anyChar $ newline <|> (eof >> return '\n')
62+
63+multiComment = do { try $ string "{-"; closeComment }
64+closeComment = manyTill anyChar . choice $
65+ [ try $ string "-}"
66+ , do { try $ string "{-"; closeComment; closeComment }
67+ ]
68+
69+token_parser = many1 token
70+
71+tokenize s = case parse token_parser "" s of
72+ Right ts -> Right ts
73+ Left err -> Left $ "Syntax error: " ++ show err
src/Parse/ParsePatterns.hsnew file+31
@@ -0,0 +1,31 @@
1+module ParsePatterns (pattern_term, pattern_expr) where
2+
3+import Ast
4+import Combinators
5+import Data.Char (isUpper)
6+import ParserLib
7+import Tokens
8+import Types
9+
10+pattern_basic =
11+ (t UNDERSCORE >> return PAnything) +|+
12+ (do { x@(c:_) <- var ;
13+ if isUpper c then star pattern_term >>= return . PData x
14+ else return $ PVar x })
15+
16+pattern_tuple = do
17+ t LPAREN; ps <- sepBy1 (t COMMA) pattern_expr; t RPAREN
18+ return $ case ps of { [p] -> p; _ -> ptuple ps }
19+
20+pattern_cons = do
21+ p <- pattern_term
22+ colon <- optional $ op_parser (==":")
23+ case colon of
24+ Just ":" -> pattern_expr >>= return . pcons p
25+ Nothing -> return p
26+
27+pattern_list = do
28+ t LBRACKET; ps <- sepBy (t COMMA) pattern_expr; t RBRACKET; return (plist ps)
29+
30+pattern_term = pattern_tuple +|+ pattern_list +|+ pattern_basic
31+pattern_expr = pattern_tuple +|+ pattern_list +|+ pattern_cons
src/Parse/ParseTypes.hsnew file+56
@@ -0,0 +1,56 @@
1+module ParseTypes where
2+
3+import Ast
4+import Combinators
5+import Data.Char (isUpper)
6+import ParserLib
7+import Tokens
8+import Types
9+
10+type_var = do whitespace; t <- item
11+ case t of
12+ ID "Int" -> return IntT
13+ ID "String" -> return StringT
14+ ID "Char" -> return CharT
15+ ID "Bool" -> return BoolT
16+ ID (v:vs) -> return (if isUpper v then ADT (v:vs) []
17+ else VarT (v:vs))
18+ _ -> zero
19+
20+type_list = do t LBRACKET; ti <- type_expr; t RBRACKET; return $ ADT "List" []
21+type_tuple = do { t LPAREN; ts <- sepBy (t COMMA) type_expr; t RPAREN
22+ ; return $ case ts of { [t] -> t; _ -> ADT "Tuple" [] } }
23+
24+type_unamb = type_list +|+ type_tuple
25+
26+type_term = type_app +|+ type_unamb
27+
28+type_app = do
29+ tipe <- type_var
30+ case tipe of
31+ ADT name _ -> star type_term >>= return . AppT name
32+ _ -> return tipe
33+
34+type_expr = do t1 <- type_term
35+ arrow <- optional $ t ARROW
36+ case arrow of
37+ Just ARROW -> type_term >>= return . LambdaT t1
38+ Nothing -> return t1
39+
40+type_constr = do
41+ name <- cap_var
42+ args <- star (type_var +|+ type_unamb)
43+ return (Constructor name args)
44+
45+constr (Constructor name args) =
46+ (name, foldr Lambda (Data name (map Var argNames)) argNames)
47+ where argNames = map (("arg"++) . show) [1..length args]
48+
49+datatype = do
50+ t DATA
51+ adt <- cap_var
52+ vs <- star var
53+ assign
54+ ts <- sepBy1 (op_parser (=="|")) type_constr
55+ -- (adt, foldr ForallT (ADT adt ts) vs)
56+ return (map constr ts)
src/Parse/Parser.hsnew file+116
@@ -0,0 +1,116 @@
1+module Parser where
2+
3+import Ast
4+import Binop (binops)
5+import Combinators
6+import Data.List (foldl')
7+import Lexer
8+import ParserLib
9+import ParseTypes (datatype)
10+import ParsePatterns
11+import Tokens
12+
13+-------- Basic Terms --------
14+
15+num_term = do { whitespace; t <- item
16+ ; case t of { NUMBER n -> return $ Number n; _ -> zero } }
17+str_term = do { whitespace; t <- item
18+ ; case t of { STRING cs -> return . list $ map Chr cs
19+ ; _ -> zero } }
20+
21+var_term = do var >>= return . Var
22+chr_term = do chr >>= return . Chr
23+
24+true_term = do { t TRUE; return $ Boolean True }
25+false_term = do { t FALSE; return $ Boolean False }
26+
27+
28+-------- Complex Terms --------
29+
30+list_term = (do { t LBRACKET; start <- expr; t DOT2; end <- expr; t RBRACKET
31+ ; return $ Range start end }) +|+
32+ (do { t LBRACKET; es <- sepBy (t COMMA) expr; t RBRACKET
33+ ; return $ list es })
34+
35+parens_term = (do { t LPAREN; op <- anyOp; t RPAREN
36+ ; return . Lambda "x" . Lambda "y" $
37+ Binop op (Var "x") (Var "y") }) +|+
38+ (do { t LPAREN; es <- sepBy (t COMMA) expr; t RPAREN
39+ ; return $ case es of { [e] -> e; _ -> tuple es } })
40+
41+term = select [ num_term
42+ , str_term
43+ , accessible var_term
44+ , chr_term
45+ , true_term
46+ , false_term
47+ , list_term
48+ , accessible parens_term
49+ ]
50+
51+-------- Applications --------
52+
53+app_expr = do
54+ tlist <- plus term
55+ return $ case tlist of
56+ t:[] -> t
57+ t:ts -> foldl' App t ts
58+
59+
60+-------- Expressions with infix operators --------
61+
62+binary_expr = binops app_expr anyOp
63+
64+
65+-------- Normal Expressions --------
66+
67+if_expr = do { t IF; e1 <- expr; t THEN; e2 <- expr; t ELSE; e3 <- expr
68+ ; return $ If e1 e2 e3 }
69+
70+lambda_expr = do { t LAMBDA; vs <- plus var; t ARROW; e <- expr
71+ ; return $ foldr (\x e -> Lambda x e) e vs }
72+
73+assign_expr = whitespace >> assign_expr_nospace
74+assign_expr_nospace = do
75+ p:ps <- plus pattern_term; assign; e <- expr
76+ case p:ps of
77+ PVar x : _ -> return (x, foldr func e ps)
78+ where func PAnything e' = Lambda "_" e'
79+ func (PVar x) e' = Lambda x e'
80+ func p' e' = Lambda "_temp" (Case (Var "_temp") [(p', e')])
81+-- _ : [] -> return $ \hole -> Case e [(p,hole)]
82+ _ -> zero
83+
84+let_expr = do
85+ t LET; brace <- optional $ t LBRACE
86+ case brace of
87+ Nothing -> do f <- assign_expr; t IN; e <- expr; return (Let [f] e)
88+ Just LBRACE -> do fs <- sepBy1 (t SEMI) assign_expr; t RBRACE; t IN;
89+ e <- expr; return (Let fs e)
90+
91+case_expr = do
92+ t CASE; e <- expr; t OF; t LBRACE
93+ cases <- sepBy1 (t SEMI)
94+ (do { p <- pattern_expr; t ARROW; e <- expr; return (p,e) })
95+ t RBRACE
96+ return $ Case e cases
97+
98+-------- All Expressions --------
99+
100+expr = select [ let_expr
101+ , binary_expr
102+ , if_expr
103+ , case_expr
104+ , lambda_expr
105+ ]
106+
107+def = assign_expr_nospace >>= return . (:[])
108+
109+defs = do
110+ ds <- plus (whitespace >> plus (sat (==NEWLINE)) >> def +|+ datatype)
111+ star $ sat (==NEWLINE) +|+ sat (==SPACES)
112+ return $ Let (concat ds) (Var "main")
113+
114+err = "Parse Error: Better error messages to come!"
115+toExpr = extractResult err . parse expr
116+toDefs = extractResult err . parse defs . (NEWLINE:)
src/Parse/ParserLib.hsnew file+36
@@ -0,0 +1,36 @@
1+module ParserLib where
2+
3+import Ast
4+import Combinators
5+import Data.Char (isUpper)
6+import Tokens
7+
8+var_noSpace = do { t <- item; case t of { ID v -> return v; _ -> zero } }
9+var = whitespace >> var_noSpace
10+cap_var = do
11+ whitespace; t <- item
12+ case t of { ID (v:vs) -> if isUpper v then return (v:vs) else zero }
13+
14+chr = do { whitespace; t <- item; case t of { CHAR c -> return c; _ -> zero } }
15+
16+t_noSpace token = sat (==token)
17+t_withSpace token = forcedWS >> sat (==token)
18+t token = whitespace >> sat (==token)
19+
20+forcedWS = do { sat (==SPACES); star nl_space } +|+ plus nl_space
21+ where nl_space = plus (sat (==NEWLINE)) >> sat (==SPACES)
22+whitespace = optional forcedWS
23+
24+accessible exp = do
25+ e <- exp
26+ access <- optional $ op_parser_nospace (==".")
27+ case access of
28+ Just "." -> accessible (var >>= return . Access e)
29+ Nothing -> return e
30+
31+op_parser_nospace pred =
32+ do { t <- item
33+ ; case t of { OP op -> if pred op then return op else zero; _ -> zero } }
34+op_parser pred = whitespace >> op_parser_nospace pred
35+anyOp = op_parser (const True)
36+assign = op_parser (=="=")
src/Parse/Tokens.hsnew file+17
@@ -0,0 +1,17 @@
1+
2+module Tokens where
3+
4+data Token =
5+ NUMBER Int | ID String | TYPE String |
6+ CHAR Char | STRING String |
7+ LAMBDA | ARROW | OP String | DOT2 | UNDERSCORE |
8+ LPAREN | RPAREN |
9+ LBRACE | RBRACE |
10+ LBRACKET | RBRACKET |
11+ COMMA | SEMI |
12+ TRUE | FALSE |
13+ IF | THEN | ELSE |
14+ CASE | OF | LET | IN |
15+ SPACES | NEWLINE | DATA
16+ deriving (Show, Eq)
17+
src/Rename.hsnew file+73
@@ -0,0 +1,73 @@
1+module Rename (rename) where
2+
3+import Ast
4+import Control.Arrow (first)
5+import Control.Monad.State
6+import Data.Char (isLower)
7+import Data.List (mapAccumL)
8+import Data.Functor.Identity
9+
10+rename expr = evalState (rename' id expr) 0
11+
12+guid :: State Int Int
13+guid = do n <- get
14+ put (n+1)
15+ return n
16+
17+rename' env expr =
18+ case expr of
19+ Range e1 e2 -> do
20+ re1 <- rename' env e1; re2 <- rename' env e2
21+ return $ Range re1 re2
22+ Access e x -> do
23+ re <- rename' env e
24+ return $ Access re x
25+ Binop op e1 e2 ->
26+ do let rop = if isLower (head op) || '_' == head op then env op else op
27+ re1 <- rename' env e1; re2 <- rename' env e2
28+ return $ Binop rop re1 re2
29+ Lambda x e -> do (rx, env') <- extend env x
30+ rename' env' e >>= return . Lambda rx
31+ App e1 e2 -> do
32+ re1 <- rename' env e1; re2 <- rename' env e2
33+ return $ App re1 re2
34+ If e1 e2 e3 -> do
35+ re1 <- rename' env e1; re2 <- rename' env e2; re3 <- rename' env e3
36+ return $ If re1 re2 re3
37+ Lift e es -> do
38+ re <- rename' env e
39+ mapM (rename' env) es >>= return . Lift re
40+ Fold e1 e2 e3 -> do
41+ re1 <- rename' env e1; re2 <- rename' env e2; re3 <- rename' env e3
42+ return $ Fold re1 re2 re3
43+ Async e -> rename' env e >>= return . Async
44+ Let defs e -> do
45+ let (vs,es) = unzip defs
46+ env' <- foldM (\acc x -> extend acc x >>= return . snd) env vs
47+ es' <- mapM (rename' env') es; re <- rename' env' e
48+ return $ Let (zip (map env' vs) es') re
49+ Var x -> return . Var $ env x
50+ Data name es -> mapM (rename' env) es >>= return . Data name
51+ Case e cases -> do
52+ re <- rename' env e
53+ mapM (pattern_rename env) cases >>= return . (Case re)
54+ _ -> return expr
55+
56+extend env x = do
57+ n <- guid
58+ let rx = x ++ "_" ++ show n
59+ return (rx, (\y -> if y == x then rx else env y))
60+
61+pattern_extend pattern env =
62+ case pattern of
63+ PAnything -> return (PAnything, env)
64+ PVar x -> extend env x >>= return . first PVar
65+ PData name ps ->
66+ foldM f ([],env) ps >>= return . first (PData name . reverse)
67+ where f (rps,env') p = do (rp,env'') <- pattern_extend p env'
68+ return (rp:rps, env'')
69+
70+pattern_rename env (p,e) = do
71+ (rp,env') <- pattern_extend p env
72+ re <- rename' env' e
73+ return (rp,re)
src/Replace.hsnew file+50
@@ -0,0 +1,50 @@
1+module Replace (replace, depth) where
2+
3+import Ast
4+import Data.Set (singleton,empty,unions,member)
5+
6+replace y v expr =
7+ let f = replace y v in
8+ case expr of
9+ Range e1 e2 -> Range (f e1) (f e2)
10+ Access e x -> Access (f e) x
11+ Binop op e1 e2 -> Binop op (f e1) (f e2)
12+ App e1 e2 -> App (f e1) (f e2)
13+ If e1 e2 e3 -> If (f e1) (f e2) (f e3)
14+ Lift e es -> Lift (f e) (map f es)
15+ Fold e1 e2 e3 -> Fold (f e1) (f e2) (f e3)
16+ Async e -> Async (f e)
17+ Let defs e -> if elem y vs then Let defs e else Let (zip vs (map f es)) (f e)
18+ where (vs,es) = unzip defs
19+ Var x -> if x == y then v else Var x
20+ Data name es -> Data name (map f es)
21+ Case e cases -> Case (f e) $ map (case_replace y v) cases
22+ _ -> expr
23+
24+case_replace y v (p,e) =
25+ if member y (pattern_vars p) then (p,e) else (p, replace y v e)
26+
27+pattern_vars pattern =
28+ case pattern of
29+ PData _ ps -> unions (map pattern_vars ps)
30+ PVar x -> singleton x
31+ PAnything -> empty
32+
33+depth = depth' 0
34+depth' d expr =
35+ let f = depth' (d+1) in
36+ case expr of
37+ Range e1 e2 -> max (f e1) (f e2)
38+ Access e x -> f e
39+ Binop op e1 e2 -> max (f e1) (f e2)
40+ Lambda x e -> f e
41+ App e1 e2 -> max (f e1) (f e2)
42+ If e1 e2 e3 -> maximum [f e1, f e2, f e3]
43+ Lift e es -> maximum $ f e : map f es
44+ Fold e1 e2 e3 -> maximum [f e1, f e2, f e3]
45+ Async e -> f e
46+ Let defs e -> let (_,es) = unzip defs in maximum $ f e : map f es
47+ Data "Cons" es -> maximum $ map (depth' d) es
48+ Data name es -> maximum $ 1 : map f es
49+ Case e cases -> maximum $ f e : map (f . snd) cases
50+ _ -> d
src/Server.hsnew file+65
@@ -0,0 +1,65 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module Main where
3+
4+import Prelude hiding (head,span,id)
5+import Control.Monad (msum,guard)
6+import Control.Monad.Trans (MonadIO(liftIO))
7+import Data.List (isPrefixOf, isSuffixOf)
8+import Happstack.Server hiding (body)
9+import Happstack.Server.Compression
10+import System.Environment
11+import Text.Blaze.Html5 hiding (map)
12+import Text.Blaze.Html5.Attributes hiding (title,span,dir,style)
13+import Text.Blaze.Internal
14+import ToHtml
15+
16+serverConf = Conf { port = 80
17+ , validator = validator nullConf
18+ , tls = tls nullConf
19+ , logAccess = logAccess nullConf
20+ , timeout = timeout nullConf }
21+
22+serve :: String -> IO ()
23+serve libLoc = do
24+ putStrLn "Elm Server 0.1: running at <http://localhost:8000>"
25+ simpleHTTP nullConf $ do
26+ compressedResponseFilter
27+ msum [ uriRest (serveElm libLoc)
28+ , serveDirectory EnableBrowsing [] "."
29+ ]
30+
31+serveElm libLoc fp = do
32+ let ('/':path) = fp
33+ guard (".elm" `isSuffixOf` path)
34+ content <- liftIO (readFile path)
35+ ok . toResponse $ compileToHtml libLoc path content
36+
37+
38+main = getArgs >>= parse
39+
40+parse ("--help":_) = putStrLn usage
41+parse ("--version":_) = putStrLn "The Elm Server 0.1"
42+parse [] = serve "/elm-mini.js"
43+parse [arg]
44+ | "--runtime-location=" `isPrefixOf` arg =
45+ serve . tail $ dropWhile (/='=') arg
46+ | otherwise = putStrLn usageMini
47+parse _ = putStrLn usageMini
48+
49+usageMini =
50+ "Usage: elm-server [OPTIONS]\n\
51+ \Try `elm-server --help' for more information."
52+
53+usage =
54+ "Usage: elm-server [OPTIONS]\n\
55+ \Compiles and serves .elm files from the current directory.\n\
56+ \Example: elm-server\n\
57+ \\n\
58+ \Resource Locations:\n\
59+ \ --runtime-location set the location of the Elm runtime (elm-mini.js)\n\
60+ \\n\
61+ \Compiler Information:\n\
62+ \ --version print the version information and exit\n\
63+ \ --help display this help and exit\n\
64+ \\n\
65+ \Elm home page: <http://elm-lang.org>"
src/ToHtml.hsnew file+19
@@ -0,0 +1,19 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module ToHtml (compileToHtml) where
3+
4+import CompileToJS
5+import Data.Monoid (mempty)
6+import GenerateHtml
7+import Network.HTTP.Base (urlEncode)
8+import Text.Blaze.Html5 hiding (map)
9+import qualified Text.Blaze.Html5 as H
10+import Text.Blaze.Html5.Attributes
11+import qualified Text.Blaze.Html5.Attributes as A
12+
13+pageTitle fp =
14+ reverse . takeWhile (/='/') . drop 1 . dropWhile (/='.') $ reverse fp
15+
16+
17+compileToHtml :: String -> String -> String -> Html
18+compileToHtml libLoc fileName source =
19+ generateHtml libLoc (pageTitle fileName) (compileToJS source)
src/Types/TypeCheck.hsnew file+175
@@ -0,0 +1,175 @@
1+
2+module TypeCheck where
3+
4+import Ast
5+import Control.Monad
6+import Control.Monad.Trans.Error
7+import Data.IORef
8+import Data.List (foldl', foldl1')
9+import qualified Data.Map as Map
10+import System.IO.Unsafe
11+import TypeHints
12+import Types
13+
14+{-- -- Testing Code
15+import Testing
16+typeCheck' s = str2expr s >>= typeCheck
17+--}
18+{--
19+instance Monad (Either e) where
20+ return = Right
21+ Right m >>= k = k m
22+ Left e >>= _ = Left e
23+--}
24+typeCheck prog = unsafePerformIO $ do
25+ tipe <- tc typeHints prog
26+ case tipe of
27+ Right t -> unify (ADT "Element") t
28+ Left _ -> return tipe
29+
30+guess = liftM GuessT (newIORef Nothing)
31+
32+varType env x =
33+ case Map.lookup x env of
34+ Just t -> return $ Right t
35+ Nothing -> liftM Right $ guess
36+ -- return . Left $ "Variable '" ++ x ++ "' is not bound to a value!"
37+ -- This is no good because some fundamental functions are only
38+ -- defined in JS, but it is the right thing to do.
39+
40+tipe = return . Right
41+
42+tc :: Map.Map String Type -> Exp -> IO (Either String Type)
43+tc env exp =
44+ case exp of
45+ Number _ -> tipe NumberT
46+ Var x -> varType env x
47+ Str _ -> tipe StringT
48+ Chr _ -> tipe CharT
49+ Boolean _ -> tipe BoolT
50+ List es -> do
51+ either_ts <- liftM sequence $ mapM (tc env) es
52+ case either_ts of
53+ Right [] -> liftM (Right . ListT) guess
54+ Right (t:ts) ->
55+ return . liftM ListT =<< foldl' func (return $ Right t) ts
56+ where func iet t = do
57+ et <- iet
58+ case et of { Right t' -> unify t t'
59+ ; _ -> return et }
60+ Left err -> return $ Left err
61+ Range start end -> return . liftM ListT =<< unifyWith env start end unify
62+ Tuple es -> return . liftM TupleT . sequence =<< mapM (tc env) es
63+{--
64+ Record r -> do
65+ rList <- mapM (\(x,v) -> tc env v >>= tipe . (,) x) $
66+ Map.toList r
67+ tipe . RecordT $ Map.fromList rList
68+ Access e x -> do
69+ t <- tc env e
70+ let err = error $ "Field '" ++ x ++
71+ "' does not exist in record '" ++ show t ++ "'."
72+ case t of
73+ RecordT tRec -> tipe $ Map.findWithDefault err x tRec
74+ GuessT _ -> guess
75+ _ -> error $ "Expecting a record, but saw '" ++
76+ show t ++ "' instead."
77+--}
78+ Binop op e1 e2 -> unifyWith env e1 e2 (checkBinop op)
79+ Lambda x e -> do g <- guess
80+ return . liftM (LambdaT g) =<< tc (Map.insert x g env) e
81+ App e1 e2 -> do
82+ g <- guess
83+ unifyWith env e1 e2 $
84+ \ta tb -> do
85+ either_lam <- unify ta (LambdaT tb g)
86+ case either_lam of { Right t -> return $ Right g
87+ ; Left _ -> return either_lam }
88+ Let x e1 e2 -> tc env (App (Lambda x e2) e1)
89+ If eb et ef -> do
90+ either_tb <- unifyWith env eb (Boolean True) unify
91+ case either_tb of
92+ Right _ -> unifyWith env et ef unify
93+ Left _ -> return either_tb
94+ _ -> return . Right =<< guess
95+ -- return . Left $ "Failure during type-checking: not implemented yet"
96+
97+unifyWith env e1 e2 f = do
98+ t1 <- tc env e1
99+ t2 <- tc env e2
100+ case (t1, t2) of { (Right ta, Right tb) -> f ta tb
101+ ; (Left _, _) -> return t1
102+ ; (_, Left _) -> return t2 }
103+
104+
105+check es = return . foldl1' f =<< sequence es
106+ where f b e = case b of { Right _ -> e; Left _ -> b }
107+
108+checkBinop Cons t1 t2 = unify (ListT t1) t2
109+checkBinop Append t1 t2 = check [guess >>= unify t1 . ListT, unify t1 t2]
110+checkBinop Compose t1 t2 = do
111+ ga <- guess; gb <- guess; gc <- guess
112+ check [ unify t2 (LambdaT ga gb)
113+ , unify t1 (LambdaT gb gc)
114+ , tipe (LambdaT ga gc) ]
115+checkBinop Apply t1 t2 = do { g <- guess
116+ ; check [unify t1 (LambdaT t2 g), tipe g] }
117+checkBinop op t1 t2
118+ | elem op [And, Or] = check [unify BoolT t1, unify BoolT t2]
119+ | elem op [Equ, Neq] = check [guess >>= unify t1, unify t1 t2, tipe BoolT]
120+ | elem op [Lt, Lte, Gt, Gte] =
121+ check [unify NumberT t1, unify NumberT t2, tipe BoolT]
122+ | elem op [Add, Sub, Mul, Div] = check [unify NumberT t1, unify NumberT t2]
123+
124+unify t1 t2
125+ | t1 == t2 = tipe t1
126+ | otherwise =
127+ case (t1,t2) of
128+ (StringT, _) -> unify (ListT CharT) t2
129+ (_, StringT) -> unify t1 (ListT CharT)
130+ (ListT t1', ListT t2') -> return . fmap ListT =<< unify t1' t2'
131+ (TupleT ts1, TupleT ts2) ->
132+ return . fmap TupleT . sequence =<< zipWithM unify ts1 ts2
133+{--
134+ (RecordT tMap1, RecordT tMap2) ->
135+ tipe . RecordT =<< unifyTmap tMap1 tMap2
136+--}
137+ (GuessT ref, _) ->
138+ if t2 `contains` ref then
139+ return . Left $ "Cannot construct infinite type: " ++
140+ show t1 ++ " = " ++ show t2
141+ else do
142+ g <- readIORef ref
143+ case g of
144+ Just t1' -> unify t1' t2
145+ Nothing -> writeIORef ref (Just t2) >> tipe t1
146+ (_, GuessT ref) -> -- unify t2 t1
147+ if t1 `contains` ref then
148+ return . Left $ "Cannot construct infinite type: " ++
149+ show t1 ++ " = " ++ show t2
150+ else do
151+ g <- readIORef ref
152+ case g of
153+ Just t2' -> unify t1 t2'
154+ Nothing -> writeIORef ref (Just t1) >> tipe t2
155+ (LambdaT t1a t1b, LambdaT t2a t2b) -> do
156+ ta <- unify t1a t2a
157+ tb <- unify t1b t2b
158+ return $ liftM2 LambdaT ta tb
159+ (_, _) -> return . Left $
160+ "Type Error: saw type '" ++ show t2 ++
161+ "' but expecting type '" ++ show t1 ++ "'"
162+
163+unifyTmap tMap1 tMap2
164+ | Map.keysSet tMap1 /= Map.keysSet tMap2 =
165+ error "record unification failed"
166+ | otherwise = Map.intersectionWith unify tMap1 tMap2
167+
168+t `contains` ref =
169+ case t of
170+ ListT t' -> t' `contains` ref
171+ TupleT ts -> any (`contains` ref) ts
172+ LambdaT t1 t2 -> t1 `contains` ref || t2 `contains` ref
173+ {- RecordT (Map.Map String Type)-}
174+ GuessT ref' -> ref == ref'
175+ _ -> False
src/Types/TypeHints.hsnew file+30
@@ -0,0 +1,30 @@
1+
2+module TypeHints (typeHints) where
3+
4+import qualified Data.Map as Map
5+import Types
6+
7+elementT = ADT "Element" []
8+n2e2e = LambdaT IntT $ LambdaT elementT elementT
9+
10+str2elem = map (\f -> (f, LambdaT StringT elementT))
11+ [ "image", "video", "text", "leftText", "centerText", "rightText" ]
12+
13+textAttrs =
14+ [ ("link", LambdaT StringT s2s), ("fontSize", LambdaT IntT s2s) ] ++
15+ map (\f -> (f, s2s))
16+ ["header", "italic", "bold", "underline"
17+ , "overline", "strikeThrough" ]
18+ where s2s = LambdaT StringT StringT
19+
20+allHints = str2elem ++ textAttrs ++
21+ [ ("flowDown", LambdaT (ADT "List" [elementT]) elementT)
22+ , ("flowRight", LambdaT (ADT "List" [elementT]) elementT)
23+ , ("opacity", n2e2e)
24+ , ("width", n2e2e)
25+ , ("height", n2e2e)
26+ , ("size", LambdaT IntT n2e2e)
27+ , ("centerX", LambdaT elementT elementT)
28+ ]
29+
30+typeHints = Map.fromList allHints
src/Types/Types.hsnew file+34
@@ -0,0 +1,34 @@
1+
2+module Types where
3+
4+import Data.List (intercalate)
5+import Data.IORef
6+import System.IO.Unsafe
7+
8+data Type = IntT
9+ | StringT
10+ | CharT
11+ | BoolT
12+ | LambdaT Type Type
13+ | VarT String
14+ | ForallT String Type
15+ | AppT String [Type]
16+ | ADT String [Type]
17+ deriving (Eq)
18+
19+data Constructor = Constructor String [Type] deriving (Eq, Show)
20+
21+instance Show Type where
22+ show t =
23+ case t of
24+ { IntT -> "Int"
25+ ; StringT -> "String"
26+ ; CharT -> "Char"
27+ ; BoolT -> "Bool"
28+ ; LambdaT t1 t2 -> show t1 ++ " -> " ++ show t2
29+ ; VarT x -> x
30+ ; ForallT x t' -> "forall " ++ x ++ ". " ++ show t'
31+ ; AppT name args -> name ++ " " ++ intercalate " " (map show args)
32+ ; ADT name constrs ->
33+ name ++ " = " ++ intercalate " | " (map show constrs)
34+ }