Elm 0.2.0.1 → 0.3.0
raw patch · 21 files changed
+1090/−773 lines, 21 filesdep +cmdargsPVP ok
version bump matches the API change (PVP)
Dependencies added: cmdargs
API changes (from Hackage documentation)
Files
- Elm.cabal +13/−5
- changelog.txt +34/−0
- elm-runtime-0.3.0.js +54/−0
- src/Ast.hs +12/−0
- src/CompileToJS.hs +0/−96
- src/Compiler.hs +88/−39
- src/ExtractNoscript.hs +0/−26
- src/Gen/CompileToJS.hs +145/−0
- src/Gen/ExtractNoscript.hs +35/−0
- src/Gen/GenerateHtml.hs +79/−0
- src/GenerateHtml.hs +0/−59
- src/Initialize.hs +12/−94
- src/Language/Elm.hs +3/−3
- src/Optimize.hs +84/−0
- src/Parse/Binops.hs +68/−69
- src/Parse/ParseExpr.hs +121/−0
- src/Parse/ParseLib.hs +141/−135
- src/Parse/ParseModules.hs +44/−0
- src/Parse/ParseTypes.hs +83/−83
- src/Parse/Parser.hs +21/−111
- src/Parse/Patterns.hs +53/−53
Elm.cabal view
@@ -1,6 +1,6 @@ Name: Elm-Version: 0.2.0.1+Version: 0.3.0 Synopsis: The Elm language module. Description: Elm aims to make client-side web-development more pleasant. It is a statically/strongly typed, functional reactive@@ -21,7 +21,8 @@ Build-type: Simple ---Extra-source-files: README.md+Extra-source-files: changelog.txt+Data-files: elm-runtime-0.3.0.js Cabal-version: >=1.8 source-repository head@@ -31,19 +32,22 @@ Library exposed-modules: Language.Elm, Language.Elm.Quasi- Hs-Source-Dirs: src, src/Parse, src/Types+ Hs-Source-Dirs: src, src/Parse, src/Types, src/Gen other-modules: Ast, CompileToJS, ExtractNoscript, GenerateHtml, Guid,+ Optimize, Initialize, Rename, Binops, Patterns, Parser, ParseLib,+ ParseExpr, ParseTypes,+ ParseModules, Types, Constrain, Hints,@@ -64,19 +68,22 @@ Executable elm Main-is: Compiler.hs- Hs-Source-Dirs: src, src/Parse, src/Types+ Hs-Source-Dirs: src, src/Parse, src/Types, src/Gen other-modules: Ast, CompileToJS, ExtractNoscript, GenerateHtml, Guid,+ Optimize, Initialize, Rename, Binops, Patterns, Parser, ParseLib,+ ParseExpr, ParseTypes,+ ParseModules, Types, Constrain, Hints,@@ -90,4 +97,5 @@ parsec >= 3.1.1, blaze-html == 0.5.0.*, blaze-markup == 0.5.1.*,- deepseq+ deepseq,+ cmdargs
+ changelog.txt view
@@ -0,0 +1,34 @@+Release 0.3.0 +============= + +Major Changes (Read this part!) +------------------------------- + +* Add a basic module system. +* Elm's JavaScript runtime is now distributed with the elm package. + Previously it was available for download as an unversioned JavaScript + file (elm-mini.js). It is now installed with the elm compiler as + elm-runtime-0.3.0.js. Be sure to serve the Elm runtime system that matches + the version of the compiler used to generate JavaScript. When working + locally, the compiler will automatically use your local copy of this file. +* BREAKING CHANGE: rgb and rgba (in the color module) now take their red, + green, and blue components as integers between 0 and 255 inclusive. +* Improve error messages for parse errors and runtime errors. + + +New Functions and Other Additions +--------------------------------- + +* Add support for keyboard events: Keyboard.Raw +* Add buttons in Signal.Input: + button :: String -> (Element, Signal Bool) +* Add new basic element (an empty rectangle, good for adding spaces): + rectangle :: Int -> Int -> Element +* Add (an awkwardly named) way to display right justified text: rightedText +* Add two basic libraries: Data.Char and Data.Maybe +* Add some new colors: magenta, yellow, cyan, gray, grey +* Add functions to Data.List module: take, drop +* Add functions to Prelude (the default imports): + fst, snd, curry, uncurry, and a bunch of list functions +* Add --make, --separate-js, and --only-js flags to help compile + with the new module system.
+ elm-runtime-0.3.0.js view
@@ -0,0 +1,54 @@+var Guid=function(){var f=0;return{guid:function(){return f+=1}}}(),Value=function(){var f=function(a){a.replace('"',""");a.replace("&","&");a.replace("'","'");a.replace("<","<");a.replace(">",">");return a},b=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 c="",g=a.length;--g;)c=","+b(a[g])+c;","===c[0]&&(c=c.substring(1));return"("+c+")"}if("Cons"===a[0])for(var g="string"===typeof a[1]?'"':"]",+h="string"===typeof a[1]?"":",",c=("string"===typeof a[1]?'"':"[")+b(a[1]),a=a[2];;)if("Cons"===a[0])c+=h+b(a[1]),a=a[2];else return c+g;else{if("Nil"===a[0])return"[]";c="";for(g=a.length;--g;)c=" "+b(a[g])+c;c=a[0]+c;return 1<a.length?"("+c+")":c}}return a+""};return{show:function(a){return Text.monospace(f(b(a)))},Tuple:function(){var a=arguments.length,c=Array(a+1);for(c[0]="Tuple"+arguments.length;a--;)c[a+1]=arguments[a];return c},append:function(a,c){if("string"===typeof a&&"string"===typeof c)return a.concat(c);+if("Nil"===a[0])return c;for(var b=["Cons",a[1],["Nil"]],h=b,a=a[2];"Cons"===a[0];)h[2]=["Cons",a[1],["Nil"]],a=a[2],h=h[2];h[2]=c;return b},toText:function(a){if("string"===typeof a)return a;for(var b=[];"Cons"===a[0];)b.push(a[1]),a=a[2];return f(b.join(""))},properEscape:f}}(),List=function(){function f(a){return function(e){if("Nil"===e[0])return e;"Cons"!==e[0]&&i("map");for(var d=["Cons",a(e[1]),["Nil"]],b=d,e=e[2];"Cons"===e[0];)b[2]=["Cons",a(e[1]),["Nil"]],e=e[2],b=b[2];return d}}function b(e){return function(a){return function(d){var b=+a;if("Nil"===d[0])return b;for("Cons"!==d[0]&&i("foldl");"Cons"===d[0];)b=e(d[1])(b),d=d[2];return b}}}function a(e){return function(a){return function(d){var b=a;if("Nil"===d[0])return b;"Cons"!==d[0]&&i("foldr");for(var c=[];"Cons"===d[0];)c.push(d[1]),d=d[2];for(d=c.length;d--;)b=e(c[d])(b);return b}}}function c(e){return function(a){var d;"Cons"!==a[0]?d=void 0:(d=a[1],a=a[2],d=b(e)(d)(a));return d}}function g(a){return function(e){return function(d){if("Nil"===d[0])return["Cons",e,["Nil"]];"Cons"!==+d[0]&&i("scanl");for(var b=[e];"Cons"===d[0];)e=a(d[1])(e),b.push(e),d=d[2];for(var d=["Nil"],c=b.length;c--;)d=["Cons",b[c],d];return d}}}function h(e){return function(a){return function(){for(var d=[function(e){return"Nil"!==e[0]?void 0:["Tuple2",["Nil"],["Nil"]]},function(a){if("Cons"===a[0]){var d=a[1],a=a[2];var b=h(e)(a);"Tuple2"!==b[0]?d=void 0:(a=b[1],b=b[2],d=e(d)?["Tuple2",["Cons",d,a],b]:["Tuple2",a,["Cons",d,b]]);return d}}],b=d.length;b--;){var c=d[b](a);if(void 0!==c)return c}}()}}function j(a){return function(){for(var e=+[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],j(a[2])],"Tuple2"!==a[0]||"Tuple2"!==a[1][0])a=void 0;else var e=a[1][1],d=a[1][2],a="Tuple2"!==a[2][0]?void 0:["Tuple2",["Cons",e,a[2][1]],["Cons",d,a[2][2]]];return a}],d=e.length;d--;){var b=e[d](a);if(void 0!==b)return b}}()}function l(a){return function(e){return function(){for(var d=[function(a){return"Nil"!==a[0]?void 0:["Nil"]},function(a){if("Cons"===a[0]){var e=+a[1];return"Nil"!==a[2][0]?void 0:["Cons",e,["Nil"]]}},function(e){if("Cons"===e[0]){var d=e[1];if("Cons"===e[2][0]){var b=e[2][1],e=e[2][2];return["Cons",d,["Cons",a,l(a)(["Cons",b,e])]]}}}],b=d.length;b--;){var c=d[b](e);if(void 0!==c)return c}}()}}function o(a){return function(e){return function(){for(var d=[function(a){return"Nil"!==a[0]?void 0:["Nil"]},function(a){if("Cons"===a[0]){var e=a[1];return"Nil"!==a[2][0]?void 0:e}},function(e){if("Cons"===e[0]){var d=e[1];if("Cons"===e[2][0]){var b=+e[2][1],e=e[2][2];return Value.append(d,Value.append(a,o(a)(["Cons",b,e])))}}}],b=d.length;b--;){var c=d[b](e);if(void 0!==c)return c}}()}}var i=function(a){throw"Function '"+a+"' expecting a list!";},k=b(function(a){return function(e){return["Cons",a,e]}})(["Nil"]),m=a(function(a){return function(e){return Value.append(a,e)}})(["Nil"]),n=b(function(a){return function(e){return a&&e}})(!0),e=b(function(a){return function(e){return a||e}})(!1),d=b(function(a){return function(e){return a+e}})(0),p=+b(function(a){return function(e){return a*e}})(1),r=c(function(a){return function(e){return Math.max(a,e)}}),t=c(function(a){return function(e){return Math.min(a,e)}});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:f,foldl:b,foldr:a,foldl1:c,foldr1:function(e){return function(d){var b;"Cons"!==d[0]?b=void 0:+(b=d[1],d=d[2],b=a(e)(b)(d));return b}},scanl:g,scanl1:function(a){return function(e){if("Cons"!==e[0])throw"Error: 'scanl1' requires a list of at least length 1.";return g(a)(e[1])(e[2])}},filter:function(a){return function(e){if("Nil"===e[0])return e;"Cons"!==e[0]&&i("filter");for(var d=[];"Cons"===e[0];)a(e[1])&&d.push(e[1]),e=e[2];for(var e=["Nil"],b=d.length;b--;)e=["Cons",d[b],e];return e}},length:function(a){for(var e=0;"Cons"===a[0];)e+=1,a=a[2];return e},reverse:k,concat:m,concatMap:function(a){return function(e){return m(f(a)(e))}},+and:n,or:e,forall:function(a){return b(function(e){return function(d){return d&&a(e)}})(!0)},exists:function(a){return b(function(e){return function(d){return d||a(e)}})(!1)},sum:d,product:p,maximum:r,minimum:t,partition:h,zipWith:function(a){return function(e){return function(d){if("Nil"===e[0]||"Nil"===d[0])return["Nil"];("Cons"!==e[0]||"Cons"!==d[0])&&i("zipWith");for(var b=[];"Cons"===e[0]&&"Cons"===d[0];)b.push(a(e[1])(d[1])),e=e[2],d=d[2];for(var d=["Nil"],c=b.length;c--;)d=["Cons",b[c],d];+return d}}},zip:function(a){return function(e){if("Nil"===a[0]||"Nil"===e[0])return["Nil"];("Cons"!==a[0]||"Cons"!==e[0])&&i("zip");for(var d=[];"Cons"===a[0]&&"Cons"===e[0];)d.push(["Tuple2",a[1],e[1]]),a=a[2],e=e[2];for(var e=["Nil"],b=d.length;b--;)e=["Cons",d[b],e];return e}},unzip:j,intersperse:l,intercalate:o,sort:function(e){if("Nil"===e[0])return e;"Cons"!==e[0]&&i("sort");for(var a=[];"Cons"===e[0];)a.push(e[1]),e=e[2];a.sort(function(e,a){return e-a});for(var e=["Nil"],d=a.length;d--;)e=+["Cons",a[d],e];return e},take:function(e){return function(a){if(0>=e)return["Nil"];if("Nil"===a[0])return a;"Cons"!==a[0]&&i("take");var d=["Cons",a[1],["Nil"]],b=d,a=a[2];for(--e;"Cons"===a[0]&&0<e;)b[2]=["Cons",a[1],["Nil"]],b=b[2],a=a[2],--e;return d}},drop:function(e){return function(a){if("Nil"===a[0])return a;for("Cons"!==a[0]&&i("drop");"Cons"===a[0]&&0<e;)a=a[2],--e;return a}}}}(),Data=function(){var f=function(){return{fromCode:function(a){return String.fromCharCode(a)},toCode:function(a){return a.charCodeAt(0)},+toUpper:function(a){return a.toUpperCase()},toLower:function(a){return a.toLowerCase()},toLocaleUpper:function(a){return a.toLocaleUpperCase()},toLocaleLower:function(a){return a.toLocaleLowerCase()}}}(),b=function(){function a(a){return function(b){return"Just"===a[0]?["Cons",a[1],b]:b}}function b(a){return function(){return function(b){var c=a(c);return"Just"===c[0]?["Cons",c[1],b]:b}}}return{Just:function(a){return["Just",a]},Nothing:["Nothing"],catMaybes:List.foldr(a)(["Nil"]),isJust:function(a){return"Just"===+a[0]},isNothing:function(a){return"Nothing"===a[0]},fromMaybe:function(a){return function(b){return"Just"===b[0]?b[1]:a}},consMaybe:a,mapMaybe:function(a){return List.foldr(b(a))(["Nil"])},maybe:function(a){return function(b){return function(c){return"Just"===c[0]?b(c[1]):a}}}}}();return{String:{toText:Value.toText,properEscape:Value.properEscape},Char:f,Maybe:b,List:List}}(),Color=function(){var f=function(b,a,c,f){return{r:b,g:a,b:c,a:f}};return{black:f(0,0,0,1),white:f(255,255,255,1),red:f(255,+0,0,1),green:f(0,255,0,1),blue:f(0,0,255,1),gray:f(128,128,128,1),grey:f(128,128,128,1),yellow:f(255,255,0,1),cyan:f(0,255,255,1),magenta:f(255,0,255,1),rgba:function(b){return function(a){return function(c){return function(g){return f(b,a,c,g)}}}},rgb:function(b){return function(a){return function(c){return f(b,a,c,1)}}},Internal:{extract:function(b){return 1===b.a?"rgb("+b.r+","+b.g+","+b.b+")":"rgba("+b.r+","+b.g+","+b.b+","+b.a+")"}}}}(),Element=function(){var f=function(a){a=document.createElement(a);+a.id=Guid.guid();return a},b=function(a){var d=f("div");d.appendChild(a);return d},a=function(a){return function(d){return function(b){var c=f("div");c.isElmLeaf=!0;c.isElmText=!0;c.innerHTML=b;c.style.textAlign=d;0<a&&(c.style.width=a+"px");return c}}},c=a(0)("left"),g=a(0)("justify"),h=a(0)("center"),j=a(0)("right"),l=function(a){return"DIV"===a.tagName?a:b(a)},o=function(a){a.style.styleFloat="left";a.style.cssFloat="left";return a},i=function(a){a.style.position="absolute";return a},k=function(a,+d,b){for(var c=f("div"),i=b.length;i--;){var h=d(b[i]);c.appendChild(h)}c.elmFlowDirection=a;return c},m=function(a){return function(d){for(var b=[];"Cons"===d[0];)b.push(d[1]),d=d[2];3<=a&&b.reverse();d=a%3;if(0==d)return k("Y",l,b);if(1==d)return k("X",o,b);if(2==d)return k("Z",i,b)}},n=function(e){return function(d){if("A"===d.tagName)return n(e)(d.firstChild),d;if(d.hasOwnProperty("isElmText")){var b=a(e)(d.style.textAlign)(d.innerHTML);d.style.height=b.style.height}d.style.width=e+"px";return d}};+return{text:c,image:function(a){var d=f("img");d.isElmLeaf=!0;d.onload=function(){""===d.style.width&&0<this.width&&(d.style.width=d.width=this.width+"px");""===d.style.height&&0<this.height&&(d.style.height=d.height=this.height+"px");Dispatcher.adjust()};d.src=Data.String.toText(a);d.name=d.src;return d},fittedImage:function(a){return function(d){return function(b){var c=f("canvas");c.style.width=a+"px";c.style.height=d+"px";c.width=a;c.height=d;c.innerHTML="Your browser does not support the canvas element.";+c.isElmLeaf=!0;var i=f("img");i.onload=function(){if(c.getContext){var b=c.getContext("2d"),h=0,f=0,g=this.width,k=this.height;a/d>this.width/this.height?(k=this.width*d/a,f=(this.height-k)/2):(g=this.height*a/d,h=(this.width-g)/2);b.drawImage(i,h,f,g,k,0,0,c.width,c.height)}};i.src=Data.String.toText(b);return c}}},video:function(a){var a=Data.String.toText(a),d=f("video");d.controls="controls";var b=f("source");b.src=a;b.type="video/"+a.substring(a.length-3,a.length);d.appendChild(b);d.isElmLeaf=+!0;return d},audio:function(a){var a=Data.String.toString(a),d=f("video");d.controls="controls";var b=f("source");b.src=a;b.type="audio/"+a.substring(a.length-3,a.length);d.appendChild(b);d.isElmLeaf=!0;return d},collage:function(a){return function(d){return function(b){var c=f("canvas");c.style.width=a+"px";c.style.height=d+"px";c.width=a;c.height=d;if(c.getContext){var i=c.getContext("2d");for(i.clearRect(0,0,c.width,c.height);"Cons"===b[0];)i=b[1](i),b=b[2];return c}c.innerHTML="Your browser does not support the canvas element.";+c.isElmLeaf=!0;return c}}},flow:m,layers:m(2),rectangle:function(a){return function(d){var b=f("div");b.isElmLeaf=!0;b.style.width=a+"px";b.style.height=d+"px";return b}},beside:function(a){return function(d){return m(4)(["Cons",a,["Cons",d,["Nil"]]])}},above:function(a){return function(d){return m(3)(["Cons",a,["Cons",d,["Nil"]]])}},below:function(a){return function(d){return m(0)(["Cons",a,["Cons",d,["Nil"]]])}},box:function(a){return function(d){d.style.position="absolute";d.style.margin="auto";+var b=(a-1)%3,c=(a-1)/3;2>b&&(d.style.left=0);0<b&&(d.style.right=0);2>c&&(d.style.top=0);0<c&&(d.style.bottom=0);b=f("div");b.style.position="relative";b.appendChild(d);return b}},width:n,height:function(a){return function(b){("A"===b.tagName?b.firstChild:b).style.height=a+"px";return b}},size:function(a){return function(b){return function(c){var i="A"===c.tagName?c.firstChild:c;i.style.width=a+"px";i.style.height=b+"px";return c}}},color:function(a){return function(b){b.style.backgroundColor=Color.Internal.extract(a);+return b}},opacity:function(a){return function(b){b.style.opacity=a;return b}},link:function(a){return function(d){var c=f("a");c.href=Text.fromString(a);c.appendChild(d);return b(c)}},asText:function(b){return a(0)("left")(Value.show(b))},plainText:function(b){return a(0)("left")(Data.String.toText(b))},justifiedText:g,centeredText:h,rightedText:j,up:0,left:1,inward:2,down:3,right:4,outward:5,correctTextSize:function(a){var b=a.style.width?a.style.width.slice(0,-2):0,c=f("div");c.innerHTML=a.innerHTML;+c.style.textAlign=a.style.textAlign;0<b&&(c.style.width=b+"px");c.style.visibility="hidden";c.style.styleFloat="left";c.style.cssFloat="left";document.body.appendChild(c);var i=window.getComputedStyle(c);0>=b&&(a.style.width=i.getPropertyValue("width"));a.style.height=i.getPropertyValue("height");document.body.removeChild(c)}}}(),Text=function(){var f=function(a){if("string"===typeof a)return a;for(var b=[];"Cons"===a[0];)b.push(a[1]),a=a[2];return Data.String.properEscape(b.join(""))},b=function(a){return function(b){return"<"++a+">"+b+"</"+a+">"}},a=function(a,b){return function(c){return"<span style='"+a+":"+b+"'>"+c+"</span>"}},c=b("h1"),g=a("font-style","italic"),b=b("b"),h=a("text-decoration","underline"),j=a("text-decoration","overline"),l=a("text-decoration","line-through");return{fromString:f,toText:f,header:c,height:function(b){return a("font-size",b+"em")},italic:g,bold:b,underline:h,overline:j,strikeThrough:l,monospace:a("font-family","monospace"),color:function(b){return a("color",Color.Internal.extract(b))},+link:function(a){return function(b){return"<a href='"+f(a)+"'>"+b+"</a>"}}}}(),Shape=function(){var f=function(a,b,f,h){return{center:a,points:b,theta:f,scale:h}},b=function(a){return function(b){return function(f){return function(h){h.save();h.translate(f.center[0],f.center[1]);h.rotate(f.theta);h.scale(f.scale,f.scale);h.beginPath();var j=f.points;h.moveTo(j[0][0],j[0][1]);for(var l=j.length;l--;)h.lineTo(j[l][0],j[l][1]);h.closePath();a?(h.fillStyle=Color.Internal.extract(b),h.fill()):(h.strokeStyle=+Color.Internal.extract(b),h.stroke());h.restore();return h}}}};return{polygon:function(a){return function(b){for(var g=[];"Cons"===a[0];)g.push([a[1][1],a[1][2]]),a=a[2];b=[b[1],b[2]];return f(b,g,0,1)}},ngon:function(a){return function(b){return function(g){for(var h=[],j=a;j--;)h.push([b*Math.cos(2*Math.PI*j/a),b*Math.sin(2*Math.PI*j/a)]);g=[g[1],g[2]];return f(g,h,0,1)}}},rect:function(a){return function(b){return function(g){var h=[[-a/2,-b/2],[a/2,-b/2],[a/2,b/2],[-a/2,b/2]],g=[g[1],g[2]];return f(g,+h,0,1)}}},oval:function(a){return function(b){return function(g){for(var h=[],j=2*Math.PI;0<j;j-=Math.PI/50)h.push([a/2*Math.cos(j),b/2*Math.sin(j)]);g=[g[1],g[2]];return f(g,h,0,1)}}},move:function(a){return function(b){return function(g){return f([a+g.center[0],b+g.center[1]],g.points,g.theta,g.scale)}}},rotate:function(a){return function(b){return f(b.center,b.points,b.theta+2*Math.PI*a,b.scale)}},scale:function(a){return function(b){return f(b.center,b.points,b.theta,b.scale*a)}},filled:b(!0),+outlined:b(!1),customOutline:function(a){return function(b){return function(f){f.points.push(f.points[0]);return Line.customLine(a)(b)(f)}}}}}(),Line=function(){var f=function(b){return function(a){return function(c){if("string"===typeof b[0]){for(var f=[];"Cons"===b[0];)f.push(b[1]),b=b[2];b=f}0===b.length&&(b=[8,4]);return function(f){f.save();f.beginPath();f.translate(c.center[0],c.center[1]);f.rotate(c.theta);f.scale(c.scale,c.scale);var g=b,l=c.points,o=l.length-1,i=l[o][0],k=l[o][1],m=0,n=0,+e=0,d=0,p=0,r=0,t=g.length,s=!0,q=g[0];for(f.moveTo(i,k);o--;){m=l[o][0];n=l[o][1];e=m-i;d=n-k;for(p=Math.sqrt(e*e+d*d);q<=p;)i+=e*q/p,k+=d*q/p,f[s?"lineTo":"moveTo"](i,k),e=m-i,d=n-k,p=Math.sqrt(e*e+d*d),s=!s,r=(r+1)%t,q=g[r];0<p&&(f[s?"lineTo":"moveTo"](m,n),q-=p);i=m;k=n}f.strokeStyle=Color.Internal.extract(a);f.stroke();f.restore();return f}}}};return{line:function(b){for(var a=[];"Cons"===b[0];)a.push([b[1][1],b[1][2]]),b=b[2];return{center:[0,0],points:a,theta:0,scale:1}},customLine:f,solid:function(b){return function(a){return function(c){c.save();+c.beginPath();c.translate(a.center[0],a.center[1]);c.rotate(a.theta);c.scale(a.scale,a.scale);var f=a.points,h=f.length;for(c.moveTo(f[h-1][0],f[h-1][1]);h--;)c.lineTo(f[h][0],f[h][1]);c.strokeStyle=Color.Internal.extract(b);c.stroke();c.restore();return c}}},dashed:f([8,4]),dotted:f([3,3])}}(),Elm=function(){var f=function(a,b,c){for(var f=a.length;f--;)a[f].recv(b,c)},b=function(a){this.id=Guid.guid();this.value=a;this.kids=[];this.recv=function(a,b,c){if(b=b===this.id)this.value=c;f(this.kids,+a,b)};Dispatcher.inputs.push(this)},a=function(a,b){this.id=Guid.guid();this.value=null;this.kids=[];this.inbox={};b.reverse();this.recalc=function(){for(var c=a,f=b.length;f--;)c=c(b[f].value);this.value=c};this.recalc();this.recv=function(a,c){this.inbox.hasOwnProperty(a)||(this.inbox[a]={changed:!1,count:0});var i=this.inbox[a];i.count+=1;c&&(i.changed=!0);i.count==b.length&&(i.changed&&this.recalc(),f(this.kids,a,i.changed),delete this.inbox[a])};for(var c=b.length;c--;)b[c].kids.push(this)},+c=function(a,b,c){this.id=Guid.guid();this.value=b;this.kids=[];this.recv=function(b,h){h&&(this.value=a(c.value)(this.value));f(this.kids,b,h)};c.kids.push(this)};return{Input:function(a){return new b(a)},Lift:function(b,c){return new a(b,c)},Fold:function(a,b,f){return new c(a,b,f)}}}(),Dispatcher=function(){var f=null,b=0,a=[],c=function(a){var b=a.childNodes,f=b.length;if(a.hasOwnProperty("isElmLeaf")){a.hasOwnProperty("isElmText")&&Element.correctTextSize(a);var b=""===a.style.width?0:a.style.width.slice(0,+-2)-0,g=""===a.style.height?0:a.style.height.slice(0,-2)-0;return[b,g]}if(1===f){var i=c(b[0]);""!==a.style.width&&(i[0]=a.style.width.slice(0,-2)-0);""!==a.style.height&&(i[1]=a.style.height.slice(0,-2)-0);0!==i[0]&&(a.style.width=i[0]+"px");0!==i[1]&&(a.style.height=i[1]+"px");return i}for(var k=0,m=g=0,n=0,e=!0,d=!0;f--;)i=c(b[f]),k=Math.max(k,i[0]),g=Math.max(g,i[1]),m+=i[0],n+=i[1],e=e&&0<i[0],d=d&&0<i[1];b=k;f=a.elmFlowDirection;"X"===f&&(b=e?m:0);"Y"===f&&(g=d?n:0);0<b&&(a.style.width=b+"px");+0<g&&(a.style.height=g+"px");return[b,g]},g=function(){var a=document.getElementById("content");c(a.children[0])};return{initialize:function(){var a=ElmCode.hasOwnProperty("main")?ElmCode.main:main;try{f=a()}catch(b){throw b;}f.hasOwnProperty("recv")||(f=Elm.Input(f));document.getElementById("content").appendChild(f.value);g();a=document.getElementById("widthChecker").offsetWidth;a!==window.innerWidth&&Dispatcher.notify(Window.dimensions.id,Value.Tuple(a,window.innerHeight));f=Elm.Lift(function(a){var b=+document.getElementById("content"),c=b.children[0];b.replaceChild(a,c);delete c;g();return a},[f])},notify:function(c,f){b+=1;for(var g=a.length;g--;)a[g].recv(b,c,f)},adjust:g,inputs:a}}(),Signal=function(){function f(a){for(var b=["Nil"],c=a.length;c--;)b=["Cons",a[c],b];return b}var b=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 d=0,c=0;b||(b=window.event);if(b.pageX||b.pageY)d=+b.pageX,c=b.pageY;else if(b.clientX||b.clientY)d=b.clientX+document.body.scrollLeft+document.documentElement.scrollLeft,c=b.clientY+document.body.scrollTop+document.documentElement.scrollTop;return Value.Tuple(d,c)}var c=Elm.Input(Value.Tuple(0,0)),f=Elm.Input(!1),g=Elm.Input(!1);b(document,"click",function(){Dispatcher.notify(g.id,!0);Dispatcher.notify(g.id,!1)});b(document,"mousedown",function(){Dispatcher.notify(f.id,!0)});b(document,"mouseup",function(){Dispatcher.notify(f.id,!1)});b(document,+"mousemove",function(b){Dispatcher.notify(c.id,a(b))});return{position:c,x:Elm.Lift(function(a){return a[1]},[c]),y:Elm.Lift(function(a){return a[2]},[c]),isClicked:g,isDown:f,clickedOn:function(a){var d=Elm.Input(!1);b(a,"click",function(){Dispatcher.notify(d.id,!0);Dispatcher.notify(d.id,!1)});return Value.Tuple(a,d)}}}(),c=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}}}(),g=function(){var a=Elm.Input(Value.Tuple(window.innerWidth,window.innerHeight));b(window,"resize",function(){var b=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])}}(),h={Raw:function(){function a(b,c){return"Nil"===c[0]?c:c[1]===b?c[2]:["Cons",c[1],a(b,c[2])]}var c=Elm.Input(["Nil"]),f=Elm.Input(["Nothing"]);b(document,"keydown",function(a){var b;a:{for(b=c.value;"Nil"!==b[0];){if(b[1]===a.keyCode){b=!0;break a}b=b[2]}b=!1}b||Dispatcher.notify(c.id,["Cons",a.keyCode,c.value])});b(document,"keyup",function(b){b=a(b.keyCode,c.value);Dispatcher.notify(c.id,b)});b(window,"blur",function(){Dispatcher.notify(c.id,["Nil"])});b(document,"keypress",function(a){Dispatcher.notify(f.id,+["Just",a.charCode||a.keyCode]);Dispatcher.notify(f.id,["Nothing"])});return{keysDown:c,charPressed:f}}()},j=function(){var a=function(a){return function(b){var c=Elm.Input(["Waiting"]),d={};window.XMLHttpRequest?d=new XMLHttpRequest:window.ActiveXObject&&(d=new ActiveXObject("Microsoft.XMLHTTP"));d.onreadystatechange=function(){4===d.readyState&&Dispatcher.notify(c.id,200===d.status?["Success",f(d.responseText)]:["Failure",d.status,f(d.statusText)])};d.open(a,Data.String.toText(b),!0);d.send(null);+return c}},b=function(a){return function(b){var c=Elm.Input(["Nothing"]),b=Elm.Lift(function(b){if("Just"!==b[0]){try{Dispatcher.notify(c.id,["Nothing"])}catch(i){}return[]}try{Dispatcher.notify(c.id,["Just",["Waiting"]])}catch(g){c.value=["Just",["Waiting"]]}var h={};window.XMLHttpRequest?h=new XMLHttpRequest:window.ActiveXObject&&(h=new ActiveXObject("Microsoft.XMLHTTP"));h.onreadystatechange=function(){4===h.readyState&&Dispatcher.notify(c.id,["Just",200===h.status?["Success",f(h.responseText)]:+["Failure",h.status,f(h.statusText)]])};h.open(a,Data.String.toText(b[1]),!0);h.send(null);return[]},[b]);return Elm.Lift(function(a){return function(){return a}},[c,b])}};return{get:a("GET"),post:a("POST"),gets:b("GET"),posts:b("POST")}}(),l=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])}}}}}(),o=+function(){var a=function(a){a.isElmLeaf=!0;var c=Elm.Input(["Nil"]);b(a,"keyup",function(){Dispatcher.notify(c.id,f(a.value));a.focus()});return Value.Tuple(a,c)},c=function(a){a=document.createElement(a);a.id=Guid.guid();return a},g=function(a){for(var e=c("select"),d=[];"Cons"===a[0];){var f=c("option"),g=Text.toText(a[1][1]);f.value=g;f.innerHTML=g;e.appendChild(f);d.push(a[1][2]);a=a[2]}var i=Elm.Input(d[0]);b(e,"change",function(){Dispatcher.notify(i.id,d[e.selectedIndex])});return Value.Tuple(e,+i)};return{textArea:function(b){return function(e){var d=c("textarea");d.rows=e;d.cols=b;return a(d,"")}},textField:function(b){var e=c("input");e.type="text";return a(e,b)},password:function(b){var e=c("input");e.type="password";return a(e,b)},checkbox:function(a){var e=c("input");e.type="checkbox";e.checked=a;var d=Elm.Input(a);b(e,"change",function(){Dispatcher.notify(d.id,e.checked)});return Value.Tuple(e,d)},dropDown:g,stringDropDown:function(a){return g(List.map(function(a){return Value.Tuple(a,+a)})(a))},button:function(a){var e=c("input");e.type="button";e.value=Text.toText(a);var d=Elm.Input(!1);b(e,"click",function(){Dispatcher.notify(d.id,!0);Dispatcher.notify(d.id,!1)});return Value.Tuple(e,d)}}}();return{Mouse:a,Keyboard:h,Time:c,Window:g,HTTP:j,Random:l,Input:o,constant:function(a){return Elm.Input(a)},lift:function(a){return function(b){return Elm.Lift(a,[b])}},lift2:function(a){return function(b){return function(c){return Elm.Lift(a,[b,c])}}},lift3:function(a){return function(b){return function(c){return function(f){return Elm.Lift(a,+[b,c,f])}}}},lift4:function(a){return function(b){return function(c){return function(f){return function(e){return Elm.Lift(a,[b,c,f,e])}}}}},foldp:function(a){return function(b){return function(c){return Elm.Fold(a,b,c)}}}}}(),Prelude=function(){var f=function(b){return function(a){var c=b%a,c=0==b?0:0<a?0<=b?c:c+a:-f(-b)(-a);return c==a?0:c}};return{id:function(b){return b},not:function(b){return!b},fst:function(b){return b[1]},snd:function(b){return b[2]},rem:function(b){return function(a){return b%+a}},sqrt:Math.sqrt,abs:Math.abs,pi:Math.PI,sin:Math.sin,cos:Math.cos,tan:Math.tan,asin:Math.asin,acos:Math.acos,atan:Math.atan,mod:f,min:function(b){return function(a){return Math.min(b,a)}},max:function(b){return function(a){return Math.max(b,a)}},flip:function(b){return function(a){return function(c){return b(c)(a)}}},clamp:function(b){return function(a){return function(c){return Math.min(a,Math.max(b,c))}}},curry:function(b){return function(a){return function(c){return b(["Tuple2",a,c])}}},uncurry:function(b){return function(a){if("Tuple2"!==+a[0])throw"Function was uncurry'd but was not given a pair.";return b(a[1])(a[2])}},logBase:function(b){return function(a){return Math.log(a)/Math.log(b)}},Just:Data.Maybe.Just,Nothing:Data.Maybe.Nothing,maybe:Data.Maybe.maybe,map:Data.List.map,filter:Data.List.filter,head:Data.List.head,tail:Data.List.tail,length:Data.List.length,reverse:Data.List.reverse,foldr:Data.List.foldr,foldr1:Data.List.foldr1,foldl:Data.List.foldl,foldl1:Data.List.foldl1,and:Data.List.and,or:Data.List.or,forall:Data.List.forall,+exists:Data.List.exists,sum:Data.List.sum,product:Data.List.product,concat:Data.List.concat,concatMap:Data.List.concatMap,maximum:Data.List.maximum,minimum:Data.List.minimum,scanl:Data.List.scanl,scanl1:Data.List.scanl1,take:Data.List.take,drop:Data.List.drop,lift:Signal.lift,lift2:Signal.lift2,lift3:Signal.lift3,lift4:Signal.lift4,foldp:Signal.foldp,constant:Signal.constant}}(),eq=function(f,b){if("object"===typeof f){if(f===b)return!0;if(f.length!==b.length)return!1;for(var a=f.length;a--;)if(!eq(f[a],+b[a]))return!1;return!0}return f===b},includeGlobal=this;+(function(){var f=function(a){for(var b in a)if("Internal"!==b)try{includeGlobal[b]=a[b]}catch(f){"length"===b&&(includeGlobal.execScript("var length;"),length=a[b])}},b=function(a){return function(b){includeGlobal[a]=includeGlobal[a]||{};for(var f in b)"Internal"!==f&&(includeGlobal[a][f]=b[f])}};f(Element);f(Text);color=Element.color;height=Element.height;show=Value.show;f(Color);f(Shape);f(Line);b("Time")(Signal.Time);b("Mouse")(Signal.Mouse);b("Keyboard")(Signal.Keyboard);b("Window")(Signal.Window);+b("HTTP")(Signal.HTTP);b("Input")(Signal.Input);b("Random")(Signal.Random)})();var ElmCode={};ElmCode.Data=Data;ElmCode.Signal=Signal;ElmCode.Data.List=List;ElmCode.Prelude=Prelude;
src/Ast.hs view
@@ -3,6 +3,18 @@ import Data.Char (isDigit) import Data.List (intercalate) +import Types +import Guid + +data Module = Module [String] Exports Imports Defs + +type Exports = [String] + +type Imports = [(String, ImportMethod)] +data ImportMethod = As String | Hiding [String] | Importing [String] + +type Defs = [(String,Expr)] + data Pattern = PData String [Pattern] | PVar String | PAnything deriving (Eq)
− src/CompileToJS.hs
@@ -1,96 +0,0 @@--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--showErr :: String -> String-showErr err = "text(monospace(" ++ msg ++ "))"- where msg = show . concatMap (++"<br>") . lines $ err--compile = (return . addMain . toJS) <=< initialize-compileToJS = addMain . either showErr toJS-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- Str s -> toJS . list $ map Chr s- 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 (Var "toText") (Str s) -> show s- App (Var "link") (Str s) -> "link(" ++ show s ++ ")"- App (Var "plainText") (Str s) -> "plainText(" ++ show s ++ ")"- 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- | 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")- "==" -> "eq(" ++ e1 ++ "," ++ e2 ++ ")"- "/=" -> "not(eq(" ++ e1 ++ "," ++ e2 ++ "))"- _ -> e1 ++ (o:p) ++ e2--append e1 e2 = "Value.append" ++ parens (e1 ++ "," ++ e2)
src/Compiler.hs view
@@ -1,49 +1,98 @@+{-# LANGUAGE DeriveDataTypeable #-} module Main where -import Data.List (isPrefixOf)+import Data.Either (lefts, rights)+import Data.List (intersect, intercalate)+import Data.Maybe (fromMaybe)+import System.Console.CmdArgs+import Text.Blaze.Html.Renderer.String (renderHtml)++import Ast+import Initialize import CompileToJS import GenerateHtml-import System.Environment-import Text.Blaze.Html.Renderer.String (renderHtml)+import Paths_Elm -main :: IO ()-main = getArgs >>= parse -parse :: [String] -> IO ()-parse ("--help":_) = putStrLn usage-parse ("--version":_) = putStrLn "The Elm Compiler 0.2.0.1"-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+data ELM =+ ELM { make :: Bool+ , files :: [FilePath]+ , runtime :: Maybe FilePath+ , separate_js :: Bool+ , only_js :: Bool+-- , verbose_js :: Bool+ }+ deriving (Data,Typeable,Show,Eq) -produceHtml :: String -> FilePath -> IO ()-produceHtml libLoc file = do+elm = ELM { make = False &= help "automatically compile dependencies."+ , files = def &= args &= typ "FILES"+ , runtime = Nothing &= typ "FILE" &=+ help "Specify a custom location for Elm's runtime system."+ , separate_js = False &= help "Compile to separate HTML and JS files."+ , only_js = False &= help "Compile only to JavaScript."+-- , verbose_js = False &= help "Produce JavaScript that may be easier to debug."+ } &=+ help "Compile Elm programs to HTML, CSS, and JavaScript." &=+ summary "The Elm Compiler v0.3.0, (c) Evan Czaplicki"++main = do+ args <- cmdArgs elm+ mini <- getDataFileName "elm-runtime-0.3.0.js"+ compileArgs mini args++compileArgs mini (ELM _ [] _ _ _) =+ putStrLn "Usage: elm [OPTIONS] [FILES]\nFor more help: elm --help"+compileArgs mini (ELM make files rtLoc split only) =+ mapM_ (fileTo get what $ fromMaybe mini rtLoc) files+ where get = if make then getModules [] else getModule+ what = if only then JS else+ if split then Split else HTML++data What = JS | HTML | Split++fileTo get what rtLoc file = do+ ems <- get file+ case ems of+ Left err -> putStrLn $ "Error while compiling " ++ file ++ ":\n" ++ err+ Right ms ->+ let name = reverse . tail . dropWhile (/='.') $ reverse file+ js = name ++ ".js"+ html = name ++ ".html"+ in case what of+ JS -> writeFile js $ concatMap jsModule ms+ HTML -> writeFile html . renderHtml $ modulesToHtml rtLoc ms+ Split -> do+ writeFile html . renderHtml $ linkedHtml rtLoc js ms+ writeFile js $ concatMap jsModule ms++getModules :: [String] -> FilePath -> IO (Either String [Module])+getModules uses 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 code+ case initialize code of+ Left err -> return . Left $ "Error in " ++ file ++ ":\n" ++ err+ Right modul@(Module _ _ imports _) ->+ let imps = filter (`notElem` builtInModules) $ map fst imports in+ case intersect uses imps of+ x:_ -> return . Left $ "Error: Cyclic dependency. Module " +++ x ++ " depends on itself."+ [] -> do+ ems <- mapM (getModules (uses ++ imps) . toFilePath) imps+ return $ case lefts ems of+ [] -> Right $ concat (rights ems) ++ [modul]+ errs -> Left $ intercalate "\n" errs -usageMini :: String-usageMini =- "Usage: elm [OPTIONS] FILE\n\- \Try `elm --help' for more information."+getModule :: FilePath -> IO (Either String [Module])+getModule file = do+ code <- readFile file+ return . fmap (:[]) $ initialize code -usage :: String-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>"+toFilePath :: String -> FilePath+toFilePath modul = map (\c -> if c == '.' then '/' else c) modul ++ ".elm"++builtInModules =+ concat [ map ("Data."++) [ "List", "Char", "Maybe" ]+ , map ("Signal."++) [ "Mouse", "Keyboard.Raw"+ , "Window", "Time", "HTTP", "Input", "Random" ]+ , [ "Element", "Text", "Color", "Line" ]+ , [ "Prelude" ]+ ]
− src/ExtractNoscript.hs
@@ -1,26 +0,0 @@- -module ExtractNoscript (extract) where - -import Ast - -extract = concatMap (\s -> "<p>" ++ s ++ "</p>") . extract' - -extract' expr = - let f = extract' in - case expr of - Str s -> [s] - Binop op e1 e2 -> case (op, f e1, f e2) of - ("++", [s1], [s2]) -> [s1 ++ s2] - (_ , ss1 , ss2 ) -> ss1 ++ ss2 - Lambda v e -> f e - App (App (Var "link") src) txt -> - case (f src, f txt) of - ([s1],[s2]) -> [ "<a href=\"" ++ s1 ++ "\">" ++ s2 ++ "</a>" ] - ( ss1, ss2) -> ss1 ++ ss2 - App e1 e2 -> f e1 ++ f e2 - If eb et ef -> f et ++ f ef - Let defs e -> concatMap (f . snd) defs ++ f e - Var _ -> [] - Case e cases -> concatMap (f . snd) cases - Data _ es -> concatMap f es - _ -> []
+ src/Gen/CompileToJS.hs view
@@ -0,0 +1,145 @@++module CompileToJS (showErr, jsModule) where++import Ast+import Control.Monad (liftM,(<=<),join)+import Data.Char (isAlpha,isDigit)+import Data.List (intercalate,sortBy,inits)+import Data.Map (toList)+import Data.Maybe (mapMaybe)++import Initialize++showErr :: String -> String+showErr err = mainEquals $ "text(monospace(" ++ msg ++ "))"+ where msg = show . concatMap (++"<br>") . lines $ err++parens = ("("++) . (++")")+braces = ("{"++) . (++"}")+jsList = ("["++) . (++"]") . intercalate ","+jsFunc args body = "function(" ++ args ++ "){" ++ body ++ "}"+assign x e = "\nvar " ++ x ++ "=" ++ e ++ ";"+ret e = "\nreturn "++ e ++";"+iff a b c = a ++ "?" ++ b ++ ":" ++ c++mainEquals s = globalAssign "ElmCode.main" (jsFunc "" (ret s))+globalAssign m s = "\n" ++ m ++ "=" ++ s ++ ";"++tryBlock names e = + concat [ "\ntry{\n" ++ e ++ "\n\n} catch (e) {"+ , "ElmCode.main=function() {"+ , "var msg = ('<br><h2>Your browser may not be supported. " +++ "Are you using a modern browser?</h2>' +" +++ " '<br><span style=\"color:grey\">Runtime Error in " +++ intercalate "." names ++ " module:<br>' + e + '</span>');"+ , "document.body.innerHTML = Text.monospace(msg);"+ , "throw e;"+ , "};}"+ ]+++jsModule (Module names exports imports defs) =+ tryBlock (tail modNames) $ concat+ [ concatMap (\n -> globalAssign n $ n ++ " || {}") . map (intercalate ".") . drop 2 . inits $ take (length modNames - 1) modNames+ , "\nif (" ++ modName ++ ") throw \"Module name collision, '" ++ intercalate "." (tail modNames) ++ "' is already defined.\"; "+ , globalAssign modName $ jsFunc "" (includes ++ body ++ export) ++ "()"+ , mainEquals $ modName ++ ".main" ]+ where modNames = if null names then ["ElmCode", "Main"] else "ElmCode" : names+ modName = intercalate "." modNames+ includes = concatMap jsImport $+ map (\(x,y) -> ("ElmCode." ++ x,y)) imports+ body = jsDefs defs+ export = ret . braces . intercalate "," $ mapMaybe getNames defs+ exps = if null exports then ["main"] else exports+ getNames (x,_) =+ let y = reverse . tail . dropWhile isDigit $ reverse x in+ if y `elem` exps then Just $ y ++ ":" ++ x else Nothing++jsImport (modul, how) =+ concat [ "\ntry{" ++ modul ++ "} catch(e) {throw \"Module '"+ , drop 1 (dropWhile (/='.') modul)+ , "' is missing. Compile with --make flag or load missing "+ , "module in a separate JavaScript file.\";}" ] ++ jsImport' (modul, how)+ +jsImport' (modul, As name) = assign name modul+jsImport' (modul, Importing []) = jsImport' (modul, Hiding [])+jsImport' (modul, Importing vs) =+ concatMap (\v -> assign v $ modul ++ "." ++ v) vs+jsImport' (modul, Hiding vs) =+ concat [ "\nfor(var i in " ++ modul ++ "){"+ , assign "hiddenVars" . jsList $ map (\v -> "'" ++ v ++ "'") vs+ , "\nif (hiddenVars.indexOf(i) >= 0) continue;"+ , globalAssign "this[i]" $ modul ++ "[i]"+ , "}" ]+++toJS expr =+ case expr of+ Number n -> show n+ Var x -> x+ Chr c -> show c+ Str s -> toJS . list $ map Chr s+ 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 (Var "toText") (Str s) -> show s+ App (Var "link") (Str s) -> "link(" ++ show s ++ ")"+ App (Var "plainText") (Str s) -> "plainText(" ++ show s ++ ")"+ 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 "" (jsDefs defs ++ ret (toJS e')) ++ "()"++jsDefs defs = concatMap toDef $ sortBy f defs+ where f a b = compare (isLambda a) (isLambda b)+ isLambda (_, Lambda _ _) = 1+ isLambda _ = 0+ toDef (f, Lambda x e) =+ "\nfunction " ++ 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+ | 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")+ "==" -> "eq(" ++ e1 ++ "," ++ e2 ++ ")"+ "/=" -> "not(eq(" ++ e1 ++ "," ++ e2 ++ "))"+ _ -> e1 ++ (o:p) ++ e2++append e1 e2 = "Value.append" ++ parens (e1 ++ "," ++ e2)
+ src/Gen/ExtractNoscript.hs view
@@ -0,0 +1,35 @@+ +module ExtractNoscript (extract) where + +import Ast + +extract (Module _ _ _ defs) = + concatMap (\s -> "<p>" ++ s ++ "</p>") $ concatMap (extract' . snd) defs + +extract' expr = + let f = extract' in + case expr of + Str s -> [s] + Binop op e1 e2 -> case (op, f e1, f e2) of + ("++", [s1], [s2]) -> [s1 ++ s2] + (_ , ss1 , ss2 ) -> ss1 ++ ss2 + Lambda v e -> f e + App (App (Var "link") src) txt -> + case (f src, f txt) of + ([s1],[s2]) -> [ "<a href=\"" ++ s1 ++ "\">" ++ s2 ++ "</a>" ] + ( ss1, ss2) -> ss1 ++ ss2 + App (Var "header") e -> tag "h1" e + App (Var "bold") e -> tag "b" e + App (Var "italic") e -> tag "i" e + App (Var "monospace") e -> tag "code" e + App e1 e2 -> f e1 ++ f e2 + If eb et ef -> f et ++ f ef + Let defs e -> concatMap (f . snd) defs ++ f e + Var _ -> [] + Case e cases -> concatMap (f . snd) cases + Data _ es -> concatMap f es + _ -> [] + +tag t e = case extract' e of + [s] -> [ concat [ "<", t, ">", s, "</", t, ">" ] ] + ss -> ss
+ src/Gen/GenerateHtml.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE OverloadedStrings #-}+module GenerateHtml (generateHtml,+ body, css, widgetBody,+ modulesToHtml, linkedHtml+ ) where++import Data.List (intercalate)+import Text.Blaze (preEscapedToMarkup)+import Text.Blaze.Html (Html)+import qualified Text.Blaze.Html5 as H+import Text.Blaze.Html5 ((!))+import qualified Text.Blaze.Html5.Attributes as A++import Ast+import Initialize+import CompileToJS+import ExtractNoscript++css = H.style ! A.type_ "text/css" $ preEscapedToMarkup+ ("* { 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;}" :: String)++makeScript :: Either String String -> H.Html+makeScript (Left s) =+ H.script ! A.type_ "text/javascript" ! A.src (H.toValue s) $ ""+makeScript (Right s) = + H.script ! A.type_ "text/javascript" $ preEscapedToMarkup s++-- |This function compiles Elm code into simple HTML.+--+-- Usage example:+--+-- > generateHtml "/elm-min.js" "Some title" [elmFile|elm-source/somePage.elm|]+generateHtml :: String -- ^ Location of elm-min.js as expected by the browser+ -> String -- ^ The page title+ -> String -- ^ The elm source code.+ -> Html+generateHtml libLoc title source =+ case initialize source of+ Left err -> createHtml libLoc title (Right $ showErr err) (H.noscript "")+ Right modul -> modulesToHtml libLoc [modul]+++modulesToHtml libLoc modules = createHtml libLoc title js noscript+ where title = (\(Module names _ _ _) -> intercalate "." names) $ last modules+ js = Right $ concatMap jsModule modules+ noscript = extract $ last modules++linkedHtml rtLoc jsLoc modules =+ createHtml rtLoc title (Left jsLoc) (H.noscript "")+ where title = (\(Module names _ _ _) -> intercalate "." names) $ last modules+++createHtml libLoc title js noscript =+ H.docTypeHtml $ do + H.head $ do+ H.meta ! A.charset "UTF-8"+ H.title . H.toHtml $ title+ makeScript (Left libLoc)+ makeScript js+ css+ H.body $ body noscript++body noscript = do+ H.div ! A.id "widthChecker" ! A.style "width:100%; height:1px; position:absolute; top:-1px;" $ ""+ H.div ! A.id "content" $ ""+ H.script ! A.type_ "text/javascript" $ "Dispatcher.initialize()"+ H.noscript $ preEscapedToMarkup noscript++widgetBody noscript = do+ H.div ! A.id "widthChecker" ! A.style "width:100%; height:1px; position:absolute; top:-1px;" $ ""+ H.div ! A.id "content" $ ""+ H.noscript $ preEscapedToMarkup noscript
− src/GenerateHtml.hs
@@ -1,59 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module GenerateHtml (generateHtml, body, css, widgetBody) where--import Text.Blaze (preEscapedToMarkup)-import Text.Blaze.Html (Html)-import qualified Text.Blaze.Html5 as H-import Text.Blaze.Html5 ((!))-import qualified Text.Blaze.Html5.Attributes as A--import Initialize-import CompileToJS-import ExtractNoscript--css = H.style ! A.type_ "text/css" $ preEscapedToMarkup- ("* { 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;}" :: String)--makeScript :: String -> H.Html-makeScript s = H.script ! A.type_ "text/javascript" ! A.src (H.toValue s) $ ""---- |This function compiles Elm code into simple HTML.------ Usage example:------ > generateHtml "/elm-min.js" "Some title" [elmFile|elm-source/somePage.elm|]-generateHtml :: String -- ^ Location of elm-min.js as expected by the browser- -> String -- ^ The page title- -> String -- ^ The elm source code.- -> Html-generateHtml libLoc title source =- let expr = initialize source- js = compileToJS expr- noscript = either id extract expr- in- H.docTypeHtml $ do - H.head $ do- H.meta ! A.charset "UTF-8"- H.title . H.toHtml $ title- makeScript libLoc- H.script ! A.type_ "text/javascript" $ preEscapedToMarkup js- css- H.body $ body noscript--body noscript = do- H.div ! A.id "widthChecker" ! A.style "width:100%; height:1px; position:absolute; top:-1px;" $ ""- H.span ! A.id "content" $ ""- H.script ! A.type_ "text/javascript" $ "Dispatcher.initialize()"- H.noscript $ preEscapedToMarkup noscript--widgetBody noscript = do- H.div ! A.id "widthChecker" ! A.style "width:100%; height:1px; position:absolute; top:-1px;" $ ""- H.span ! A.id "content" $ ""- H.noscript $ preEscapedToMarkup noscript
src/Initialize.hs view
@@ -1,100 +1,18 @@ module Initialize (initialize) where -import Ast-import Control.Arrow (first, second)-import Control.Monad-import Data.Char (isAlpha)-import Data.Maybe (mapMaybe)-import Data.Either (rights)--import Parser (toDefs)-import Rename (rename)+import Control.Monad.Error -import Unify+import Ast+import Parser (parseProgram) import Hints-+import Unify+import Rename+import Optimize initialize str = do- (expr, hints') <- toDefs str- let expr' = rename expr- subs <- unify (liftM2 (++) hints hints') expr'- let init = simp_loop expr'- return (seq subs init)--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 -> 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 -> App (f e1) (f e2)- If e1 e2 e3 -> simp_if (f e1) (f e2) (f e3)- Let defs e -> Let (map (second f) defs) (f e)- Data name es -> Data name (map f es)- Case e cases -> Case (f e) (map (second f) cases)- _ -> expr--simp_if (Boolean b) e2 e3 = if b then e2 else e3-simp_if a b c = If a b c--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 "++" (Str s1) (Str s2) = Str $ s1 ++ s2-binop "++" (Str s1) (Binop "++" (Str s2) e) = Binop "++" (Str $ s1 ++ s2) e-binop "++" (Binop "++" e (Str s1)) (Str s2) = Binop "++" e (Str $ s1 ++ s2)-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---}+ (Module name ex im defs, tipes) <- parseProgram str+ let expr = rename . Let defs $ Var "_"+ subs <- unify (liftM2 (++) hints tipes) expr+ let Let defs' _ = optimize expr+ let im' = if any ((=="Prelude") . fst) im then im else ("Prelude", Importing []):im+ return (subs `seq` Module name ex im' defs')
src/Language/Elm.hs view
@@ -69,6 +69,6 @@ -- build helper to avoid boilerplate repetition toPartsHelper :: String -> (Html, Html, String) toPartsHelper source = (html, css, js) - where expr = initialize source - js = compileToJS expr - html = widgetBody $ either id extract expr + where modul = initialize source + js = either showErr jsModule modul + html = widgetBody $ either id extract modul
+ src/Optimize.hs view
@@ -0,0 +1,84 @@+module Optimize (optimize) where++import Ast+import Control.Arrow (second)+import Data.Char (isAlpha)+++optimize exp = if exp == exp' then exp' else optimize exp'+ where exp' = simp exp++simp expr =+ let f = simp in+ case expr of+ Range e1 e2 -> 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 -> App (f e1) (f e2)+ If e1 e2 e3 -> simp_if (f e1) (f e2) (f e3)+ Let defs e -> Let (map (second f) defs) (f e)+ Data name es -> Data name (map f es)+ Case e cases -> Case (f e) (map (second f) cases)+ _ -> expr++simp_if (Boolean b) e2 e3 = if b then e2 else e3+simp_if a b c = If a b c++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 "++" (Str s1) (Str s2) = Str $ s1 ++ s2+binop "++" (Str s1) (Binop "++" (Str s2) e) = Binop "++" (Str $ s1 ++ s2) e+binop "++" (Binop "++" e (Str s1)) (Str s2) = Binop "++" e (Str $ s1 ++ s2)+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/Binops.hs view
@@ -1,69 +1,68 @@-module Binops (binops) where - -import Ast -import Control.Monad (liftM,guard) -import Control.Monad.Error -import Data.List (foldl',splitAt,elemIndices,group,groupBy,sortBy,find) -import qualified Data.Map as Map -import Data.Maybe (mapMaybe) - -import Text.Parsec -import ParseLib - -data Assoc = L | N | R deriving (Eq,Show) - -table = [ (9, R, ".") - , (7, L, "*"), (7, L, "/"), (7, L, "mod") - , (6, L, "+"), (6, L, "-") - , (5, R, ":" ), (5, R, "++") - , (4, N, "<="), (4, N, ">="), (4, N, "<") - , (4, N, "=="), (4, N, "/="), (4, N, ">") - , (3, R, "&&") - , (2, R, "||") - , (0, R, "$") - ] - -sortOps = sortBy (\(i,_,_) (j,_,_) -> compare i j) - -binops term anyOp = do - e <- term - (ops,es) <- liftM unzip $ - many (try $ do { whitespace - ; op <- anyOp - ; whitespace - ; e <- term; return (op,e) }) - case binopOf Map.empty (sortOps table) ops (e:es) of - Right e -> return e - Left msg -> fail msg - -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 seen [] ops es = binopOf seen [(9,L,head ops)] ops 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 (Map.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 (Map.insert lvl (assoc,op) seen) tbl i ops es - Just (assoc',op') -> - if assoc == assoc' && assoc /= N 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 ++ "]" +module Binops (binops) where++import Ast+import Control.Monad (liftM,guard)+import Control.Monad.Error+import Data.List (foldl',splitAt,elemIndices,group,groupBy,sortBy,find)+import qualified Data.Map as Map+import Data.Maybe (mapMaybe)++import Text.Parsec+import ParseLib++data Assoc = L | N | R deriving (Eq,Show)++table = [ (9, R, ".")+ , (7, L, "*"), (7, L, "/"), (7, L, "mod")+ , (6, L, "+"), (6, L, "-")+ , (5, R, ":" ), (5, R, "++")+ , (4, N, "<="), (4, N, ">="), (4, N, "<")+ , (4, N, "=="), (4, N, "/="), (4, N, ">")+ , (3, R, "&&")+ , (2, R, "||")+ , (0, R, "$")+ ]++sortOps = sortBy (\(i,_,_) (j,_,_) -> compare i j)++binops term anyOp = do+ e <- term+ (ops,es) <- liftM unzip $+ many (commitIf (whitespace >> anyOp) $ do { whitespace ; op <- anyOp+ ; whitespace ; e <- term+ ; return (op,e) })+ case binopOf Map.empty (sortOps table) ops (e:es) of+ Right e -> return e+ Left msg -> fail msg++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 seen [] ops es = binopOf seen [(9,L,head ops)] ops 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 (Map.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 (Map.insert lvl (assoc,op) seen) tbl i ops es+ Just (assoc',op') ->+ if assoc == assoc' && assoc /= N 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/ParseExpr.hs view
@@ -0,0 +1,121 @@+module ParseExpr (def) where + +import Ast +import Control.Applicative ((<$>), (<*>)) +import Control.Monad +import Data.Char (isSymbol, isDigit) +import Data.List (foldl') +import Text.Parsec hiding (newline,spaces) + +import ParseLib +import Patterns +import Binops + +import Guid +import Types (Type (VarT)) + + +-------- Basic Terms -------- + +numTerm :: (Monad m) => ParsecT [Char] u m Expr +numTerm = liftM (Number . read) (many1 digit) <?> "number" + +strTerm :: (Monad m) => ParsecT [Char] u m Expr +strTerm = liftM Str . expecting "string" . betwixt '"' '"' . many $ + backslashed <|> satisfy (/='"') + +varTerm :: (Monad m) => ParsecT [Char] u m Expr +varTerm = toVar <$> var <?> "variable" + +toVar v = case v of "True" -> Boolean True + "False" -> Boolean False + _ -> Var v + +chrTerm :: (Monad m) => ParsecT [Char] u m Expr +chrTerm = Chr <$> betwixt '\'' '\'' (backslashed <|> satisfy (/='\'')) + <?> "character" + + +-------- Complex Terms -------- + +listTerm = braces $ choice + [ try $ do { lo <- expr; whitespace; string ".." ; whitespace + ; Range lo <$> expr } + , list <$> commaSep expr + ] + +parensTerm = parens $ choice + [ do op <- anyOp + return . Lambda "x" . Lambda "y" $ Binop op (Var "x") (Var "y") + , do es <- commaSep expr + return $ case es of { [e] -> e; _ -> tuple es } + ] + +term = choice [ numTerm, strTerm, chrTerm + , accessible varTerm + , listTerm, parensTerm ] + <?> "basic term (4, x, 'c', etc.)" + +-------- Applications -------- + +appExpr = do + tlist <- spaceSep1 term + return $ case tlist of + t:[] -> t + t:ts -> foldl' App t ts + +-------- Normal Expressions -------- + +binaryExpr = binops appExpr anyOp + +ifExpr = do reserved "if" ; whitespace ; e1 <- expr ; whitespace + reserved "then" ; whitespace ; e2 <- expr ; (whitespace <?> "an 'else' branch") + reserved "else" <?> "an 'else' branch" ; whitespace ; If e1 e2 <$> expr + +lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function" + whitespace + args <- spaceSep1 patternTerm + whitespace ; arrow ; whitespace + e <- expr + return $ makeFunction args e + +letExpr = do + reserved "let" + brace <- optionMaybe . try $ do + whitespace + char '{' <?> "a set of definitions { x = ... ; y = ... }" + case brace of + Nothing -> do whitespace; ds <- assignExpr + whitespace; reserved "in"; whitespace; Let ds <$> expr + Just '{' -> do whitespace ; dss <- semiSep1 assignExpr ; whitespace + string "}" <?> "closing bracket '}'" + whitespace; reserved "in"; whitespace; e <- expr + return $ Let (concat dss) e + +caseExpr = do + reserved "case"; whitespace; e <- expr; whitespace; reserved "of"; whitespace + Case e <$> brackets (semiSep1 (case_ <?> "cases { x -> ... }")) + where case_ = do p <- patternExpr; whitespace; arrow; whitespace + (,) p <$> expr + +expr = choice [ ifExpr, letExpr, caseExpr + , lambdaExpr, binaryExpr ] <?> "an expression" + +assignExpr = do + patterns <- + choice [ try $ do v <- PVar <$> lowVar + notFollowedBy (whitespace >> char ':') + (v:) <$> spacePrefix patternTerm + , (:[]) <$> patternExpr + ] <?> "the definition of a variable (x = ...)" + whitespace; string "="; whitespace; exp <- expr + flattenPatterns patterns exp + + +def = do (fs,es) <- unzip <$> assignExpr + return (fs, es, mapM (\_ -> liftM VarT guid) fs) + +parseDef str = + case parse def "" str of + Right result -> Right result + Left err -> Left $ "Parse error at " ++ show err
src/Parse/ParseLib.hs view
@@ -1,136 +1,142 @@- -module ParseLib where - -import Ast -import Control.Applicative ((<$>),(<*>)) -import Control.Monad -import Data.Char (isSymbol) -import Text.Parsec hiding (newline,spaces) - -reserveds = [ "if", "then", "else" - , "case", "of", "data" - , "let", "in" ] - -expecting = flip (<?>) - -backslashed :: (Monad m) => ParsecT [Char] u m Char -backslashed = do { char '\\'; c <- anyChar - ; return . read $ ['\'','\\',c,'\''] } - -var :: (Monad m) => ParsecT [Char] u m String -var = makeVar (letter <|> char '_' <?> "variable") - -lowVar :: (Monad m) => ParsecT [Char] u m String -lowVar = makeVar (lower <?> "lower case variable") -capVar :: (Monad m) => ParsecT [Char] u m String -capVar = makeVar (upper <?> "upper case variable") - -innerVarChar :: (Monad m) => ParsecT [Char] u m Char -innerVarChar = alphaNum <|> char '_' <|> char '\'' <?> "" - -makeVar p = do v <- (:) <$> p <*> many innerVarChar - guard (v `notElem` reserveds) - return v - -reserved word = - try (string word >> notFollowedBy innerVarChar) >> return word - <?> "reserved word '" ++ word ++ "'" - -anyOp :: (Monad m) => ParsecT [Char] u m String -anyOp = betwixt '`' '`' var <|> - (do op <- many1 (satisfy isSymbol <|> oneOf "+-/*=.$<>:&|^?%#@~!") - guard (op `notElem` [ "=", "..", "->", "--" ]) - return op) <?> "infix operator (e.g. x + y)" - -arrow :: (Monad m) => ParsecT [Char] u m String -arrow = string "->" <|> string "\8594" <?> "arrow (->)" - -commaSep :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a] -commaSep p = do - x <- optionMaybe p - case x of - Just a -> (a:) <$> many (try (whitespace >> (char ',' <?> "comma ','")) >> - whitespace >> p) - Nothing -> return [] - -semiSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a] -semiSep1 p = do - a <- p - (a:) <$> many (try (whitespace >> (char ';' <?> "semicolon ';'")) >> - whitespace >> p) - -pipeSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a] -pipeSep1 p = do - a <- p - (a:) <$> many (try (whitespace >> (char '|' <?> "type divider '|'")) >> - whitespace >> p) - -consSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a] -consSep1 p = do - a <- p - (a:) <$> many (try (whitespace >> (char ':' <?> "cons operator ':'")) >> - whitespace >> p) - -spaceSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a] -spaceSep1 p = (:) <$> p <*> spacePrefix p - -spacePrefix p = many (try (whitespace >> p)) - -betwixt a b c = do char a ; out <- c - char b <?> "closing '" ++ [b] ++ "'" ; return out - -surround a z name p = do - char a ; whitespace ; a <- p ; whitespace - char z <?> unwords ["closing", name, show z] - return a - -braces :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m a -braces = surround '[' ']' "brace" - -parens :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m a -parens = surround '(' ')' "paren" - -brackets :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m a -brackets = surround '{' '}' "bracket" - -accessible expr = do - e <- expr - access <- optionMaybe . try $ - (do { char '.' ; notFollowedBy (char '.') } <?> "field access (e.g. List.map)") - case access of - Just _ -> accessible (Access e `liftM` var <?> "field access (e.g. List.map)") - Nothing -> return e - - -spaces :: (Monad m) => ParsecT [Char] u m String -spaces = many1 ((multiComment <|> string " " <?> "") >> return ' ') <?> "spaces" - -forcedWS :: (Monad m) => ParsecT [Char] u m [String] -forcedWS = try (do { spaces; many nl_space }) <|> try (many1 nl_space) - where nl_space = try $ many1 newline >> spaces - -whitespace :: (Monad m) => ParsecT [Char] u m () -whitespace = optional forcedWS <?> "" - -freshLine :: (Monad m) => ParsecT [Char] u m [[String]] -freshLine = try (do { many1 newline; many space_nl }) <|> try (many1 space_nl) <?> "" - where space_nl = try $ spaces >> many1 newline - -newline :: (Monad m) => ParsecT [Char] u m String -newline = simpleNewline <|> lineComment <?> "" - -simpleNewline :: (Monad m) => ParsecT [Char] u m String -simpleNewline = try (string "\r\n") <|> string "\n" - -lineComment :: (Monad m) => ParsecT [Char] u m String -lineComment = do try (string "--") - manyTill anyChar $ simpleNewline <|> (eof >> return "\n") - -multiComment :: (Monad m) => ParsecT [Char] u m String -multiComment = do { try (string "{-"); closeComment } - -closeComment :: (Monad m) => ParsecT [Char] u m String -closeComment = manyTill anyChar . choice $ - [ try (string "-}") <?> "close comment" - , do { try $ string "{-"; closeComment; closeComment } ++module ParseLib where++import Ast+import Control.Applicative ((<$>),(<*>))+import Control.Monad+import Data.Char (isSymbol)+import Text.Parsec hiding (newline,spaces)++reserveds = [ "if", "then", "else"+ , "case", "of", "data"+ , "let", "in"+ , "module", "where"+ , "import", "as", "hiding" ]++expecting = flip (<?>)++backslashed :: (Monad m) => ParsecT [Char] u m Char+backslashed = do { char '\\'; c <- anyChar+ ; return . read $ ['\'','\\',c,'\''] }++var :: (Monad m) => ParsecT [Char] u m String+var = makeVar (letter <|> char '_' <?> "variable")++lowVar :: (Monad m) => ParsecT [Char] u m String+lowVar = makeVar (lower <?> "lower case variable")+capVar :: (Monad m) => ParsecT [Char] u m String+capVar = makeVar (upper <?> "upper case variable")++innerVarChar :: (Monad m) => ParsecT [Char] u m Char+innerVarChar = alphaNum <|> char '_' <|> char '\'' <?> "" ++makeVar p = do v <- (:) <$> p <*> many innerVarChar+ guard (v `notElem` reserveds)+ return v++reserved word =+ try (string word >> notFollowedBy innerVarChar) >> return word+ <?> "reserved word '" ++ word ++ "'"++anyOp :: (Monad m) => ParsecT [Char] u m String+anyOp = betwixt '`' '`' var <|>+ (do op <- many1 (satisfy isSymbol <|> oneOf "+-/*=.$<>:&|^?%#@~!")+ guard (op `notElem` [ "=", "..", "->", "--" ])+ return op) <?> "infix operator (e.g. +, *, ||)"++arrow :: (Monad m) => ParsecT [Char] u m String+arrow = string "->" <|> string "\8594" <?> "arrow (->)"+++commitIf check p = commit <|> try p+ where commit = do (try $ lookAhead check) >> p++spaceySepBy1 :: (Monad m) => ParsecT [Char] u m b -> ParsecT [Char] u m a -> ParsecT [Char] u m [a]+spaceySepBy1 sep p = do+ a <- p+ (a:) <$> many (commitIf (whitespace >> sep) (whitespace >> sep >> whitespace >> p))+++commaSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]+commaSep1 = spaceySepBy1 (char ',' <?> "comma ','")++commaSep :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]+commaSep = option [] . commaSep1++semiSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]+semiSep1 = spaceySepBy1 (char ';' <?> "semicolon ';'")++pipeSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]+pipeSep1 = spaceySepBy1 (char '|' <?> "type divider '|'")++consSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]+consSep1 = spaceySepBy1 (char ':' <?> "cons operator ':'")++dotSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]+dotSep1 p = (:) <$> p <*> many (try (char '.') >> p)++spaceSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]+spaceSep1 p = (:) <$> p <*> spacePrefix p++spacePrefix p = many (commitIf (whitespace >> (char '[' <|> char '(')) (whitespace >> p))++followedBy a b = do x <- a ; b ; return x++betwixt a b c = do char a ; out <- c+ char b <?> "closing '" ++ [b] ++ "'" ; return out++surround a z name p = do+ char a ; whitespace ; a <- p ; whitespace+ char z <?> unwords ["closing", name, show z]+ return a++braces :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m a+braces = surround '[' ']' "brace"++parens :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m a+parens = surround '(' ')' "paren"++brackets :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m a+brackets = surround '{' '}' "bracket"++accessible expr = do+ e <- expr+ access <- optionMaybe . try $+ (do { char '.' ; notFollowedBy (char '.') } <?> "field access (e.g. List.map)")+ case access of+ Just _ -> accessible (Access e `liftM` var <?> "field access (e.g. List.map)")+ Nothing -> return e+++spaces :: (Monad m) => ParsecT [Char] u m String+spaces = many1 ((multiComment <|> string " " <?> "") >> return ' ') <?> "spaces"++forcedWS :: (Monad m) => ParsecT [Char] u m [String]+forcedWS = try (do { spaces; many nl_space }) <|> try (many1 nl_space)+ where nl_space = try $ many1 newline >> spaces++whitespace :: (Monad m) => ParsecT [Char] u m ()+whitespace = optional forcedWS <?> ""++freshLine :: (Monad m) => ParsecT [Char] u m [[String]]+freshLine = try (do { many1 newline; many space_nl }) <|> try (many1 space_nl) <?> ""+ where space_nl = try $ spaces >> many1 newline++newline :: (Monad m) => ParsecT [Char] u m String+newline = simpleNewline <|> lineComment <?> ""++simpleNewline :: (Monad m) => ParsecT [Char] u m String+simpleNewline = try (string "\r\n") <|> string "\n"++lineComment :: (Monad m) => ParsecT [Char] u m String+lineComment = do try (string "--")+ manyTill anyChar $ simpleNewline <|> (eof >> return "\n")++multiComment :: (Monad m) => ParsecT [Char] u m String+multiComment = do { try (string "{-"); closeComment }++closeComment :: (Monad m) => ParsecT [Char] u m String+closeComment = manyTill anyChar . choice $+ [ try (string "-}") <?> "close comment"+ , do { try $ string "{-"; closeComment; closeComment } ]
+ src/Parse/ParseModules.hs view
@@ -0,0 +1,44 @@+ +module ParseModules (moduleDef, imports) where + +import Control.Applicative ((<$>), (<*>)) +import Data.List (intercalate) +import Text.Parsec hiding (newline,spaces) + +import Ast +import ParseLib + +moduleDef :: (Monad m) => ParsecT [Char] u m ([String], [String]) +moduleDef = do + try (reserved "module") + whitespace <?> "name of module" + names <- dotSep1 capVar + whitespace + exports <- option [] . parens $ commaSep var + whitespace <?> "reserved word 'where'" + reserved "where" + return (names, exports) + +imports :: (Monad m) => ParsecT [Char] u m Imports +imports = option [] ((:) <$> import' <*> many (try (freshLine >> import'))) + + +import' :: (Monad m) => ParsecT [Char] u m (String, ImportMethod) +import' = do + reserved "import" + whitespace + name <- intercalate "." <$> dotSep1 capVar + method <- option (Importing []) $ try (whitespace >> + (as' <|> hiding' <|> importing')) + return (name, method) + + +as' :: (Monad m) => ParsecT [Char] u m ImportMethod +as' = reserved "as" >> whitespace >> As <$> capVar <?> "alias for module" + +hiding' :: (Monad m) => ParsecT [Char] u m ImportMethod +hiding' = reserved "hiding" >> whitespace >> + Hiding <$> parens (commaSep1 var) <?> "listing of hidden values" + +importing' :: (Monad m) => ParsecT [Char] u m ImportMethod +importing' = Importing <$> parens (commaSep1 var) <?> "listing of imported values (x,y,z)"
src/Parse/ParseTypes.hs view
@@ -1,83 +1,83 @@-module ParseTypes where - -import Ast -import Control.Applicative ((<$>),(<*>)) -import Control.Monad (liftM) -import Data.Char (isUpper,isLower) -import Data.Maybe (fromMaybe) -import Data.List (lookup) -import Text.Parsec - -import ParseLib -import Types hiding (string,parens) -import Guid - -data ParseType = VarPT String - | LambdaPT ParseType ParseType - | ADTPT String [ParseType] - -listPT t = ADTPT "List" [t] -tuplePT ts = ADTPT ("Tuple" ++ show (length ts)) ts - -typeVar :: (Monad m) => ParsecT [Char] u m ParseType -typeVar = VarPT <$> lowVar <?> "type variable" - -typeList :: (Monad m) => ParsecT [Char] u m ParseType -typeList = listPT <$> braces typeExpr - -typeTuple :: (Monad m) => ParsecT [Char] u m ParseType -typeTuple = do ts <- parens (commaSep typeExpr) - return $ case ts of { [t] -> t ; _ -> tuplePT ts } - -typeUnambiguous :: (Monad m) => ParsecT [Char] u m ParseType -typeUnambiguous = typeList <|> typeTuple - -typeSimple :: (Monad m) => ParsecT [Char] u m ParseType -typeSimple = VarPT <$> var - -typeApp :: (Monad m) => ParsecT [Char] u m ParseType -typeApp = do name <- capVar - args <- spacePrefix (typeUnambiguous <|> typeSimple) - return $ case args of - [] -> VarPT name - _ -> ADTPT name args - -typeExpr :: (Monad m) => ParsecT [Char] u m ParseType -typeExpr = do - t1 <- typeVar <|> typeApp <|> typeUnambiguous - whitespace ; arr <- optionMaybe arrow ; whitespace - case arr of Just _ -> LambdaPT t1 <$> typeExpr - Nothing -> return t1 - -typeConstructor :: (Monad m) => ParsecT [Char] u m (String, [ParseType]) -typeConstructor = (,) <$> capVar <*> spacePrefix (typeSimple <|> typeUnambiguous) - -datatype :: (Monad m) => ParsecT [Char] u m ([String], [Expr], GuidCounter [Type]) -datatype = do - reserved "data" <?> "datatype definition (data T = A | B | ...)" - forcedWS ; name <- capVar ; args <- spacePrefix lowVar - whitespace ; string "=" ; whitespace - tcs <- pipeSep1 typeConstructor - return $ (map fst tcs , map toFunc tcs , toTypes name args tcs) - -beta = liftM VarT guid - -toFunc (name,args) = foldr Lambda (Data name $ map Var argNames) argNames - where argNames = map (("a"++) . show) [1..length args] - -toTypes name args constructors = do - pairs <- mapM (\x -> (,) x `liftM` guid) args - return $ map (toType pairs . ADT name $ map (VarT . snd) pairs) constructors - -toType pairs outType (name,args) = - foldr (==>) outType (map toT args) - where toT (LambdaPT t1 t2) = toT t1 ==> toT t2 - toT (ADTPT name args) = ADT name $ map toT args - toT (VarPT x@(c:_)) - | isLower c = VarT . fromMaybe (-1) $ lookup x pairs - | otherwise = case x of "Int" -> IntT - "Number" -> IntT - "String" -> StringT - "Char" -> CharT - "Bool" -> BoolT - _ -> ADT x [] +module ParseTypes where++import Ast+import Control.Applicative ((<$>),(<*>))+import Control.Monad (liftM)+import Data.Char (isUpper,isLower)+import Data.Maybe (fromMaybe)+import Data.List (lookup)+import Text.Parsec++import ParseLib+import Types hiding (string,parens)+import Guid++data ParseType = VarPT String+ | LambdaPT ParseType ParseType+ | ADTPT String [ParseType]++listPT t = ADTPT "List" [t]+tuplePT ts = ADTPT ("Tuple" ++ show (length ts)) ts++typeVar :: (Monad m) => ParsecT [Char] u m ParseType+typeVar = VarPT <$> lowVar <?> "type variable"++typeList :: (Monad m) => ParsecT [Char] u m ParseType+typeList = listPT <$> braces typeExpr++typeTuple :: (Monad m) => ParsecT [Char] u m ParseType+typeTuple = do ts <- parens (commaSep typeExpr)+ return $ case ts of { [t] -> t ; _ -> tuplePT ts }++typeUnambiguous :: (Monad m) => ParsecT [Char] u m ParseType+typeUnambiguous = typeList <|> typeTuple++typeSimple :: (Monad m) => ParsecT [Char] u m ParseType+typeSimple = VarPT <$> var++typeApp :: (Monad m) => ParsecT [Char] u m ParseType+typeApp = do name <- capVar <?> "type constructor"+ args <- spacePrefix (typeUnambiguous <|> typeSimple)+ return $ case args of+ [] -> VarPT name+ _ -> ADTPT name args++typeExpr :: (Monad m) => ParsecT [Char] u m ParseType+typeExpr = do+ t1 <- typeVar <|> typeApp <|> typeUnambiguous+ whitespace ; arr <- optionMaybe arrow ; whitespace+ case arr of Just _ -> LambdaPT t1 <$> typeExpr+ Nothing -> return t1++typeConstructor :: (Monad m) => ParsecT [Char] u m (String, [ParseType])+typeConstructor = (,) <$> (capVar <?> "another type constructor") <*> spacePrefix (typeSimple <|> typeUnambiguous)++datatype :: (Monad m) => ParsecT [Char] u m ([String], [Expr], GuidCounter [Type])+datatype = do+ reserved "data" <?> "datatype definition (data T = A | B | ...)"+ forcedWS ; name <- capVar <?> "name of data-type" ; args <- spacePrefix lowVar+ whitespace ; string "=" ; whitespace+ tcs <- pipeSep1 typeConstructor+ return $ (map fst tcs , map toFunc tcs , toTypes name args tcs)++beta = liftM VarT guid++toFunc (name,args) = foldr Lambda (Data name $ map Var argNames) argNames+ where argNames = map (("a"++) . show) [1..length args]++toTypes name args constructors = do+ pairs <- mapM (\x -> (,) x `liftM` guid) args+ return $ map (toType pairs . ADT name $ map (VarT . snd) pairs) constructors++toType pairs outType (name,args) =+ foldr (==>) outType (map toT args)+ where toT (LambdaPT t1 t2) = toT t1 ==> toT t2+ toT (ADTPT name args) = ADT name $ map toT args+ toT (VarPT x@(c:_))+ | isLower c = VarT . fromMaybe (-1) $ lookup x pairs+ | otherwise = case x of "Int" -> IntT+ "Number" -> IntT+ "String" -> StringT+ "Char" -> CharT+ "Bool" -> BoolT+ _ -> ADT x []
src/Parse/Parser.hs view
@@ -1,4 +1,4 @@-module Parser (toDefs) where +module Parser (parseProgram) where import Ast import Control.Applicative ((<$>), (<*>)) @@ -8,122 +8,32 @@ import Text.Parsec hiding (newline,spaces) import ParseLib -import Patterns -import Binops +import ParseExpr import ParseTypes - -import Guid -import Types (Type (VarT)) - --------- Basic Terms -------- - -numTerm :: (Monad m) => ParsecT [Char] u m Expr -numTerm = liftM (Number . read) (many1 digit) <?> "number" - -strTerm :: (Monad m) => ParsecT [Char] u m Expr -strTerm = liftM Str . expecting "string" . betwixt '"' '"' . many $ - backslashed <|> satisfy (/='"') - -varTerm :: (Monad m) => ParsecT [Char] u m Expr -varTerm = toVar <$> var <?> "variable" - -toVar v = case v of "True" -> Boolean True - "False" -> Boolean False - _ -> Var v - -chrTerm :: (Monad m) => ParsecT [Char] u m Expr -chrTerm = Chr <$> betwixt '\'' '\'' (backslashed <|> satisfy (/='\'')) - <?> "character" - - --------- Complex Terms -------- - -listTerm = braces $ choice - [ try $ do { lo <- expr; whitespace; string ".." ; whitespace - ; Range lo <$> expr } - , list <$> commaSep expr - ] - -parensTerm = parens $ choice - [ do op <- anyOp - return . Lambda "x" . Lambda "y" $ Binop op (Var "x") (Var "y") - , do es <- commaSep expr - return $ case es of { [e] -> e; _ -> tuple es } - ] - -term = choice [ numTerm, strTerm, chrTerm - , accessible varTerm - , listTerm, parensTerm ] - <?> "basic term (4, x, 'c', etc.)" - --------- Applications -------- - -appExpr = do - tlist <- spaceSep1 term - return $ case tlist of - t:[] -> t - t:ts -> foldl' App t ts - --------- Normal Expressions -------- - -binaryExpr = binops appExpr anyOp - -ifExpr = do reserved "if" ; whitespace ; e1 <- expr ; whitespace - reserved "then" ; whitespace ; e2 <- expr ; (whitespace <?> "an 'else' branch") - reserved "else" <?> "an 'else' branch" ; whitespace ; If e1 e2 <$> expr - -lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function" - whitespace - args <- spaceSep1 patternTerm - whitespace ; arrow ; whitespace - e <- expr - return $ makeFunction args e - -assignExpr = do - patterns <- - choice [ try $ do v <- PVar <$> lowVar - notFollowedBy (whitespace >> char ':') - (v:) <$> spacePrefix patternTerm - , (:[]) <$> patternExpr - ] <?> "the definition of a variable (x = ...)" - whitespace; string "="; whitespace; exp <- expr - flattenPatterns patterns exp - -letExpr = do - reserved "let" - brace <- optionMaybe . try $ do - whitespace - char '{' <?> "a set of definitions { x = ... ; y = ... }" - case brace of - Nothing -> do whitespace; ds <- assignExpr - whitespace; reserved "in"; whitespace; Let ds <$> expr - Just '{' -> do whitespace ; dss <- semiSep1 assignExpr ; whitespace - string "}" <?> "closing bracket '}'" - whitespace; reserved "in"; whitespace; e <- expr - return $ Let (concat dss) e - -caseExpr = do - reserved "case"; whitespace; e <- expr; whitespace; reserved "of"; whitespace - Case e <$> brackets (semiSep1 (case_ <?> "cases { x -> ... }")) - where case_ = do p <- patternExpr; whitespace; arrow; whitespace - (,) p <$> expr +import ParseModules -expr = choice [ ifExpr, letExpr, caseExpr, lambdaExpr, binaryExpr ] <?> "expression" - -def = do (fs,es) <- unzip <$> assignExpr - return (fs, es, mapM (\_ -> liftM VarT guid) fs) +freshDef = commitIf (freshLine >> (letter <|> char '_')) $ do + freshLine + datatype <|> def <?> "another datatype or variable definition" -defs1 = do optional freshLine - d <- datatype <|> def - (d:) <$> many (try (try freshLine >> (datatype <|> def))) +defs1 = do d <- datatype <|> def <?> "at least one datatype or variable definition" + (d:) <$> many freshDef defs = do (fss,ess,tss) <- unzip3 <$> defs1 - let (fs,es,ts) = (concat fss, concat ess, concat `liftM` sequence tss) + return (concat fss, concat ess, concat `liftM` sequence tss) + +program = do + optional freshLine + (names,exports) <- option ([],[]) (moduleDef `followedBy` freshLine) + is <- (do try (lookAhead $ reserved "import") + imports `followedBy` freshLine) <|> return [] + (vs,es,ts) <- defs optional freshLine ; optional spaces ; eof - return (Let (zip fs es) (Var "main"), liftM (zip fs) ts) + return (Module names exports is $ zip vs es, zip vs `liftM` ts) -toDefs source = case parse defs "" source of - Right result -> Right result - Left err -> Left $ "Parse error at " ++ show err +parseProgram source = + case parse program "" source of + Right result -> Right result + Left err -> Left $ "Parse error at " ++ show err
src/Parse/Patterns.hs view
@@ -1,53 +1,53 @@-module Patterns (patternTerm, patternExpr, makeFunction, flattenPatterns) where - -import Ast -import Data.Char (isUpper) -import Control.Applicative ((<$>)) -import Control.Monad -import Text.Parsec -import ParseLib - -patternBasic :: Monad m => ParsecT [Char] u m Pattern -patternBasic = - choice [ char '_' >> return PAnything - , do x@(c:_) <- var - if isUpper c then PData x <$> spacePrefix patternTerm - else return $ PVar x - ] - -patternTuple :: Monad m => ParsecT [Char] u m Pattern -patternTuple = do ps <- parens (commaSep patternExpr) - return $ case ps of { [p] -> p; _ -> ptuple ps } - -patternList :: Monad m => ParsecT [Char] u m Pattern -patternList = plist <$> braces (commaSep patternExpr) - -patternTerm :: Monad m => ParsecT [Char] u m Pattern -patternTerm = patternTuple <|> patternList <|> patternBasic <?> "pattern" - -patternExpr :: Monad m => ParsecT [Char] u m Pattern -patternExpr = foldl1 pcons <$> consSep1 patternTerm <?> "pattern" - - - -makeFunction args body = foldr func body args - where func PAnything e = Lambda "_" e - func (PVar x) e = Lambda x e - func p e = "t" `Lambda` Case (Var "t") [(p,e)] - -flattenPatterns (PVar f : args) exp = return [(f, makeFunction args exp)] -flattenPatterns [p] exp = return $ matchSingle p exp p -flattenPatterns ps _ = - fail $ "Pattern (" ++ unwords (map show ps) ++ - ") cannot be used on the left-hand side of an assign statement." - -matchSingle pat exp p@(PData _ ps) = - (v, exp) : concatMap (matchSingle p $ Var v) ps - where v = "'" ++ getName p -matchSingle pat exp (PVar x) = [ (x, Case exp [(pat,Var x)]) ] -matchSingle pat exp PAnything = [] - -getName (PData n ps) = n ++ concatMap getName ps -getName (PAnything) = "_" -getName (PVar x) = x - +module Patterns (patternTerm, patternExpr, makeFunction, flattenPatterns) where++import Ast+import Data.Char (isUpper)+import Control.Applicative ((<$>))+import Control.Monad+import Text.Parsec+import ParseLib++patternBasic :: Monad m => ParsecT [Char] u m Pattern+patternBasic =+ choice [ char '_' >> return PAnything+ , do x@(c:_) <- var+ if isUpper c then PData x <$> spacePrefix patternTerm+ else return $ PVar x+ ]++patternTuple :: Monad m => ParsecT [Char] u m Pattern+patternTuple = do ps <- parens (commaSep patternExpr)+ return $ case ps of { [p] -> p; _ -> ptuple ps }++patternList :: Monad m => ParsecT [Char] u m Pattern+patternList = plist <$> braces (commaSep patternExpr)++patternTerm :: Monad m => ParsecT [Char] u m Pattern+patternTerm = patternTuple <|> patternList <|> patternBasic <?> "pattern"++patternExpr :: Monad m => ParsecT [Char] u m Pattern+patternExpr = foldl1 pcons <$> consSep1 patternTerm <?> "pattern"++++makeFunction args body = foldr func body args+ where func PAnything e = Lambda "_" e+ func (PVar x) e = Lambda x e+ func p e = "t" `Lambda` Case (Var "t") [(p,e)]++flattenPatterns (PVar f : args) exp = return [(f, makeFunction args exp)]+flattenPatterns [p] exp = return $ matchSingle p exp p+flattenPatterns ps _ = + fail $ "Pattern (" ++ unwords (map show ps) +++ ") cannot be used on the left-hand side of an assign statement."++matchSingle pat exp p@(PData _ ps) =+ (v, exp) : concatMap (matchSingle p $ Var v) ps+ where v = "'" ++ getName p+matchSingle pat exp (PVar x) = [ (x, Case exp [(pat,Var x)]) ]+matchSingle pat exp PAnything = []++getName (PData n ps) = n ++ concatMap getName ps+getName (PAnything) = "_"+getName (PVar x) = x+