Elm (empty) → 0.1.0
raw patch · 24 files changed
+1232/−0 lines, 24 filesdep +HTTPdep +basedep +blaze-htmlsetup-changed
Dependencies added: HTTP, base, blaze-html, containers, happstack-server, mtl, parsec, transformers
Files
- Elm.cabal +58/−0
- LICENSE +30/−0
- README +1/−0
- Setup.hs +2/−0
- elm-mini.js +45/−0
- src/Ast.hs +37/−0
- src/CompileToJS.hs +89/−0
- src/Elm.hs +45/−0
- src/FreeVar.hs +30/−0
- src/GenerateHtml.hs +32/−0
- src/Initialize.hs +154/−0
- src/Parse/Binop.hs +64/−0
- src/Parse/Combinators.hs +82/−0
- src/Parse/Lexer.hs +73/−0
- src/Parse/ParsePatterns.hs +30/−0
- src/Parse/ParseTypes.hs +56/−0
- src/Parse/Parser.hs +116/−0
- src/Parse/ParserLib.hs +36/−0
- src/Parse/Tokens.hs +17/−0
- src/Rename.hs +73/−0
- src/Replace.hs +50/−0
- src/Server.hs +59/−0
- src/ToHtml.hs +19/−0
- src/Types/Types.hs +34/−0
+ Elm.cabal view
@@ -0,0 +1,58 @@++Name: Elm+Version: 0.1.0+Synopsis: The Elm compiler and server.+Description: Elm aims to make client-side web-development more pleasant.+ It is a statically/strongly typed, functional reactive+ language to HTML, CSS, and JS. This package provides a+ compiler and server for Elm.++Homepage: http://elm-lang.org++License: BSD3+License-file: LICENSE++Author: Evan Czaplicki+Maintainer: info@elm-lang.org+Copyright: Copyright: (c) 2011-2012 Evan Czaplicki++Category: Compiler++Build-type: Simple++Extra-source-files: README, elm-mini.js+Cabal-version: >=1.6++source-repository head+ type: git+ location: git://github.com/evancz/Elm.git++Executable elm+ -- .hs or .lhs file containing the Main module.+ Main-is: Elm.hs+ Hs-Source-Dirs: src, src/Parse, src/Types+ other-modules: Ast, CompileToJS, FreeVar, GenerateHtml, Initialize,+ Rename, Replace, ToHtml, Binop, Combinators, Lexer,+ ParsePatterns, Parser, ParserLib, ParseTypes, Tokens,+ Types+ + -- Packages needed in order to build this package.+ Build-depends: base >=4.2 && <5, containers >= 0.3, transformers >= 0.2,+ mtl >= 2, parsec >= 3.1.1, blaze-html >=0.4 && <0.5+ + -- Modules not exported by this package.+ -- Other-modules: + + -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.+ -- Build-tools: + +Executable elm-server+ Main-is: Server.hs+ Hs-Source-Dirs: src, src/Parse, src/Types+ other-modules: Ast, CompileToJS, FreeVar, GenerateHtml, Initialize,+ Rename, Replace, ToHtml, Binop, Combinators, Lexer,+ ParsePatterns, Parser, ParserLib, ParseTypes, Tokens,+ Types+ Build-depends: base >=4.2 && <5, containers >= 0.3, transformers >= 0.2,+ mtl >= 2, parsec >= 3.1.1, blaze-html >=0.4 && <0.5,+ HTTP >= 4000, happstack-server >= 6.2.4
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2012, Evan Czaplicki + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Evan Czaplicki nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README view
@@ -0,0 +1,1 @@+TODO.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple +main = defaultMain
+ elm-mini.js view
@@ -0,0 +1,45 @@+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;+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",+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('"',""");c.replace("&","&");c.replace("'","'");c.replace("<","<");c.replace(">",">");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,+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(a){a=document.createElement(a);a.id=Guid.guid();return a},a=function(a){var b=c("div");b.appendChild(a);return b},d=function(a){return function(b){return function(d){var e=+c("div");e.isElmText=!0;e.innerHTML=d;e.style.textAlign=b;0<a&&(e.style.width=a+"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>=a&&(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"),+g=function(b){return"DIV"===b.tagName?b:a(b)},h=function(a){a.style.styleFloat="left";a.style.cssFloat="left";return a},j=function(a){a.style.position="absolute";return a},i=function(a,b,d){for(var e=c("div"),f=d.length;f--;){var j=b(d[f]);e.appendChild(j)}e.elmFlowDirection=a;return e},k=function(a){return function(b){for(var d=[];"Cons"===b[0];)d.push(b[1]),b=b[2];3<=a&&d.reverse();b=a%3;if(0==b)return i("Y",g,d);if(1==b)return i("X",h,d);if(2==b)return i("Z",j,d)}},l=function(a){return function(b){if("A"===+b.tagName)return l(a)(b.firstChild),b;if(b.hasOwnProperty("isElmText")){var e=d(a)(b.style.textAlign)(b.innerHTML);b.style.height=e.style.height}b.style.width=a+"px";return b}};return{text:b,image:function(a){var b=c("img");b.isElmLeaf=!0;b.onload=function(){""===b.style.width&&0<this.width&&(b.style.width=b.width=this.width+"px");""===b.style.height&&0<this.height&&(b.style.height=b.height=this.height+"px");Dispatcher.adjust()};b.src=String.toText(a);b.name=b.src;return b},video:function(b){var b=+String.toText(b),a=c("video");a.controls="controls";var d=c("source");d.src=b;d.type="video/"+b.substring(b.length-3,b.length);a.appendChild(d);a.isElmLeaf=!0;return a},audio:function(b){var b=String.toString(b),a=c("video");a.controls="controls";var d=c("source");d.src=b;d.type="audio/"+b.substring(b.length-3,b.length);a.appendChild(d);a.isElmLeaf=!0;return a},collage:function(b){return function(a){return function(d){var e=c("canvas");e.style.width=b+"px";e.style.height=a+"px";e.width=b;e.height=+a;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:k,layers:k(2),beside:function(b){return function(a){return k(1)(["Cons",b,["Cons",a,["Nil"]]])}},above:function(b){return function(a){return k(0)(["Cons",b,["Cons",a,["Nil"]]])}},below:function(b){return function(a){return k(3)(["Cons",b,["Cons",a,["Nil"]]])}},box:function(b){return function(a){a.style.position=+"absolute";a.style.margin="auto";var d=(b-1)%3,e=(b-1)/3;2>d&&(a.style.left=0);0<d&&(a.style.right=0);2>e&&(a.style.top=0);0<e&&(a.style.bottom=0);d=c("div");d.style.position="relative";d.appendChild(a);return d}},width:l,height:function(b){return function(a){("A"===a.tagName?a.firstChild:a).style.height=b+"px";return a}},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=+Color.Internal.extract(b);return a}},opacity:function(b){return function(a){a.style.opacity=b;return a}},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(""))},+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",+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),+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/+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,+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,j=h.length-+1,i=h[j][0],k=h[j][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,k);j--;){l=h[j][0];m=h[j][1];n=l-i;o=m-k;for(p=Math.sqrt(n*n+o*o);q<=p;)i+=n*q/p,k+=o*q/p,e[s?"lineTo":"moveTo"](i,k),n=l-i,o=m-k,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;k=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,+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=+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 j=d.step(c,e);j?this.value=a(d.value)(this.value):this[c]=!0;return j}};+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=+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 j=0,i=g=0,k=0,l=!0,m=!0;f--;)h=d(c[f]),j=Math.max(j,+h[0]),g=Math.max(g,h[1]),i+=h[0],k+=h[1],l=l&&0<h[0],m=m&&0<h[1];c=j;f=a.elmFlowDirection;"X"===f&&(c=l?i:0);"Y"===f&&(g=m?k: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,+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(){function c(a){for(var b=["Nil"],c=a.length;c--;)b=["Cons",a[c],b];return b}var a=function(){return document.addEventListener?function(a,b,c){a.addEventListener(b,c,!1)}:function(a,b,c){a.attachEvent("on"+b,c)}}(),d=function(){function b(a){var c=0,d=0;a||(a=window.event);if(a.pageX||a.pageY)c=a.pageX,d=a.pageY;else if(a.clientX||+a.clientY)c=a.clientX+document.body.scrollLeft+document.documentElement.scrollLeft,d=a.clientY+document.body.scrollTop+document.documentElement.scrollTop;return Value.Tuple(c,d)}var c=Elm.Input(Value.Tuple(0,0)),d=Elm.Input(!1),e=Elm.Input(!1);a(document,"click",function(){Dispatcher.notify(e.id,!0);Dispatcher.notify(e.id,!1)});a(document,"mousedown",function(){Dispatcher.notify(d.id,!0)});a(document,"mouseup",function(){Dispatcher.notify(d.id,!1)});a(document,"mousemove",function(a){Dispatcher.notify(c.id,+b(a))});return{position:c,x:Elm.Lift(function(a){return a[1]},[c]),y:Elm.Lift(function(a){return a[2]},[c]),isClicked:e,isDown:d}}(),b=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}}}(),e=function(){var b=+Elm.Input(Value.Tuple(window.innerWidth,window.innerHeight));a(window,"resize",function(){var a=document.getElementById("widthChecker").offsetWidth;Dispatcher.notify(b.id,Value.Tuple(a,window.innerHeight))});return{dimensions:b,width:Elm.Lift(function(a){return a[1]},[b]),height:Elm.Lift(function(a){return a[2]},[b])}}(),f=function(){var a=function(a){return function(b){var d=Elm.Input(["Waiting"]),e={};window.XMLHttpRequest?e=new XMLHttpRequest:window.ActiveXObject&&(e=new ActiveXObject("Microsoft.XMLHTTP"));+e.onreadystatechange=function(){4===e.readyState&&Dispatcher.notify(d.id,200===e.status?["Success",c(e.responseText)]:["Failure",e.status,c(e.statusText)])};e.open(a,String.toText(b),!0);e.send(null);return d}},b=function(a){return function(b){var d=Elm.Input(["Nothing"]),b=Elm.Lift(function(b){if("Just"!==b[0]){try{Dispatcher.notify(d.id,["Nothing"])}catch(e){}return[]}try{Dispatcher.notify(d.id,["Just",["Waiting"]])}catch(l){d.value=["Just",["Waiting"]]}var f={};window.XMLHttpRequest?f=new XMLHttpRequest:+window.ActiveXObject&&(f=new ActiveXObject("Microsoft.XMLHTTP"));f.onreadystatechange=function(){4===f.readyState&&Dispatcher.notify(d.id,["Just",200===f.status?["Success",c(f.responseText)]:["Failure",f.status,c(f.statusText)]])};f.open(a,String.toText(b[1]),!0);f.send(null);return[]},[b]);return Elm.Lift(function(a){return function(){return a}},[d,b])}};return{get:a("GET"),post:a("POST"),gets:b("GET"),posts:b("POST")}}(),g=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])}}}}}(),h=function(){var b=function(b){b.isElmLeaf=!0;var d=Elm.Input(["Nil"]);a(b,"keyup",function(){Dispatcher.notify(d.id,c(b.value));b.focus()});return Value.Tuple(b,d)},d=function(a){a=document.createElement(a);a.id=Guid.guid();return a},e=function(b){for(var c=d("select"),e=[];"Cons"===b[0];){var f=d("option"),g=Text.toText(b[1][1]);f.value=g;f.innerHTML=+g;c.appendChild(f);e.push(b[1][2]);b=b[2]}var h=Elm.Input(e[0]);a(c,"change",function(){Dispatcher.notify(h.id,e[c.selectedIndex])});return Value.Tuple(c,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(b){var c=d("input");c.type="checkbox";c.checked=b;var e=Elm.Input(b);a(c,"change",function(){Dispatcher.notify(e.id,+c.checked)});return Value.Tuple(c,e)},dropDown:e,stringDropDown:function(a){return e(List.map(function(a){return Value.Tuple(a,a)})(a))}}}();return{Mouse:d,Time:b,Window:e,HTTP:f,Random:g,Input:h}}(),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"===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=[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"!==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",a,h(a)(["Cons",d,b])]]}}}],d=c.length;d--;){var e=c[d](b);if(void 0!==e)return e}}()}}function j(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,j(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!";},k=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"!==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"===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:k,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,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=["Nil"],d=c.length;d--;)b=["Cons",c[d],b];return b}},unzip:g,intersperse:h,intercalate:j,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)/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)}}},+Just=function(c){return["Just",c]},Nothing=["Nothing"];function constant(c){return Elm.Input(c)}function lift(c){return function(a){return Elm.Lift(c,[a])}}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;+(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);+c(Color);c(Shape);c(Line)})();
+ src/Ast.hs view
@@ -0,0 +1,37 @@+module Ast where + +data Pattern = PData String [Pattern] | PVar String | PAnything + deriving (Show, Eq) + +data Expr = Number Int + | Chr Char + | Boolean Bool + | Range Expr Expr + | Access Expr String + | Binop String Expr Expr + | Lambda String Expr + | App Expr Expr + | If Expr Expr Expr + | Lift Expr [Expr] + | Fold Expr Expr Expr + | Async Expr + | Input String + | Let [(String,Expr)] Expr + | Var String + | Case Expr [(Pattern,Expr)] + | Data String [Expr] + deriving (Show, Eq) + +cons h t = Data "Cons" [h,t] +nil = Data "Nil" [] +list = foldr cons nil +tuple es = Data ("Tuple" ++ show (length es)) es + +delist (Data "Cons" [h,t]) = h : delist t +delist _ = [] + + +pcons h t = PData "Cons" [h,t] +pnil = PData "Nil" [] +plist = foldr pcons pnil +ptuple es = PData ("Tuple" ++ show (length es)) es
+ src/CompileToJS.hs view
@@ -0,0 +1,89 @@+ +module CompileToJS (compile, compileToJS) where + +import Ast +import Control.Monad (liftM,(<=<),join) +import Data.Char (isAlpha) +import Data.List (intercalate,sortBy) +import Data.Map (toList) + +import Initialize + + +compile = (return . addMain . toJS) <=< initialize +compileToJS = addMain . either (\err -> "text('"++err++"')") toJS . initialize +addMain body = "function main(){return " ++ body ++ ";}" + +parens = ("("++) . (++")") +braces = ("{"++) . (++"}") +jsList = ("["++) . (++"]") . intercalate "," +jsFunc args body = "function(" ++ args ++ "){" ++ body ++ "}" +assign x e = "var " ++ x ++ "=" ++ e ++ ";" +ret e = "return "++ e ++";" +iff a b c = a ++ "?" ++ b ++ ":" ++ c + +toJS expr = + case expr of + Number n -> show n + Var x -> x + Chr c -> show c + Boolean b -> if b then "true" else "false" + Range lo hi -> jsRange (toJS lo) (toJS hi) + Access e lbl -> toJS e ++ "." ++ lbl + Binop op e1 e2 -> binop op (toJS e1) (toJS e2) + If eb et ef -> parens $ iff (toJS eb) (toJS et) (toJS ef) + Lambda v e -> jsFunc v $ ret (toJS e) + App e1 e2 -> toJS e1 ++ parens (toJS e2) + Let defs e -> jsLet defs e + Case e cases -> jsCase e cases + Data name es -> jsList $ show name : map toJS es + +jsLet defs e' = jsFunc "" (defs' ++ ret (toJS e')) ++ "()" + where defs' = concatMap toDef $ sortBy f defs + f a b = compare (isLambda a) (isLambda b) + isLambda (_, Lambda _ _) = 1 + isLambda _ = 0 + toDef (f, Lambda x e) = + "function " ++ f ++ parens x ++ braces (ret $ toJS e) ++ ";" + toDef (x, e) = assign x (toJS e) + +jsCase e [c] = jsMatch c ++ parens (toJS e) +jsCase e cases = "(function(){" ++ + assign "v" (toJS e) ++ + assign "c" jsCases ++ + "for(var i=c.length;i--;){" ++ + assign "r" "c[i](v)" ++ + "if(r!==undefined){return r;}}}())" + where jsCases = jsList $ map jsMatch (reverse cases) + +jsMatch (p,e) = jsFunc "v" . match p "v" . ret $ toJS e +match p v hole = + case p of + PAnything -> hole + PVar x -> assign x v ++ hole + PData name ps -> + "if(" ++ show name ++ "!==" ++ v ++ + "[0]){return undefined;}else{"++body++"}" + where matches = zipWith match ps vs + vs = map (\i -> v++"["++show (i+1)++"]") [0..length ps-1] + body = foldr ($) hole matches + +jsNil = "[\"Nil\"]" +jsCons e1 e2 = jsList [ show "Cons", e1, e2 ] +jsRange e1 e2 = (++"()") . jsFunc "" $ + assign "lo" e1 ++ assign "hi" e2 ++ assign "lst" jsNil ++ + "do{" ++ assign "lst" (jsCons "hi" "lst") ++ "}while(hi-->lo)" ++ + ret "lst" + +binop (o:p) e1 e2 + | (o:p) == "mod" = e1 ++ "%" ++ e2 + | isAlpha o || '_' == o = (o:p) ++ parens e1 ++ parens e2 + | otherwise = case o:p of + ":" -> jsCons e1 e2 + "++" -> append e1 e2 + "$" -> e1 ++ parens e2 + "." -> jsFunc "x" . ret $ e1 ++ parens (e2 ++ parens "x") + "/=" -> e1 ++ "!==" ++ e2 + _ -> e1 ++ (o:p) ++ e2 + +append e1 e2 = "Value.append" ++ parens (e1 ++ "," ++ e2)
+ src/Elm.hs view
@@ -0,0 +1,45 @@++module Main where++import System.Environment+import CompileToJS+import Data.List (isPrefixOf)+import GenerateHtml+import Text.Blaze.Renderer.String++main = getArgs >>= parse++parse ("--help":_) = putStrLn usage+parse ("--version":_) = putStrLn "The Elm Compiler 0.1.0"+parse [loc,file]+ | "--runtime-location=" `isPrefixOf` loc =+ produceHtml (tail $ dropWhile (/='=') loc) file+ | otherwise = putStrLn usageMini+parse [file] = produceHtml "elm-mini.js" file+parse _ = putStrLn usageMini++produceHtml libLoc file = do+ code <- readFile file+ let name = takeWhile (/='.') file+ case compile code of+ Left err -> putStrLn err+ Right jsCode -> writeFile (name ++ ".html") . renderHtml $+ generateHtml libLoc name jsCode++usageMini =+ "Usage: elm [OPTIONS] FILE\n\+ \Try `elm --help' for more information."++usage =+ "Usage: elm [OPTIONS] FILE\n\+ \Compile .elm files to .html files.\n\+ \Example: elm --runtime-location=../elm-mini.js main.elm\n\+ \\n\+ \Resource Locations:\n\+ \ --runtime-location set the location of the Elm runtime (elm-mini.js)\n\+ \\n\+ \Compiler Information:\n\+ \ --version print the version information and exit\n\+ \ --help display this help and exit\n\+ \\n\+ \Elm home page: <http://elm-lang.org>"
+ src/FreeVar.hs view
@@ -0,0 +1,30 @@+module FreeVar (freeIn) where + +import Ast +import Data.Set hiding (map) + +x `freeIn` expr = member x $ freeVars expr + +freeVars expr = + let f = freeVars in + case expr of + Range e1 e2 -> union (f e1) (f e2) + Binop op e1 e2 -> union (f e1) (f e2) + Lambda x e -> delete x (f e) + App e1 e2 -> union (f e1) (f e2) + If e1 e2 e3 -> unions $ map f [e1,e2,e3] + Lift e es -> unions $ map f es + Fold e1 e2 e3 -> unions $ map f [e1,e2,e3] + Async e -> f e + Let defs e -> foldr delete (unions (f e : map f es)) vs + where (vs,es) = unzip defs + Var x -> singleton x + Data name es -> unions (map f es) + Case e cases -> union (f e) (unions $ map caseFreeVars cases) + _ -> empty + +caseFreeVars (p,e) = difference (freeVars e) (pvars p) + where pvars p = case p of + PAnything -> empty + PVar x -> singleton x + PData _ ps -> unions (map pvars ps)
+ src/GenerateHtml.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE OverloadedStrings #-} +module GenerateHtml (generateHtml) where + +import Text.Blaze.Html5 hiding (map) +import qualified Text.Blaze.Html5 as H +import Text.Blaze.Html5.Attributes +import qualified Text.Blaze.Html5.Attributes as A + +css = preEscapedString "* { padding:0; margin:0; \ + \hyphens: auto; -moz-hyphens: auto;\ + \ -webkit-hyphens: auto; -ms-hyphens: auto; }\ + \body { font-family: Arial; }\ + \a:link {text-decoration: none}\ + \a:visited {text-decoration: none}\ + \a:active {text-decoration: none}\ + \a:hover {text-decoration: underline; color: #ff8f12;}" + +makeScript :: String -> Html +makeScript s = script ! type_ "text/javascript" ! src (toValue s) $ "" + +generateHtml libLoc title source = + docTypeHtml $ do + H.head $ do + meta ! charset "UTF-8" + H.title . toHtml $ title + makeScript libLoc + (script ! type_ "text/javascript") . preEscapedString $ source + H.style ! type_ "text/css" $ css + body $ do + H.div ! A.id "widthChecker" ! A.style "width:100%; height:1px; position:absolute; top:-1px;" $ "" + H.span ! A.id "content" $ "" + script ! type_ "text/javascript" $ "Dispatcher.initialize()"
+ src/Initialize.hs view
@@ -0,0 +1,154 @@+module Initialize (initialize) where + +import Ast +import Control.Arrow (first) +import Control.Monad +import Data.Char (isAlpha) +import Data.Maybe (mapMaybe) +import Data.Either (rights) +import FreeVar +import Lexer +import Parser (toExpr,toDefs) +import Rename (rename) +import Replace +import System.IO.Unsafe + +initialize str = do + expr <- toDefs =<< tokenize str +-- let rexpr = rename expr +-- let init = simp_loop rexpr +-- return $ if depth init < depth rexpr then init else rexpr + return $ rename expr +{-- +simp_loop exp = if exp == exp' then exp' else simp_loop exp' + where exp' = simp exp + +simp expr = + let f = simp in + case expr of + Range e1 e2 -> simp_range (f e1) (f e2) + Binop op e1 e2 -> simp_binop op (f e1) (f e2) + Lambda x e -> Lambda x (f e) + App e1 e2 -> simp_app (f e1) (f e2) + If e1 e2 e3 -> simp_if (f e1) (f e2) (f e3) + Lift e es -> Lift (f e) $ map f es + Fold e1 e2 e3 -> Fold (f e1) (f e2) (f e3) + Async e -> Async (f e) + Let x e1 e2 -> simp_let x (f e1) (f e2) + Data name es -> Data name (map f es) + Case e cases -> simp_case (f e) cases + _ -> expr + +data Status = NoMatch | Quit deriving (Show,Eq) + +simp_case v cases = + case v of + Data _ _ -> case rights $ map (\(p,e) -> match p v e) cases of + { v:_ -> v; _ -> Case v cases } + _ -> Case v cases + +match p v hole = + case p of PAnything -> return hole + PVar x -> return $ Let x v hole + PData pn ps -> + case v of + Data vn vs -> if pn /= vn then Left NoMatch else + foldM (flip ($)) hole (zipWith match ps vs) + _ -> Left Quit + +simp_let x e1 e2 + | not (x `freeIn` e2) = e2 + | isValue e1 = Let x e1 (replace x e1 e2) + | otherwise = Let x e1 e2 + +simp_app e1 e2 = + case e1 of + Let x s e -> if x `freeIn` e2 then error "Overlapping names!" else + Let x s (App e e2) + Lambda x e -> Let x e2 e +{-- + Var "constant" -> App (Lambda "v" (Lift (Var "v") [])) e2 + Var "async" -> Async e2 + Var "foldp" -> Lambda "b" . Lambda "s" $ (Fold e2 (Var "b") (Var "s")) + Var "lift" -> Lambda "s" (Lift e2 [Var "s"]) + Var "lift2" -> Lambda "s1" . Lambda "s2" $ (Lift e2 [Var "s1",Var "s2"]) +--} + _ -> App e1 e2 + +simp_if (Boolean b) e2 e3 = if b then e2 else e3 +simp_if a b c = If a b c + +isValue expr = + case expr of + Number _ -> True + Chr _ -> True + Boolean _ -> True + Range _ _ -> True + Lambda _ _ -> True + Data _ _ -> True + Var _ -> True + _ -> False + +simp_range lo hi = toAST (parse code) + where toAST = either (error "Compilation Failure") (\f -> App (App f lo) hi) + parse str = toExpr =<< tokenize str + code = "let range xs lo hi = \ + \if hi < lo then xs else range (hi:xs) lo (hi-1) in\ + \ \\x y -> range [] x y" + +simp_binop "mod" (Number n) (Number m) = Number (mod n m) +simp_binop "mod" e1 e2 = Binop "mod" e1 e2 +simp_binop str e1 e2 + | isAlpha (head str) || '_' == head str = + App (App (Var str) e1) e2 + | otherwise = binop str e1 e2 + +binop op (Number n) (Number m) = f n m + where f a b = case op of + { "+" -> Number $ (+) a b + ; "-" -> Number $ (-) a b + ; "*" -> Number $ (*) a b + --; "/" -> Number $ div a b + ; "<" -> Boolean $ a < b + ; ">" -> Boolean $ a < b + ; "<=" -> Boolean $ a <= b + ; ">=" -> Boolean $ a >= b + ; "==" -> Boolean $ a == b + ; "/=" -> Boolean $ a /= b + ; _ -> Binop op (Number n) (Number m) } + +binop "-" e (Number 0) = e +binop "+" (Number 0) e = e +binop "+" (Number n) (Binop "+" (Number m) e) = binop "+" (Number (n+m)) e +binop "+" (Number n) (Binop "+" e (Number m)) = binop "+" (Number (n+m)) e + +binop "/" e (Number 1) = e +binop "*" (Number 0) e = Number 0 +binop "*" (Number 1) e = e +binop "*" (Number n) (Binop "*" (Number m) e) = binop "*" (Number (n*m)) e +binop "*" (Number n) (Binop "*" e (Number m)) = binop "*" (Number (n*m)) e + +binop "+" e (Number n) = binop "+" (Number n) e +binop "*" e (Number n) = binop "*" (Number n) e + +binop op (Boolean n) (Boolean m) = f n m + where f a b = case op of { "&&" -> Boolean $ (&&) n m + ; "||" -> Boolean $ (||) n m + ; _ -> Binop op (Boolean n) (Boolean m) } + +binop "&&" (Boolean True) e = e +binop "&&" (Boolean False) e = Boolean False +binop "||" (Boolean True) e = Boolean True +binop "||" (Boolean False) e = e + +binop op e (Boolean n) = binop op (Boolean n) e + +binop ":" h t = cons h t +binop "++" (Data "Nil" []) e = e +binop "++" e (Data "Nil" []) = e +binop "++" (Data "Cons" [h,t]) e = Data "Cons" [h, binop "++" t e] + +binop "$" e1 e2 = App e1 e2 + +binop op e1 e2 = Binop op e1 e2 +--}
+ src/Parse/Binop.hs view
@@ -0,0 +1,64 @@+module Binop (binops) where + +import Ast +import Combinators +import Control.Monad (liftM,guard) +import Control.Monad.Error +import Data.List (foldl',splitAt,elemIndices,group,groupBy,sortBy,find) +import Data.Map as Map +import Data.Maybe (mapMaybe) + +data Assoc = L | Non | R deriving (Eq,Show) + +table = [ (9, R, ".") + , (7, L, "*"), (7, L, "/"), (7, L, "mod") + , (6, L, "+"), (6, L, "-") + , (5, R, ":" ), (5, R, "++") + , (4, Non, "<="), (4, Non, ">="), (4, Non, "<") + , (4, Non, "=="), (4, Non, "/="), (4, Non, ">") + , (3, R, "&&") + , (2, R, "||") + , (0, R, "$") + ] + +sortOps = sortBy (\(i,_,_) (j,_,_) -> compare i j) + +binops term anyOp = do + e <- term + (ops,es) <- liftM unzip $ star (do { op <- anyOp; e <- term; return (op,e) }) + case binopOf (Map.empty) (sortOps table) ops (e:es) of + Right e -> return e + Left msg -> zero + +binopSplit seen opTable i ops es = + case (splitAt i ops, splitAt (i+1) es) of + ((befores, op:afters), (pres, posts)) -> + do e1 <- binopOf seen opTable befores pres + e2 <- binopOf seen opTable afters posts + return $ Binop op e1 e2 + +binopOf _ _ _ [e] = return e +binopOf _ [] ops es = + return $ foldl (flip ($)) (head es) $ zipWith Binop ops (tail es) + +binopOf seen (tbl@((lvl, L, op):rest)) ops es = + case elemIndices op ops of + [] -> binopOf seen rest ops es + is -> case Map.lookup lvl seen of + Nothing -> binopSplit (insert lvl (L,op) seen) tbl (last is) ops es + Just (L,_) -> binopSplit seen tbl (last is) ops es + Just (assoc,op') -> Left $ errorMessage lvl op L op' assoc +binopOf seen (tbl@((lvl, assoc, op):rest)) ops es = + case elemIndices op ops of + [] -> binopOf seen rest ops es + i:_ -> case Map.lookup lvl seen of + Nothing -> binopSplit (insert lvl (R,op) seen) tbl i ops es + Just (assoc',op') -> + if assoc == assoc' && assoc /= Non then + binopSplit seen tbl i ops es + else Left $ errorMessage lvl op assoc op' assoc' + +errorMessage lvl op1 assoc1 op2 assoc2 = + "Cannot have (" ++ op1 ++ ") with [" ++ show assoc1 ++ " " ++ + show lvl ++ "] and (" ++ op2 ++ ") with [" ++ show assoc2 ++ " " ++ + show lvl ++ "]"
+ src/Parse/Combinators.hs view
@@ -0,0 +1,82 @@+module Combinators where +import Control.Monad +import Data.Char +import Data.List (sortBy) + +newtype Parser from to = Parser ([from] -> [(to,[from])]) +--newtype Parser a = Parser (String -> [(a,String)]) + +parse (Parser p) = p + +instance Monad (Parser from) where + return a = Parser (\cs -> [(a,cs)]) + p >>= f = Parser (\cs -> concat [parse (f a) cs' | (a,cs') <- parse p cs]) + +instance MonadPlus (Parser from) where + mzero = Parser (\cs -> []) + mplus p q = Parser (\cs -> parse p cs ++ parse q cs) + +-- True recursive descent, tries everything. +p +++ q = mplus p q + +-- Get the first parse. +p +|+ q = Parser (\cs -> case parse (mplus p q) cs of + [] -> [] + (x:xs) -> [x]) + +zero = Parser (\cs -> []) + +item = Parser (\cs -> case cs of + [] -> [] + (c:cs) -> [(c,cs)]) + +sat p = do {c <- item; if p c then return c else mzero} + +char c = sat (c ==) + +string "" = return "" +string (c:cs) = do {char c; string cs; return (c:cs)} + +star p = plus p +++ return [] +plus p = do {a <- p; as <- star p; return (a:as)} + +optional p = do { p >>= return . Just } +++ return Nothing + +nospace = guard . (==0) . length =<< space +space = star $ sat isSpace +space1 = plus $ sat isSpace +newline = do + star $ char ' ' +++ char '\t' + char '\n' + space + return "" + +digit = do {x <- sat isDigit; return (ord x - ord '0')} +integer = do {i <- plus digit; return $ foldl (\a d -> 10 * a + d) 0 i} + +variable = do + shd <- sat isLower; + stl <- star $ sat (\c -> isAlphaNum c || c == '_') + return $ shd:stl + +sepBy sep p = sepBy1 sep p +++ return [] + +sepBy1 sep p = do + x <- p + xs <- star (sep >> p) + return $ x:xs + +select ps = foldl1 (+|+) ps + +chainl p op a = (chainl1 p op) +++ return a +chainl1 p op = do {a <- p; rest a} + where + rest a = (do f <- op + b <- p + rest (f a b)) +++ return a + +extractResult err parse = + case parse of + (r,[]) : _ -> Right r + _ : rest -> extractResult err rest + [] -> Left err
+ src/Parse/Lexer.hs view
@@ -0,0 +1,73 @@+ +module Lexer (tokenize) where + +import Data.Char (isSymbol) +import Text.Parsec.Char +import Text.Parsec.Combinator +import Text.ParserCombinators.Parsec.Prim (parse,(<|>),many,try) +import Tokens + +token = do { integer >>= return . NUMBER } + <|> whitespace + <|> chrs [ ('(',LPAREN) , (')',RPAREN) + , ('{',LBRACE) , ('}',RBRACE) + , ('[',LBRACKET), (']',RBRACKET) + , (',',COMMA) , (';',SEMI), ('_',UNDERSCORE) + , ('\\',LAMBDA) , ('\x03BB',LAMBDA) ] + <|> reserveds [ ("True",TRUE), ("False",FALSE) + , ("if",IF), ("then",THEN), ("else",ELSE) + , ("case",CASE), ("of",OF), ("data", DATA) + , ("let",LET), ("in",IN) ] + <|> do { char '`'; v <- variable; char '`'; return $ OP v } + <|> anyOp + <|> do { char '"'; s <- many $ backslashed <|> satisfy (/='"'); char '"' + ; return $ STRING s} + <|> do { char '\''; c <- backslashed <|> satisfy (/='\''); char '\'' + ; return $ CHAR c} + <|> do { variable >>= return . ID } + <|> typeVar + <|> do { try $ string "\r\n" <|> string "\n"; return NEWLINE } + +str s t = do { try $ string s; return t } +chrs = choice . map (uncurry chr) +chr c t = do { char c; return t } +reserveds = choice . map (uncurry reserved) +reserved str token = + try $ do {string str; notFollowedBy $ alphaNum <|> char '_'; return token } +anyOp = do op <- many1 (satisfy isSymbol <|> oneOf "+-/*=.$<>:&|^?%#@~!") + case op of { ".." -> return DOT2 + ; "->" -> return ARROW; "\8594" -> return ARROW + ; _ -> return $ OP op } + +backslashed = do { char '\\'; c <- satisfy (\x -> True) + ; return . read $ ['\'','\\',c,'\''] } + +integer = return . read =<< many1 digit +variable = do + shd <- letter <|> char '_' + stl <- many $ alphaNum <|> char '_' <|> char '\'' + return $ shd:stl +typeVar = do + shd <- upper + stl <- many $ alphaNum <|> char '_' <|> char '\'' + return . TYPE $ shd:stl + + +---- White Space and comments ---- + +whitespace = (lineComment >> return NEWLINE) <|> + (many1 (multiComment <|> many1 (char ' ')) >> return SPACES) +lineComment = do try $ string "--" + manyTill anyChar $ newline <|> (eof >> return '\n') + +multiComment = do { try $ string "{-"; closeComment } +closeComment = manyTill anyChar . choice $ + [ try $ string "-}" + , do { try $ string "{-"; closeComment; closeComment } + ] + +token_parser = many1 token + +tokenize s = case parse token_parser "" s of + Right ts -> Right ts + Left err -> Left $ "Syntax error: " ++ show err
+ src/Parse/ParsePatterns.hs view
@@ -0,0 +1,30 @@+module ParsePatterns (pattern_term, pattern_expr) where++import Ast+import Combinators+import Data.Char (isUpper)+import ParserLib+import Tokens++pattern_basic =+ (t UNDERSCORE >> return PAnything) +|++ (do { x@(c:_) <- var ;+ if isUpper c then star pattern_term >>= return . PData x+ else return $ PVar x })++pattern_tuple = do+ t LPAREN; ps <- sepBy1 (t COMMA) pattern_expr; t RPAREN+ return $ case ps of { [p] -> p; _ -> ptuple ps }++pattern_cons = do+ p <- pattern_term+ colon <- optional $ op_parser (==":")+ case colon of+ Just ":" -> pattern_expr >>= return . pcons p+ Nothing -> return p++pattern_list = do+ t LBRACKET; ps <- sepBy (t COMMA) pattern_expr; t RBRACKET; return (plist ps)++pattern_term = pattern_tuple +|+ pattern_list +|+ pattern_basic+pattern_expr = pattern_tuple +|+ pattern_list +|+ pattern_cons
+ src/Parse/ParseTypes.hs view
@@ -0,0 +1,56 @@+module ParseTypes where + +import Ast +import Combinators +import Data.Char (isUpper) +import ParserLib +import Tokens +import Types + +type_var = do whitespace; t <- item + case t of + ID "Int" -> return IntT + ID "String" -> return StringT + ID "Char" -> return CharT + ID "Bool" -> return BoolT + ID (v:vs) -> return (if isUpper v then ADT (v:vs) [] + else VarT (v:vs)) + _ -> zero + +type_list = do t LBRACKET; ti <- type_expr; t RBRACKET; return $ ADT "List" [] +type_tuple = do { t LPAREN; ts <- sepBy (t COMMA) type_expr; t RPAREN + ; return $ case ts of { [t] -> t; _ -> ADT "Tuple" [] } } + +type_unamb = type_list +|+ type_tuple + +type_term = type_app +|+ type_unamb + +type_app = do + tipe <- type_var + case tipe of + ADT name _ -> star type_term >>= return . AppT name + _ -> return tipe + +type_expr = do t1 <- type_term + arrow <- optional $ t ARROW + case arrow of + Just ARROW -> type_term >>= return . LambdaT t1 + Nothing -> return t1 + +type_constr = do + name <- cap_var + args <- star (type_var +|+ type_unamb) + return (Constructor name args) + +constr (Constructor name args) = + (name, foldr Lambda (Data name (map Var argNames)) argNames) + where argNames = map (("arg"++) . show) [1..length args] + +datatype = do + t DATA + adt <- cap_var + vs <- star var + assign + ts <- sepBy1 (op_parser (=="|")) type_constr + -- (adt, foldr ForallT (ADT adt ts) vs) + return (map constr ts)
+ src/Parse/Parser.hs view
@@ -0,0 +1,116 @@+module Parser where + +import Ast +import Binop (binops) +import Combinators +import Data.List (foldl') +import Lexer +import ParserLib +import ParseTypes (datatype) +import ParsePatterns +import Tokens + +-------- Basic Terms -------- + +num_term = do { whitespace; t <- item + ; case t of { NUMBER n -> return $ Number n; _ -> zero } } +str_term = do { whitespace; t <- item + ; case t of { STRING cs -> return . list $ map Chr cs + ; _ -> zero } } + +var_term = do var >>= return . Var +chr_term = do chr >>= return . Chr + +true_term = do { t TRUE; return $ Boolean True } +false_term = do { t FALSE; return $ Boolean False } + + +-------- Complex Terms -------- + +list_term = (do { t LBRACKET; start <- expr; t DOT2; end <- expr; t RBRACKET + ; return $ Range start end }) +|+ + (do { t LBRACKET; es <- sepBy (t COMMA) expr; t RBRACKET + ; return $ list es }) + +parens_term = (do { t LPAREN; op <- anyOp; t RPAREN + ; return . Lambda "x" . Lambda "y" $ + Binop op (Var "x") (Var "y") }) +|+ + (do { t LPAREN; es <- sepBy (t COMMA) expr; t RPAREN + ; return $ case es of { [e] -> e; _ -> tuple es } }) + +term = select [ num_term + , str_term + , accessible var_term + , chr_term + , true_term + , false_term + , list_term + , accessible parens_term + ] + +-------- Applications -------- + +app_expr = do + tlist <- plus term + return $ case tlist of + t:[] -> t + t:ts -> foldl' App t ts + + +-------- Expressions with infix operators -------- + +binary_expr = binops app_expr anyOp + + +-------- Normal Expressions -------- + +if_expr = do { t IF; e1 <- expr; t THEN; e2 <- expr; t ELSE; e3 <- expr + ; return $ If e1 e2 e3 } + +lambda_expr = do { t LAMBDA; vs <- plus var; t ARROW; e <- expr + ; return $ foldr (\x e -> Lambda x e) e vs } + +assign_expr = whitespace >> assign_expr_nospace +assign_expr_nospace = do + p:ps <- plus pattern_term; assign; e <- expr + case p:ps of + PVar x : _ -> return (x, foldr func e ps) + where func PAnything e' = Lambda "_" e' + func (PVar x) e' = Lambda x e' + func p' e' = Lambda "_temp" (Case (Var "_temp") [(p', e')]) +-- _ : [] -> return $ \hole -> Case e [(p,hole)] + _ -> zero + +let_expr = do + t LET; brace <- optional $ t LBRACE + case brace of + Nothing -> do f <- assign_expr; t IN; e <- expr; return (Let [f] e) + Just LBRACE -> do fs <- sepBy1 (t SEMI) assign_expr; t RBRACE; t IN; + e <- expr; return (Let fs e) + +case_expr = do + t CASE; e <- expr; t OF; t LBRACE + cases <- sepBy1 (t SEMI) + (do { p <- pattern_expr; t ARROW; e <- expr; return (p,e) }) + t RBRACE + return $ Case e cases + +-------- All Expressions -------- + +expr = select [ let_expr + , binary_expr + , if_expr + , case_expr + , lambda_expr + ] + +def = assign_expr_nospace >>= return . (:[]) + +defs = do + ds <- plus (whitespace >> plus (sat (==NEWLINE)) >> def +|+ datatype) + star $ sat (==NEWLINE) +|+ sat (==SPACES) + return $ Let (concat ds) (Var "main") + +err = "Parse Error: Better error messages to come!" +toExpr = extractResult err . parse expr +toDefs = extractResult err . parse defs . (NEWLINE:)
+ src/Parse/ParserLib.hs view
@@ -0,0 +1,36 @@+module ParserLib where + +import Ast +import Combinators +import Data.Char (isUpper) +import Tokens + +var_noSpace = do { t <- item; case t of { ID v -> return v; _ -> zero } } +var = whitespace >> var_noSpace +cap_var = do + whitespace; t <- item + case t of { ID (v:vs) -> if isUpper v then return (v:vs) else zero } + +chr = do { whitespace; t <- item; case t of { CHAR c -> return c; _ -> zero } } + +t_noSpace token = sat (==token) +t_withSpace token = forcedWS >> sat (==token) +t token = whitespace >> sat (==token) + +forcedWS = do { sat (==SPACES); star nl_space } +|+ plus nl_space + where nl_space = plus (sat (==NEWLINE)) >> sat (==SPACES) +whitespace = optional forcedWS + +accessible exp = do + e <- exp + access <- optional $ op_parser_nospace (==".") + case access of + Just "." -> accessible (var >>= return . Access e) + Nothing -> return e + +op_parser_nospace pred = + do { t <- item + ; case t of { OP op -> if pred op then return op else zero; _ -> zero } } +op_parser pred = whitespace >> op_parser_nospace pred +anyOp = op_parser (const True) +assign = op_parser (=="=")
+ src/Parse/Tokens.hs view
@@ -0,0 +1,17 @@+ +module Tokens where + +data Token = + NUMBER Int | ID String | TYPE String | + CHAR Char | STRING String | + LAMBDA | ARROW | OP String | DOT2 | UNDERSCORE | + LPAREN | RPAREN | + LBRACE | RBRACE | + LBRACKET | RBRACKET | + COMMA | SEMI | + TRUE | FALSE | + IF | THEN | ELSE | + CASE | OF | LET | IN | + SPACES | NEWLINE | DATA + deriving (Show, Eq) +
+ src/Rename.hs view
@@ -0,0 +1,73 @@+module Rename (rename) where + +import Ast +import Control.Arrow (first) +import Control.Monad.State +import Data.Char (isLower) +import Data.List (mapAccumL) +import Data.Functor.Identity + +rename expr = evalState (rename' id expr) 0 + +guid :: State Int Int +guid = do n <- get + put (n+1) + return n + +rename' env expr = + case expr of + Range e1 e2 -> do + re1 <- rename' env e1; re2 <- rename' env e2 + return $ Range re1 re2 + Access e x -> do + re <- rename' env e + return $ Access re x + Binop op e1 e2 -> + do let rop = if isLower (head op) || '_' == head op then env op else op + re1 <- rename' env e1; re2 <- rename' env e2 + return $ Binop rop re1 re2 + Lambda x e -> do (rx, env') <- extend env x + rename' env' e >>= return . Lambda rx + App e1 e2 -> do + re1 <- rename' env e1; re2 <- rename' env e2 + return $ App re1 re2 + If e1 e2 e3 -> do + re1 <- rename' env e1; re2 <- rename' env e2; re3 <- rename' env e3 + return $ If re1 re2 re3 + Lift e es -> do + re <- rename' env e + mapM (rename' env) es >>= return . Lift re + Fold e1 e2 e3 -> do + re1 <- rename' env e1; re2 <- rename' env e2; re3 <- rename' env e3 + return $ Fold re1 re2 re3 + Async e -> rename' env e >>= return . Async + Let defs e -> do + let (vs,es) = unzip defs + env' <- foldM (\acc x -> extend acc x >>= return . snd) env vs + es' <- mapM (rename' env') es; re <- rename' env' e + return $ Let (zip (map env' vs) es') re + Var x -> return . Var $ env x + Data name es -> mapM (rename' env) es >>= return . Data name + Case e cases -> do + re <- rename' env e + mapM (pattern_rename env) cases >>= return . (Case re) + _ -> return expr + +extend env x = do + n <- guid + let rx = x ++ "_" ++ show n + return (rx, (\y -> if y == x then rx else env y)) + +pattern_extend pattern env = + case pattern of + PAnything -> return (PAnything, env) + PVar x -> extend env x >>= return . first PVar + PData name ps -> + foldM f ([],env) ps >>= return . first (PData name . reverse) + where f (rps,env') p = do (rp,env'') <- pattern_extend p env' + return (rp:rps, env'') + +pattern_rename env (p,e) = do + (rp,env') <- pattern_extend p env + re <- rename' env' e + return (rp,re)
+ src/Replace.hs view
@@ -0,0 +1,50 @@+module Replace (replace, depth) where + +import Ast +import Data.Set (singleton,empty,unions,member) + +replace y v expr = + let f = replace y v in + case expr of + Range e1 e2 -> Range (f e1) (f e2) + Access e x -> Access (f e) x + Binop op e1 e2 -> Binop op (f e1) (f e2) + App e1 e2 -> App (f e1) (f e2) + If e1 e2 e3 -> If (f e1) (f e2) (f e3) + Lift e es -> Lift (f e) (map f es) + Fold e1 e2 e3 -> Fold (f e1) (f e2) (f e3) + Async e -> Async (f e) + Let defs e -> if elem y vs then Let defs e else Let (zip vs (map f es)) (f e) + where (vs,es) = unzip defs + Var x -> if x == y then v else Var x + Data name es -> Data name (map f es) + Case e cases -> Case (f e) $ map (case_replace y v) cases + _ -> expr + +case_replace y v (p,e) = + if member y (pattern_vars p) then (p,e) else (p, replace y v e) + +pattern_vars pattern = + case pattern of + PData _ ps -> unions (map pattern_vars ps) + PVar x -> singleton x + PAnything -> empty + +depth = depth' 0 +depth' d expr = + let f = depth' (d+1) in + case expr of + Range e1 e2 -> max (f e1) (f e2) + Access e x -> f e + Binop op e1 e2 -> max (f e1) (f e2) + Lambda x e -> f e + App e1 e2 -> max (f e1) (f e2) + If e1 e2 e3 -> maximum [f e1, f e2, f e3] + Lift e es -> maximum $ f e : map f es + Fold e1 e2 e3 -> maximum [f e1, f e2, f e3] + Async e -> f e + Let defs e -> let (_,es) = unzip defs in maximum $ f e : map f es + Data "Cons" es -> maximum $ map (depth' d) es + Data name es -> maximum $ 1 : map f es + Case e cases -> maximum $ f e : map (f . snd) cases + _ -> d
+ src/Server.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE OverloadedStrings #-}+module Main where++import Prelude hiding (head,span,id)+import Control.Monad (msum,guard)+import Control.Monad.Trans (MonadIO(liftIO))+import Data.List (isPrefixOf, isSuffixOf)+import Happstack.Server hiding (body)+import Happstack.Server.Compression+import System.Environment+import Text.Blaze.Html5 hiding (map)+import Text.Blaze.Html5.Attributes hiding (title,span,dir,style)+import Text.Blaze.Internal+import ToHtml++serve :: String -> IO ()+serve libLoc = do+ putStrLn "Elm Server 0.1.0: running at <http://localhost:8000>"+ simpleHTTP nullConf $ do+ compressedResponseFilter+ msum [ uriRest (serveElm libLoc)+ , serveDirectory EnableBrowsing [] "."+ ]++serveElm libLoc fp = do+ let ('/':path) = fp+ guard (".elm" `isSuffixOf` path)+ content <- liftIO (readFile path)+ ok . toResponse $ compileToHtml libLoc path content+++main = getArgs >>= parse++parse ("--help":_) = putStrLn usage+parse ("--version":_) = putStrLn "The Elm Server 0.1.0"+parse [] = serve "/elm-mini.js"+parse [arg]+ | "--runtime-location=" `isPrefixOf` arg =+ serve . tail $ dropWhile (/='=') arg+ | otherwise = putStrLn usageMini+parse _ = putStrLn usageMini++usageMini =+ "Usage: elm-server [OPTIONS]\n\+ \Try `elm-server --help' for more information."++usage =+ "Usage: elm-server [OPTIONS]\n\+ \Compiles and serves .elm files from the current directory.\n\+ \Example: elm-server\n\+ \\n\+ \Resource Locations:\n\+ \ --runtime-location set the location of the Elm runtime (elm-mini.js)\n\+ \\n\+ \Compiler Information:\n\+ \ --version print the version information and exit\n\+ \ --help display this help and exit\n\+ \\n\+ \Elm home page: <http://elm-lang.org>"
+ src/ToHtml.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE OverloadedStrings #-} +module ToHtml (compileToHtml) where + +import CompileToJS +import Data.Monoid (mempty) +import GenerateHtml +import Network.HTTP.Base (urlEncode) +import Text.Blaze.Html5 hiding (map) +import qualified Text.Blaze.Html5 as H +import Text.Blaze.Html5.Attributes +import qualified Text.Blaze.Html5.Attributes as A + +pageTitle fp = + reverse . takeWhile (/='/') . drop 1 . dropWhile (/='.') $ reverse fp + + +compileToHtml :: String -> String -> String -> Html +compileToHtml libLoc fileName source = + generateHtml libLoc (pageTitle fileName) (compileToJS source)
+ src/Types/Types.hs view
@@ -0,0 +1,34 @@+ +module Types where + +import Data.List (intercalate) +import Data.IORef +import System.IO.Unsafe + +data Type = IntT + | StringT + | CharT + | BoolT + | LambdaT Type Type + | VarT String + | ForallT String Type + | AppT String [Type] + | ADT String [Type] + deriving (Eq) + +data Constructor = Constructor String [Type] deriving (Eq, Show) + +instance Show Type where + show t = + case t of + { IntT -> "Int" + ; StringT -> "String" + ; CharT -> "Char" + ; BoolT -> "Bool" + ; LambdaT t1 t2 -> show t1 ++ " -> " ++ show t2 + ; VarT x -> x + ; ForallT x t' -> "forall " ++ x ++ ". " ++ show t' + ; AppT name args -> name ++ " " ++ intercalate " " (map show args) + ; ADT name constrs -> + name ++ " = " ++ intercalate " | " (map show constrs) + }