diff --git a/docs/beautify.js b/docs/beautify.js --- a/docs/beautify.js +++ b/docs/beautify.js @@ -58,6 +58,10 @@ +function $jsBeautify(source,indentSize) { + return js_beautify(source, { indent_size: indentSize }); +} + function js_beautify(js_source_text, options) { var input, output, token_text, last_type, last_text, last_last_text, last_word, flags, flag_store, indent_string; diff --git a/docs/home.hs b/docs/home.hs new file mode 100644 --- /dev/null +++ b/docs/home.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | The home page script: +-- +-- 1) Make sure that the language samples are highlighted. +-- 2) Add a show/hide button for the JS output on all samples. +-- 3) For code samples that are too large, hide them. +-- +-- Because dogfood. This is not necessarily a good example, indeed, it +-- may very well be a very bad example of how to write client +-- code. But that's the point, really. Even the quick scripts that +-- you'd just whip up in JS should be also done in Fay. Alright? +-- + +module Home (main) where + +import Language.Fay.FFI +import Language.Fay.Prelude + +-- | Main entry point. +main :: Fay () +main = do + ready (jquery [thedocument]) $ do + samples <- query ".language-javascript" + forM_ samples $ \this -> + let sample = jquery [this] + in do text <- getText sample + setText sample + (beautify text 2) + setTabReplace hljs " " + initHighlightingOnLoad hljs + wrapwidth <- query ".wrap" >>= getWidth . jquery + each ".example" $ \this -> do + tr <- getFind this "tr" + left <- getFind tr "td" >>= getFirst + addClass left "left" + right <- getNext left + toggle <- makeElement "Show JavaScript" + toggleButton <- return $ do + visible <- getIs right ":visible" + if visible + then do setText toggle "Hide JavaScript" + swapClasses toggle "toggle-hide" "toggle-show" + else do setText toggle "Show JavaScript" + swapClasses toggle "toggle-show" "toggle-hide" + setClick toggle $ fadeToggle right $ toggleButton + width <- getWidth tr + when (width > wrapwidth + 20*wrapwidth/100) $ hide right + toggleButton + panel <- getFind left ".panel" + prepend panel toggle + return () + +-------------------------------------------------------------------------------- +-- Window object + +-- | Console log. +print :: (Show a,Foreign a) => a -> Fay () +print = foreignFay "console.log" FayNone + +-- | Pop-up an alert. +alert :: String -> Fay () +alert = foreignFay "window.alert" FayNone + +-------------------------------------------------------------------------------- +-- DOM + +data Element +instance Foreign Element +instance Show Element + +-- | The document. +thedocument :: Element +thedocument = foreignValue "window.document" FayNone + +-------------------------------------------------------------------------------- +-- jQuery + +data JQuery +instance Foreign JQuery +instance Show JQuery + +-- | Make a jQuery object out of an element. +jquery :: [Element] -> JQuery +jquery = foreignPure "window['jQuery']" FayNone + +-- | Bind a handler for when the element is ready. +ready :: JQuery -> Fay () -> Fay () +ready = foreignMethodFay "ready" FayNone + +-- | Query for elements. +query :: String -> Fay [Element] +query = foreignFay "window['jQuery']" FayList + +-- | Set the text of the given object. +setText :: JQuery -> String -> Fay () +setText = foreignMethodFay "text" FayNone + +-- | Set the click of the given object. +setClick :: JQuery -> Fay () -> Fay () +setClick = foreignMethodFay "click" FayNone + +-- | Toggle the visibility of an element, faded. +fadeToggle :: JQuery -> Fay () -> Fay () +fadeToggle = foreignMethodFay "fadeToggle" FayNone + +-- | Hide an element. +hide :: JQuery -> Fay () +hide = foreignMethodFay "hide" FayNone + +-- | Add a class to the given object. +addClass :: JQuery -> String -> Fay () +addClass = foreignMethodFay "addClass" FayNone + +-- | Remove a class from the given object. +removeClass :: JQuery -> String -> Fay () +removeClass = foreignMethodFay "removeClass" FayNone + +-- | Swap the given classes on the object. +swapClasses :: JQuery -> String -> String -> Fay () +swapClasses obj addme removeme = do + addClass obj addme + removeClass obj removeme + +-- | Get the text of the given object. +getText :: JQuery -> Fay String +getText = foreignMethodFay "text" FayString + +-- | Get the text of the given object. +getIs :: JQuery -> String -> Fay Bool +getIs = foreignMethodFay "is" FayBool + +-- | Get the next of the given object. +getNext :: JQuery -> Fay JQuery +getNext = foreignMethodFay "next" FayNone + +-- | Get the first of the given object. +getFirst :: JQuery -> Fay JQuery +getFirst = foreignMethodFay "first" FayNone + +-- | Get the find of the given object. +getFind :: JQuery -> String -> Fay JQuery +getFind = foreignMethodFay "find" FayNone + +-- | Prepend an element to this one. +prepend :: JQuery -> JQuery -> Fay JQuery +prepend = foreignMethodFay "prepend" FayNone + +-- | Make a new element. +makeElement :: String -> Fay JQuery +makeElement = foreignFay "window['jQuery']" FayNone + +-- | Get the width of the given object. +getWidth :: JQuery -> Fay Double +getWidth = foreignMethodFay "width" FayNone + +-- | For each element in a query set do something. +each :: String -> (JQuery -> Fay ()) -> Fay () +each q go = do + results <- query q + forM_ results $ \result -> go (jquery [result]) + +-------------------------------------------------------------------------------- +-- Pretty printing / highlighting + +-- | Pretty print the given JS code. +beautify :: String -- ^ The JS code. + -> Double -- ^ The indentation level. + -> String -- ^ The reformatted JS code. +beautify = foreignPure "$jsBeautify" FayString + +data Highlighter +instance Foreign Highlighter + +-- | Get the highlighter. +hljs :: Highlighter +hljs = foreignValue "window['hljs']" FayNone + +-- | Init syntax highlighting on load. +initHighlightingOnLoad :: Highlighter -> Fay () +initHighlightingOnLoad = foreignMethodFay "initHighlightingOnLoad" FayNone + +-- | Init syntax highlighting on load. +setTabReplace :: Highlighter -> String -> Fay () +setTabReplace = foreignSetProp "tabReplace" diff --git a/docs/home.js b/docs/home.js --- a/docs/home.js +++ b/docs/home.js @@ -1,56 +1,383 @@ -$(document).ready(function(){ - $('.language-javascript').each(function(){ - $(this).text(js_beautify($(this).text(), - { indent_size: 2})); +/** @constructor +*/ +var Home = function(){ +var True = true; +var False = false; + +/******************************************************************************* +* Thunks. +*/ + +// Force a thunk (if it is a thunk) until WHNF. +function _(thunkish,nocache){ + while (thunkish instanceof $) { + thunkish = thunkish.force(nocache); + } + return thunkish; +} + +// Apply a function to arguments (see method2 in Fay.hs). +function __(){ + var f = arguments[0]; + for (var i = 1, len = arguments.length; i < len; i++) { + f = (f instanceof $? _(f) : f)(arguments[i]); + } + return f; +} + +// Thunk object. +function $(value){ + this.forced = false; + this.value = value; +} + +// Force the thunk. +$.prototype.force = function(nocache){ + return nocache + ? this.value() + : this.forced + ? this.value + : (this.forced = true, this.value = this.value()); +}; + +/******************************************************************************* +* Constructors. +*/ + +// A constructor. +function Fay$$Constructor(){ + this.name = arguments[0]; + this.fields = Array.prototype.slice.call(arguments,1); +} + +// Eval in the context of the Haskell bindings. +function Fay$$eval(str){ + return eval(str); +} + +/******************************************************************************* +* Monad. +*/ + +function Fay$$Monad(value){ + this.value = value; +} + +// >> +function Fay$$then(a){ + return function(b){ + return new $(function(){ + _(a,true); + return b; }); - hljs.tabReplace = ' '; - hljs.initHighlightingOnLoad(); - // Creates tabs from the code samples. - // $('.example').each(function(){ - // var example = $(this); - // var tabs = $('
'); - // example.children('.lang').each(function(){ - // var title = $(this).clone().click(function(){ - // example.find('.pre').hide(); - // pre.show(); - // tabs.children().removeClass('tab-title-current'); - // title.addClass('tab-title-current'); - // }); - // title.addClass('tab-title'); - // var pre = $(this).next(); - // tabs.append(title); - // }).remove(); - // example.prepend(tabs); - // example.find('.pre').hide().first().show(); - // tabs.children().first().addClass('tab-title-current'); - // }); - var wrapwidth = $('.wrap').width(); - $('.example').each(function(){ - var tr = $(this).find('tr'); - var left = tr.find('td').first(); - left.addClass('left'); - var right = left.next(); - var toggle = $('Show JavaScript'); - function toggleButton(){ - if(right.is(':visible')) { - toggle.text("Hide JavaScript"); - toggle.addClass('toggle-hide'); - toggle.removeClass('toggle-show'); - } - else { - toggle.text("Show JavaScript"); - toggle.addClass('toggle-show'); - toggle.removeClass('toggle-hide'); - } - } - toggle.click(function(){ - right.fadeToggle(function(){ - toggleButton(); - }); - }); - if(tr.width() > wrapwidth + (20*wrapwidth/100)) - right.hide(); - toggleButton(); - left.find('.panel').prepend(toggle); + }; +} + +// >>= +function Fay$$bind(m){ + return function(f){ + return new $(function(){ + var monad = _(m,true); + return f(monad.value); }); -}); + }; +} + +var Fay$$unit = null; + +// return +function Fay$$return(a){ + return new Fay$$Monad(a); +} + +/******************************************************************************* +* FFI. +*/ + +// Serialize a Fay object to JS. +function Fay$$serialize(type,obj){ + type = _(type); + if(type) type = type[0].name; + if(type == "JsType"){ + return function(){ + return _(obj,true).value; + }; + } else { + obj = _(obj); + if(type == "StringType" || + (obj instanceof Fay$$Cons && typeof obj.car == 'string')){ + var str = ""; + while(obj instanceof Fay$$Cons) { + str += obj.car; + obj = _(obj.cdr); + } + return str; + } else if(type == "FunctionType" || typeof obj == 'function'){ + return function(){ + var out = obj; + for (var len = arguments.length, i = 0; i < len; i++){ + if(typeof out != 'function') { + throw "Wrong number of arguments for callback: " + arguments.toString(); + } + out = out(arguments[i]); + } + return _(out,true); + }; + } else if(type == "ListType" || (obj instanceof Fay$$Cons)){ + var arr = []; + while(obj instanceof Fay$$Cons) { + arr.push(Fay$$serialize(null,obj.car)); + obj = _(obj.cdr); + } + return arr; + } // else if(type == "BoolType || obj == _(True) || obj == _(False)) { + // return obj == _(True); + // } + else { + return obj; + } + } +} + +// Encode a value to a Show representation +function Fay$$encodeShow(x){ + if (x instanceof $) x = _(x); + if (x instanceof Array) { + if (x.length == 0) { + return "[]"; + } else { + if (x[0] instanceof Fay$$Constructor) { + if(x[0].fields.length > 0) { + var args = x.slice(1); + var fieldNames = x[0].fields; + return "(" + x[0].name + " { " + args.map(function(x,i){ + return fieldNames[i] + ' = ' + Fay$$encodeShow(x); + }).join(", ") + " })"; + } else { + var args = x.slice(1); + return "(" + [x[0].name].concat(args.map(Fay$$encodeShow)).join(" ") + ")"; + } + } else { + return "[" + x.map(Fay$$encodeShow).join(",") + "]"; + } + } + } else if (typeof x == 'string') { + return JSON.stringify(x); + } else if(x instanceof Fay$$Cons) { + return Fay$$encodeShow(Fay$$serialize(ListType,x)); + } else if(x == null) { + return '[]'; + } else { + return x.toString(); + } +} + +// Unserialize an object from JS to Fay. +function Fay$$unserialize(typ,obj){ + if(typ == 'string' || typ == 'array' || typ == 'list') + return Fay$$list(obj); + else if(typ == 'bool') + return obj? True : False; + else if(typ == 'data') { + alert('Time to unserialize a data record!'); + } + else return obj; +} + +/******************************************************************************* +* Lists. +*/ + +// Cons object. +function Fay$$Cons(car,cdr){ + this.car = car; + this.cdr = cdr; +} + +// Make a list. +function Fay$$list(xs){ + var out = null; + for(var i=xs.length-1; i>=0;i--) + out = new Fay$$Cons(xs[i],out); + return out; +} + +// Built-in list cons. +function Fay$$cons(x){ + return function(y){ + return new Fay$$Cons(x,y); + }; +} + +// List index. +function Fay$$index(index){ + return function(list){ + for(var i = 0; i < index; i++) { + list = _(list).cdr; + } + return list.car; + }; +} + +/******************************************************************************* +* Numbers. +*/ + +// Built-in *. +function Fay$$mult(x){ + return function(y){ + return _(x) * _(y); + }; +} + +// Built-in +. +function Fay$$add(x){ + return function(y){ + return _(x) + _(y); + }; +} + +// Built-in -. +function Fay$$sub(x){ + return function(y){ + return _(x) - _(y); + }; +} + +// Built-in /. +function Fay$$div(x){ + return function(y){ + return _(x) / _(y); + }; +} + +/******************************************************************************* +* Booleans. +*/ + +// Are two values equal? +function Fay$$equal(lit1,lit2){ + // Simple case + lit1 = _(lit1); + lit2 = _(lit2); + if(lit1 === lit2) { + return true; + } + // General case + if(lit1 instanceof Array) { + if(lit1.length!=lit2.length) return false; + for(var len = lit1.length, i = 0; i < len; i++) { + if(!Fay$$equal(lit1[i],lit2[i])) + return false; + } + return true; + } else if (lit1 instanceof Fay$$Cons) { + while(lit1 instanceof Fay$$Cons && lit2 instanceof Fay$$Cons && Fay$$equal(lit1.car,lit2.car)) + lit1 = lit1.cdr, lit2 = lit2.cdr; + return (lit1 === null && lit2 === null); + } else return false; +} + +// Built-in ==. +function Fay$$eq(x){ + return function(y){ + return Fay$$equal(x,y); + }; +} + +// Built-in /=. +function Fay$$neq(x){ + return function(y){ + return !(Fay$$equal(x,y)); + }; +} + +// Built-in >. +function Fay$$gt(x){ + return function(y){ + return _(x) > _(y); + }; +} + +// Built-in <. +function Fay$$lt(x){ + return function(y){ + return _(x) < _(y); + }; +} + +// Built-in >=. +function Fay$$gte(x){ + return function(y){ + return _(x) >= _(y); + }; +} + +// Built-in <=. +function Fay$$lte(x){ + return function(y){ + return _(x) <= _(y); + }; +} + +// Built-in &&. +function Fay$$and(x){ + return function(y){ + return _(x) && _(y); + }; +} + +// Built-in ||. +function Fay$$or(x){ + return function(y){ + return _(x) || _(y); + }; +} + +/******************************************************************************* +* Mutable references. +*/ + +// Make a new mutable reference. +function Fay$$Ref(x){ + this.value = x; +} + +// Write to the ref. +function Fay$$writeRef(ref,x){ + ref.value = x; +} + +// Get the value from the ref. +function Fay$$readRef(ref,x){ + return ref.value; +} + +/******************************************************************************* +* Dates. +*/ +function Fay$$date(str){ + return window.Date.parse(str); +} + +/******************************************************************************* +* Application code. +*/ + + +var main = new $(function(){return __($36$,__(ready,__(jquery,Fay$$list([thedocument]))),__(Fay$$bind,__(query,Fay$$list(".language-javascript")),function($_a){var samples = $_a;return __(Fay$$then,__($36$,__(forM_,samples),function($_a){var _$this = $_a;return (function(){var sample = new $(function(){return __(jquery,Fay$$list([_$this]));});return __(Fay$$bind,__(getText,sample),function($_a){var text = $_a;return __(setText,sample,__(beautify,text,2));});})();}),__(Fay$$then,__(setTabReplace,hljs,Fay$$list(" ")),__(Fay$$then,__(initHighlightingOnLoad,hljs),__(Fay$$bind,__(Fay$$bind,__(query,Fay$$list(".wrap")),__($46$,getWidth,jquery)),function($_a){var wrapwidth = $_a;return __($36$,__(each,Fay$$list(".example")),function($_a){var _$this = $_a;return __(Fay$$bind,__(getFind,_$this,Fay$$list("tr")),function($_a){var tr = $_a;return __(Fay$$bind,__(Fay$$bind,__(getFind,tr,Fay$$list("td")),getFirst),function($_a){var left = $_a;return __(Fay$$then,__(addClass,left,Fay$$list("left")),__(Fay$$bind,__(getNext,left),function($_a){var right = $_a;return __(Fay$$bind,__(makeElement,Fay$$list("Show JavaScript")),function($_a){var toggle = $_a;return __(Fay$$bind,__($36$,Fay$$return,__(Fay$$bind,__(getIs,right,Fay$$list(":visible")),function($_a){var visible = $_a;return _(visible) ? __(Fay$$then,__(setText,toggle,Fay$$list("Hide JavaScript")),__(swapClasses,toggle,Fay$$list("toggle-hide"),Fay$$list("toggle-show"))) : __(Fay$$then,__(setText,toggle,Fay$$list("Show JavaScript")),__(swapClasses,toggle,Fay$$list("toggle-show"),Fay$$list("toggle-hide")));})),function($_a){var toggleButton = $_a;return __(Fay$$then,__($36$,__(setClick,toggle),__($36$,__(fadeToggle,right),toggleButton)),__(Fay$$bind,__(getWidth,tr),function($_a){var width = $_a;return __(Fay$$then,__($36$,__(when,_(width) > _(_(wrapwidth) + _(_(20 * _(wrapwidth)) / 100))),__(hide,right)),__(Fay$$then,toggleButton,__(Fay$$bind,__(getFind,left,Fay$$list(".panel")),function($_a){var panel = $_a;return __(Fay$$then,__(prepend,panel,toggle),__(Fay$$return,Fay$$unit));})));}));});});}));});});});}))));}));});var print = function($_a){return new $(function(){return new Fay$$Monad(Fay$$unserialize("",console.log(Fay$$serialize(UnknownType,$_a))));});};var alert = function($_a){return new $(function(){return new Fay$$Monad(Fay$$unserialize("",window.alert(Fay$$serialize(StringType,$_a))));});};var thedocument = new $(function(){return Fay$$unserialize("",window.document);});var jquery = function($_a){return new $(function(){return Fay$$unserialize("",window['jQuery'](Fay$$serialize(ListType,$_a)));});};var ready = function($_a){return function($_b){return new $(function(){return new Fay$$Monad(Fay$$unserialize("",_($_a)['ready'](Fay$$serialize(JsType,$_b))));});};};var query = function($_a){return new $(function(){return new Fay$$Monad(Fay$$unserialize("list",window['jQuery'](Fay$$serialize(StringType,$_a))));});};var setText = function($_a){return function($_b){return new $(function(){return new Fay$$Monad(Fay$$unserialize("",_($_a)['text'](Fay$$serialize(StringType,$_b))));});};};var setClick = function($_a){return function($_b){return new $(function(){return new Fay$$Monad(Fay$$unserialize("",_($_a)['click'](Fay$$serialize(JsType,$_b))));});};};var fadeToggle = function($_a){return function($_b){return new $(function(){return new Fay$$Monad(Fay$$unserialize("",_($_a)['fadeToggle'](Fay$$serialize(JsType,$_b))));});};};var hide = function($_a){return new $(function(){return new Fay$$Monad(Fay$$unserialize("",_($_a)['hide']()));});};var addClass = function($_a){return function($_b){return new $(function(){return new Fay$$Monad(Fay$$unserialize("",_($_a)['addClass'](Fay$$serialize(StringType,$_b))));});};};var removeClass = function($_a){return function($_b){return new $(function(){return new Fay$$Monad(Fay$$unserialize("",_($_a)['removeClass'](Fay$$serialize(StringType,$_b))));});};};var swapClasses = function($_a){return function($_b){return function($_c){return new $(function(){var removeme = $_c;var addme = $_b;var obj = $_a;return __(Fay$$then,__(addClass,obj,addme),__(removeClass,obj,removeme));});};};};var getText = function($_a){return new $(function(){return new Fay$$Monad(Fay$$unserialize("string",_($_a)['text']()));});};var getIs = function($_a){return function($_b){return new $(function(){return new Fay$$Monad(Fay$$unserialize("bool",_($_a)['is'](Fay$$serialize(StringType,$_b))));});};};var getNext = function($_a){return new $(function(){return new Fay$$Monad(Fay$$unserialize("",_($_a)['next']()));});};var getFirst = function($_a){return new $(function(){return new Fay$$Monad(Fay$$unserialize("",_($_a)['first']()));});};var getFind = function($_a){return function($_b){return new $(function(){return new Fay$$Monad(Fay$$unserialize("",_($_a)['find'](Fay$$serialize(StringType,$_b))));});};};var prepend = function($_a){return function($_b){return new $(function(){return new Fay$$Monad(Fay$$unserialize("",_($_a)['prepend'](Fay$$serialize(UnknownType,$_b))));});};};var makeElement = function($_a){return new $(function(){return new Fay$$Monad(Fay$$unserialize("",window['jQuery'](Fay$$serialize(StringType,$_a))));});};var getWidth = function($_a){return new $(function(){return new Fay$$Monad(Fay$$unserialize("",_($_a)['width']()));});};var each = function($_a){return function($_b){return new $(function(){var go = $_b;var q = $_a;return __(Fay$$bind,__(query,q),function($_a){var results = $_a;return __($36$,__(forM_,results),function($_a){var result = $_a;return __(go,__(jquery,Fay$$list([result])));});});});};};var beautify = function($_a){return function($_b){return new $(function(){return Fay$$unserialize("string",$jsBeautify(Fay$$serialize(StringType,$_a),Fay$$serialize(DoubleType,$_b)));});};};var hljs = new $(function(){return Fay$$unserialize("",window['hljs']);});var initHighlightingOnLoad = function($_a){return new $(function(){return new Fay$$Monad(Fay$$unserialize("",_($_a)['initHighlightingOnLoad']()));});};var setTabReplace = function($_a){return function($_b){return new $(function(){return new Fay$$Monad((_($_a)['tabReplace'] = Fay$$serialize(StringType,$_b)));});};};var DateType = new $(function(){return [new Fay$$Constructor("DateType")];});var FunctionType = new $(function(){return [new Fay$$Constructor("FunctionType")];});var JsType = new $(function(){return [new Fay$$Constructor("JsType")];});var StringType = new $(function(){return [new Fay$$Constructor("StringType")];});var DoubleType = new $(function(){return [new Fay$$Constructor("DoubleType")];});var ListType = new $(function(){return [new Fay$$Constructor("ListType")];});var BoolType = new $(function(){return [new Fay$$Constructor("BoolType")];});var UnknownType = new $(function(){return [new Fay$$Constructor("UnknownType")];});var Just = function(slot1){return new $(function(){return [new Fay$$Constructor("Just"),slot1];});};var Nothing = new $(function(){return [new Fay$$Constructor("Nothing")];});var show = function($_a){return new $(function(){return Fay$$unserialize("string",Fay$$encodeShow(Fay$$serialize(UnknownType,$_a)));});};var fromInteger = function($_a){return new $(function(){var x = $_a;return x;});};var fromRational = function($_a){return new $(function(){var x = $_a;return x;});};var snd = function($_a){return new $(function(){var x = Fay$$index(1)(_($_a));return x;throw ["unhandled case in Ident \"snd\"",[$_a]];});};var fst = function($_a){return new $(function(){var x = Fay$$index(0)(_($_a));return x;throw ["unhandled case in Ident \"fst\"",[$_a]];});};var find = function($_a){return function($_b){return new $(function(){var $_$_b = _($_b);if ($_$_b instanceof Fay$$Cons) {var x = $_$_b.car;var xs = $_$_b.cdr;var p = $_a;return _(__(p,x)) ? __(Just,x) : __(find,p,xs);}if (_($_b) === null) {var p = $_a;return Nothing;}throw ["unhandled case in Ident \"find\"",[$_a,$_b]];});};};var any = function($_a){return function($_b){return new $(function(){var $_$_b = _($_b);if ($_$_b instanceof Fay$$Cons) {var x = $_$_b.car;var xs = $_$_b.cdr;var p = $_a;return _(__(p,x)) ? true : __(any,p,xs);}if (_($_b) === null) {var p = $_a;return false;}throw ["unhandled case in Ident \"any\"",[$_a,$_b]];});};};var filter = function($_a){return function($_b){return new $(function(){var $_$_b = _($_b);if ($_$_b instanceof Fay$$Cons) {var x = $_$_b.car;var xs = $_$_b.cdr;var p = $_a;return _(__(p,x)) ? __(Fay$$cons,x,__(filter,p,xs)) : __(filter,p,xs);}if (_($_b) === null) {return null;}throw ["unhandled case in Ident \"filter\"",[$_a,$_b]];});};};var not = function($_a){return new $(function(){var p = $_a;return _(p) ? false : true;});};var _$null = function($_a){return new $(function(){if (_($_a) === null) {return true;}return false;});};var map = function($_a){return function($_b){return new $(function(){if (_($_b) === null) {return null;}var $_$_b = _($_b);if ($_$_b instanceof Fay$$Cons) {var x = $_$_b.car;var xs = $_$_b.cdr;var f = $_a;return __(Fay$$cons,__(f,x),__(map,f,xs));}throw ["unhandled case in Ident \"map\"",[$_a,$_b]];});};};var nub = function($_a){return new $(function(){var ls = $_a;return __(nub$39$,ls,null);});};var nub$39$ = function($_a){return function($_b){return new $(function(){if (_($_a) === null) {return null;}var ls = $_b;var $_$_a = _($_a);if ($_$_a instanceof Fay$$Cons) {var x = $_$_a.car;var xs = $_$_a.cdr;return _(__(elem,x,ls)) ? __(nub$39$,xs,ls) : __(Fay$$cons,x,__(nub$39$,xs,__(Fay$$cons,x,ls)));}throw ["unhandled case in Ident \"nub'\"",[$_a,$_b]];});};};var elem = function($_a){return function($_b){return new $(function(){var $_$_b = _($_b);if ($_$_b instanceof Fay$$Cons) {var y = $_$_b.car;var ys = $_$_b.cdr;var x = $_a;return _(__(Fay$$eq,x,y)) || _(__(elem,x,ys));}if (_($_b) === null) {return false;}throw ["unhandled case in Ident \"elem\"",[$_a,$_b]];});};};var GT = new $(function(){return [new Fay$$Constructor("GT")];});var LT = new $(function(){return [new Fay$$Constructor("LT")];});var EQ = new $(function(){return [new Fay$$Constructor("EQ")];});var sort = new $(function(){return __(sortBy,compare);});var compare = function($_a){return function($_b){return new $(function(){var y = $_b;var x = $_a;return _(_(x) > _(y)) ? GT : _(_(x) < _(y)) ? LT : EQ;});};};var sortBy = function($_a){return new $(function(){var cmp = $_a;return __(foldr,__(insertBy,cmp),null);});};var insertBy = function($_a){return function($_b){return function($_c){return new $(function(){if (_($_c) === null) {var x = $_b;return Fay$$list([x]);}var ys = $_c;var x = $_b;var cmp = $_a;return (function($_ys){var $_$_ys = _($_ys);if ($_$_ys instanceof Fay$$Cons) {var y = $_$_ys.car;var ys$39$ = $_$_ys.cdr;return (function($tmp){if ((_($tmp))[0].name === "GT") {return __(Fay$$cons,y,__(insertBy,cmp,x,ys$39$));}return __(Fay$$cons,x,ys);})(__(cmp,x,y));}return (function(){ throw (["unhandled case",$_ys]); })();})(ys);});};};};var when = function($_a){return function($_b){return new $(function(){var m = $_b;var p = $_a;return _(p) ? __(Fay$$then,m,__(Fay$$return,Fay$$unit)) : __(Fay$$return,Fay$$unit);});};};var enumFrom = function($_a){return new $(function(){var i = $_a;return __(Fay$$cons,i,__(enumFrom,_(i) + 1));});};var enumFromTo = function($_a){return function($_b){return new $(function(){var n = $_b;var i = $_a;return _(__(Fay$$eq,i,n)) ? Fay$$list([i]) : __(Fay$$cons,i,__(enumFromTo,_(i) + 1,n));});};};var zipWith = function($_a){return function($_b){return function($_c){return new $(function(){var $_$_c = _($_c);if ($_$_c instanceof Fay$$Cons) {var b = $_$_c.car;var bs = $_$_c.cdr;var $_$_b = _($_b);if ($_$_b instanceof Fay$$Cons) {var a = $_$_b.car;var as = $_$_b.cdr;var f = $_a;return __(Fay$$cons,__(f,a,b),__(zipWith,f,as,bs));}}return null;});};};};var zip = function($_a){return function($_b){return new $(function(){var $_$_b = _($_b);if ($_$_b instanceof Fay$$Cons) {var b = $_$_b.car;var bs = $_$_b.cdr;var $_$_a = _($_a);if ($_$_a instanceof Fay$$Cons) {var a = $_$_a.car;var as = $_$_a.cdr;return __(Fay$$cons,Fay$$list([a,b]),__(zip,as,bs));}}return null;});};};var flip = function($_a){return function($_b){return function($_c){return new $(function(){var y = $_c;var x = $_b;var f = $_a;return __(f,y,x);});};};};var maybe = function($_a){return function($_b){return function($_c){return new $(function(){if ((_($_c))[0].name === "Nothing") {var f = $_b;var m = $_a;return m;}if ((_($_c))[0].name === "Just") {var x = (_($_c))[1];var f = $_b;var m = $_a;return __(f,x);}throw ["unhandled case in Ident \"maybe\"",[$_a,$_b,$_c]];});};};};var $46$ = function($_a){return function($_b){return function($_c){return new $(function(){var x = $_c;var g = $_b;var f = $_a;return __(f,__(g,x));});};};};var $43$$43$ = function($_a){return function($_b){return new $(function(){var y = $_b;var x = $_a;return __(conc,x,y);});};};var $36$ = function($_a){return function($_b){return new $(function(){var x = $_b;var f = $_a;return __(f,x);});};};var conc = function($_a){return function($_b){return new $(function(){var ys = $_b;var $_$_a = _($_a);if ($_$_a instanceof Fay$$Cons) {var x = $_$_a.car;var xs = $_$_a.cdr;return __(Fay$$cons,x,__(conc,xs,ys));}var ys = $_b;if (_($_a) === null) {return ys;}throw ["unhandled case in Ident \"conc\"",[$_a,$_b]];});};};var concat = new $(function(){return __(foldr,conc,null);});var foldr = function($_a){return function($_b){return function($_c){return new $(function(){if (_($_c) === null) {var z = $_b;var f = $_a;return z;}var $_$_c = _($_c);if ($_$_c instanceof Fay$$Cons) {var x = $_$_c.car;var xs = $_$_c.cdr;var z = $_b;var f = $_a;return __(f,x,__(foldr,f,z,xs));}throw ["unhandled case in Ident \"foldr\"",[$_a,$_b,$_c]];});};};};var foldl = function($_a){return function($_b){return function($_c){return new $(function(){if (_($_c) === null) {var z = $_b;var f = $_a;return z;}var $_$_c = _($_c);if ($_$_c instanceof Fay$$Cons) {var x = $_$_c.car;var xs = $_$_c.cdr;var z = $_b;var f = $_a;return __(foldl,f,__(f,z,x),xs);}throw ["unhandled case in Ident \"foldl\"",[$_a,$_b,$_c]];});};};};var lookup = function($_a){return function($_b){return new $(function(){if (_($_b) === null) {var _key = $_a;return Nothing;}var $_$_b = _($_b);if ($_$_b instanceof Fay$$Cons) {var x = Fay$$index(0)(_($_$_b.car));var y = Fay$$index(1)(_($_$_b.car));var xys = $_$_b.cdr;var key = $_a;return _(__(Fay$$eq,key,x)) ? __(Just,y) : __(lookup,key,xys);}throw ["unhandled case in Ident \"lookup\"",[$_a,$_b]];});};};var intersperse = function($_a){return function($_b){return new $(function(){if (_($_b) === null) {return null;}var $_$_b = _($_b);if ($_$_b instanceof Fay$$Cons) {var x = $_$_b.car;var xs = $_$_b.cdr;var sep = $_a;return __(Fay$$cons,x,__(prependToAll,sep,xs));}throw ["unhandled case in Ident \"intersperse\"",[$_a,$_b]];});};};var prependToAll = function($_a){return function($_b){return new $(function(){if (_($_b) === null) {return null;}var $_$_b = _($_b);if ($_$_b instanceof Fay$$Cons) {var x = $_$_b.car;var xs = $_$_b.cdr;var sep = $_a;return __(Fay$$cons,sep,__(Fay$$cons,x,__(prependToAll,sep,xs)));}throw ["unhandled case in Ident \"prependToAll\"",[$_a,$_b]];});};};var intercalate = function($_a){return function($_b){return new $(function(){var xss = $_b;var xs = $_a;return __(concat,__(intersperse,xs,xss));});};};var forM_ = function($_a){return function($_b){return new $(function(){var m = $_b;var $_$_a = _($_a);if ($_$_a instanceof Fay$$Cons) {var x = $_$_a.car;var xs = $_$_a.cdr;return __(Fay$$then,__(m,x),__(forM_,xs,m));}if (_($_a) === null) {return __(Fay$$return,Fay$$unit);}throw ["unhandled case in Ident \"forM_\"",[$_a,$_b]];});};};var mapM_ = function($_a){return function($_b){return new $(function(){var $_$_b = _($_b);if ($_$_b instanceof Fay$$Cons) {var x = $_$_b.car;var xs = $_$_b.cdr;var m = $_a;return __(Fay$$then,__(m,x),__(mapM_,m,xs));}if (_($_b) === null) {return __(Fay$$return,Fay$$unit);}throw ["unhandled case in Ident \"mapM_\"",[$_a,$_b]];});};}; +// Exports +this.main = main; + +// Built-ins +this.$force = _; +this.$ = $; +this.$list = Fay$$list; +this.$encodeShow = Fay$$encodeShow; +this.$eval = Fay$$eval; + +}; +; +var main = new Home(); +main.$force(main.main); + diff --git a/docs/snippets/ffi.hs b/docs/snippets/ffi.hs --- a/docs/snippets/ffi.hs +++ b/docs/snippets/ffi.hs @@ -4,11 +4,14 @@ alert :: Foreign a => a -> Fay () alert = foreignFay "window.alert" "" -thebody :: Element -thebody = foreignPure "document.body" FayNone - getInnerHtml :: Element -> Fay String -getInnerHtml = foreignPropFay "innerHTML" FayString +getInnerHtml = foreignMethodFay "innerHTML" FayString setInnerHtml :: Element -> String -> Fay () setInnerHtml = foreignSetProp "innerHTML" + +thedocument :: Element +thedocument = foreignValue "window.document" FayNone + +jquery :: Element -> JQuery +jquery = foreignPure "window.jQuery" FayNone diff --git a/examples/canvaswater.hs b/examples/canvaswater.hs --- a/examples/canvaswater.hs +++ b/examples/canvaswater.hs @@ -55,7 +55,7 @@ -- | Add an event listener to an element. addEventListener :: (Foreign a,Eventable a) => a -> String -> Fay () -> Bool -> Fay () -addEventListener = foreignPropFay "addEventListener" FayNone +addEventListener = foreignMethodFay "addEventListener" FayNone -- | Get an element by its ID. getElementById :: String -> Fay Element @@ -85,11 +85,11 @@ -- | Get an element by its ID. getContext :: Element -> String -> Fay Context -getContext = foreignPropFay "getContext" FayNone +getContext = foreignMethodFay "getContext" FayNone -- | Draw an image onto a canvas rendering context. drawImage :: Context -> Image -> Double -> Double -> Fay () -drawImage = foreignPropFay "drawImage" FayNone +drawImage = foreignMethodFay "drawImage" FayNone -- | Draw an image onto a canvas rendering context. -- @@ -101,7 +101,7 @@ drawImageSpecific :: Context -> Image -> Double -> Double -> Double -> Double -> Double -> Double -> Double -> Double -> Fay () -drawImageSpecific = foreignPropFay "drawImage" FayNone +drawImageSpecific = foreignMethodFay "drawImage" FayNone -- | Set the fill style. setFillStyle :: Context -> String -> Fay () @@ -109,7 +109,7 @@ -- | Set the fill style. setFillRect :: Context -> Double -> Double -> Double -> Double -> Fay () -setFillRect = foreignPropFay "fillRect" FayNone +setFillRect = foreignMethodFay "fillRect" FayNone -------------------------------------------------------------------------------- -- Ref diff --git a/examples/dom.hs b/examples/dom.hs --- a/examples/dom.hs +++ b/examples/dom.hs @@ -15,7 +15,7 @@ print result print :: Foreign a => a -> Fay () -print = foreignFay "console.log" "" +print = foreignFay "console.log" FayNone data Element instance Foreign Element diff --git a/fay.cabal b/fay.cabal --- a/fay.cabal +++ b/fay.cabal @@ -1,5 +1,5 @@ name: fay -version: 0.2.2.0 +version: 0.3.1.0 synopsis: A compiler for Fay, a Haskell subset that compiles to JavaScript. description: Fay is a proper subset of Haskell which can be compiled (type-checked) with GHC, and compiled to JavaScript. It is lazy, pure, with a Fay monad, @@ -22,14 +22,30 @@ . /Release Notes/ . - Some more compilation options. + * Rewrite home page/docs JS in Fay. Because dogfood. . - * Optional flat function application (-flatten-apps). + * Support bool unseralization. . - * Exporting-builtins is optional (-no-export-builtins). + * Export more functions from stdlib. . - * The main module is annotated as a Closure \@constructor. + * Add fixity to monad. . + * Replace home page JS with Fay. + . + * Another FFI change. BREAKING CHANGE, LOOK AT THE FFI AND EXAPLES AGAIN. + . + * Handle list unserializing. + . + * Fix dom.hs. + . + * Add simple sum benchmark, will expand later (refs #11). + . + * Fix auto-exports. + . + * Fix docs for silly haddock syntax. + . + * Support avoiding Google Closure name mangling. + . See full history at: homepage: http://fay-lang.org/ license: BSD3 @@ -69,6 +85,7 @@ docs/snippets/lists.hs docs/snippets/patterns.hs docs/snippets/tail.hs + docs/home.hs -- Misc CHANGELOG diff --git a/js/runtime.js b/js/runtime.js --- a/js/runtime.js +++ b/js/runtime.js @@ -171,7 +171,7 @@ // Unserialize an object from JS to Fay. function Fay$$unserialize(typ,obj){ - if(typ == 'string' || typ == 'array') + if(typ == 'string' || typ == 'array' || typ == 'list') return Fay$$list(obj); else if(typ == 'bool') return obj? True : False; diff --git a/src/Docs.hs b/src/Docs.hs --- a/src/Docs.hs +++ b/src/Docs.hs @@ -7,6 +7,7 @@ module Main where import Language.Fay (compileViaStr,compileModule) +import Language.Fay.Compiler (compileFromTo) import Control.Exception import Control.Monad @@ -28,6 +29,7 @@ main = do let file = "docs" "index.html" generate >>= L.writeFile file + generateJs putStrLn $ "Documentation file written to " ++ file generate = do @@ -52,6 +54,14 @@ examples = map (("docs" "snippets") ) (map (++".hs") (words "declarations conditions functions lists data enums patterns ffi dom tail")) + +generateJs = do + putStrLn $ "Compiling " ++ inp ++ " to " ++ out ++ " ..." + compileFromTo def True inp out + + where docs = ("docs" ) + inp = (docs "home.hs") + out = (docs "home.js") page now analytics examples = do docType diff --git a/src/Language/Fay.hs b/src/Language/Fay.hs --- a/src/Language/Fay.hs +++ b/src/Language/Fay.hs @@ -97,7 +97,7 @@ } mapM_ emitExport (fromMaybe [] exports) imported <- fmap concat (mapM compileImport imports) - current <- compileDecls decls + current <- compileDecls True decls return (imported ++ current) compileModule mod = throwError (UnsupportedModuleSyntax mod) @@ -117,26 +117,26 @@ "It was: " ++ show i -- | Compile Haskell declaration. -compileDecls :: [Decl] -> Compile [JsStmt] -compileDecls decls = do +compileDecls :: Bool -> [Decl] -> Compile [JsStmt] +compileDecls toplevel decls = do case decls of [] -> return [] - (TypeSig _ _ sig:bind@PatBind{}:decls) -> appendM (compilePatBind (Just sig) bind) - (compileDecls decls) - (decl:decls) -> appendM (compileDecl decl) - (compileDecls decls) + (TypeSig _ _ sig:bind@PatBind{}:decls) -> appendM (compilePatBind toplevel (Just sig) bind) + (compileDecls toplevel decls) + (decl:decls) -> appendM (compileDecl toplevel decl) + (compileDecls toplevel decls) where appendM m n = do x <- m xs <- n return (x ++ xs) -- | Compile a declaration. -compileDecl :: Decl -> Compile [JsStmt] -compileDecl decl = +compileDecl :: Bool -> Decl -> Compile [JsStmt] +compileDecl toplevel decl = case decl of - pat@PatBind{} -> compilePatBind Nothing pat - FunBind matches -> compileFunCase matches - DataDecl _ DataType _ _ _ constructors _ -> compileDataDecl decl constructors + pat@PatBind{} -> compilePatBind toplevel Nothing pat + FunBind matches -> compileFunCase toplevel matches + DataDecl _ DataType _ _ _ constructors _ -> compileDataDecl toplevel decl constructors -- Just ignore type aliases and signatures. TypeDecl{} -> return [] TypeSig{} -> return [] @@ -146,25 +146,24 @@ _ -> throwError (UnsupportedDeclaration decl) -- | Compile a top-level pattern bind. -compilePatBind :: Maybe Type -> Decl -> Compile [JsStmt] -compilePatBind sig pat = do +compilePatBind :: Bool -> Maybe Type -> Decl -> Compile [JsStmt] +compilePatBind toplevel sig pat = do case pat of PatBind _ (PVar ident) Nothing (UnGuardedRhs rhs) (BDecls []) -> case ffiExp rhs <|> ffiProp rhs of Just detail@(binding,_,_) -> case sig of - Nothing -> compileNormalPatBind ident rhs + Nothing -> compileNormalPatBind toplevel ident rhs Just sig -> case () of () | func binding -> compileFFIFunc sig ident detail | method binding -> compileFFIMethod sig ident detail | setprop binding -> compileFFISetProp sig ident detail --- | value binding -> compileFFIValue sig ident detail | otherwise -> throwError (FfiNeedsTypeSig pat) - _ -> compileNormalPatBind ident rhs + _ -> compileNormalPatBind toplevel ident rhs _ -> throwError (UnsupportedDeclaration pat) - where func = flip elem ["foreignFay","foreignPure"] - method = flip elem ["foreignPropFay","foreignProp"] + where func = flip elem ["foreignFay","foreignPure","foreignValue"] + method = flip elem ["foreignMethodFay","foreignProp","foreignPropFay","foreignMethod"] setprop = flip elem ["foreignSetProp"] ffiExp (App (App (Var (UnQual (Ident ident))) @@ -179,10 +178,10 @@ ffiProp _ = Nothing -- | Compile a normal simple pattern binding. -compileNormalPatBind :: Name -> Exp -> Compile [JsStmt] -compileNormalPatBind ident rhs = do +compileNormalPatBind :: Bool -> Name -> Exp -> Compile [JsStmt] +compileNormalPatBind toplevel ident rhs = do body <- compileExp rhs - bind <- bindToplevel (UnQual ident) (thunk body) + bind <- bindToplevel toplevel (UnQual ident) (thunk body) return [bind] -- | Compile a foreign function. @@ -197,7 +196,7 @@ let args = zipWith const uniqueNames [1..typeArity sig] jsargs = drop 1 args obj = head args - compileFFI sig ident detail (JsGetProp (force (JsName obj)) (fromString name)) args jsargs + compileFFI sig ident detail (JsGetPropExtern (force (JsName obj)) (fromString name)) args jsargs -- | Compile a foreign method. compileFFISetProp :: Type -> Name -> (String,String,FayReturnType) -> Compile [JsStmt] @@ -208,10 +207,10 @@ compileFFI sig ident detail - (JsUpdateProp (force (JsName obj)) - (fromString name) - (serialize (head (tail funcTypes)) - (JsName (head jsargs)))) + (JsUpdatePropExtern (force (JsName obj)) + (fromString name) + (serialize (head (tail funcTypes)) + (JsName (head jsargs)))) args [] @@ -227,12 +226,13 @@ -> Compile [JsStmt] compileFFI sig ident (binding,_,typ) exp params args = do let innerexp - | length args == 0 = exp + | length args == 0 && elem binding ["foreignProp","foreignPropFay","foreignValue"] = exp | binding == "foreignSetProp" = exp | otherwise = JsApp exp (map (\(typ,name) -> serialize typ (JsName name)) (zip types args)) - bind <- bindToplevel (UnQual ident) + bind <- bindToplevel True + (UnQual ident) (foldr (\name inner -> JsFun [name] [] (Just inner)) (thunk (maybeMonad @@ -243,8 +243,10 @@ return [bind] where (maybeMonad,types) | binding == "foreignFay" = (monad,funcTypes) - | binding == "foreignPropFay" = (monad,drop 1 funcTypes) | binding == "foreignProp" = (id,drop 1 funcTypes) + | binding == "foreignMethodFay" = (monad,drop 1 funcTypes) + | binding == "foreignPropFay" = (monad,drop 1 funcTypes) + | binding == "foreignMethod" = (id,drop 1 funcTypes) | binding == "foreignSetProp" = (monad,[]) | otherwise = (id,funcTypes) funcTypes = functionTypeArgs sig @@ -292,8 +294,8 @@ _ -> 0 -- | Compile a data declaration. -compileDataDecl :: Decl -> [QualConDecl] -> Compile [JsStmt] -compileDataDecl decl constructors = do +compileDataDecl :: Bool -> Decl -> [QualConDecl] -> Compile [JsStmt] +compileDataDecl toplevel decl constructors = do fmap concat $ forM constructors $ \(QualConDecl _ _ _ condecl) -> case condecl of @@ -319,7 +321,8 @@ fmap concat $ forM fields $ \(i,field) -> forM field $ \name -> - bindToplevel (UnQual name) + bindToplevel toplevel + (UnQual name) (JsFun ["x"] [] (Just (thunk (JsIndex i (force (JsName "x")))))) @@ -335,9 +338,9 @@ unname _ = error "Expected ident from uname." -- FIXME: -- | Compile a function which pattern matches (causing a case analysis). -compileFunCase :: [Match] -> Compile [JsStmt] -compileFunCase [] = return [] -compileFunCase matches@(Match _ name argslen _ _ _:_) = do +compileFunCase :: Bool -> [Match] -> Compile [JsStmt] +compileFunCase _toplevel [] = return [] +compileFunCase toplevel matches@(Match _ name argslen _ _ _:_) = do tco <- config configTCO pats <- fmap optimizePatConditions $ forM matches $ \match@(Match _ _ pats _ rhs wheres) -> do unless (noBinds wheres) $ do _ <- throwError (UnsupportedWhereInMatch match) -- TODO: Support `where'. @@ -347,7 +350,8 @@ compilePat (JsName arg) pat inner) [JsEarlyReturn exp] (zip args pats) - bind <- bindToplevel (UnQual name) + bind <- bindToplevel toplevel + (UnQual name) (foldr (\arg inner -> JsFun [arg] [] (Just inner)) (stmtsThunk (let stmts = (concat pats ++ basecase) in if tco @@ -412,13 +416,14 @@ compileRhs rhs = throwError (UnsupportedRhs rhs) -- | Compile a pattern match binding. -compileFunMatch :: Match -> Compile [JsStmt] -compileFunMatch match = +compileFunMatch :: Bool -> Match -> Compile [JsStmt] +compileFunMatch toplevel match = case match of (Match _ name args Nothing (UnGuardedRhs rhs) _) -> do body <- compileExp rhs args <- mapM patToArg args - bind <- bindToplevel (UnQual name) + bind <- bindToplevel toplevel + (UnQual name) (foldr (\arg inner -> JsFun [arg] [] (Just inner)) (thunk body) args) @@ -428,7 +433,7 @@ where patToArg (PVar name) = return (UnQual name) patToArg _ = throwError (UnsupportedMatchSyntax match) -instance CompilesTo Decl [JsStmt] where compileTo = compileDecl +instance CompilesTo Decl [JsStmt] where compileTo = compileDecl False -- | Compile Haskell expression. compileExp :: Exp -> Compile JsExp @@ -695,8 +700,8 @@ compileLetDecl :: Decl -> Compile [JsStmt] compileLetDecl decl = case decl of - decl@PatBind{} -> compileDecls [decl] - decl@FunBind{} -> compileDecls [decl] + decl@PatBind{} -> compileDecls False [decl] + decl@FunBind{} -> compileDecls False [decl] _ -> throwError (UnsupportedLetBinding decl) -- | Compile Haskell literal. @@ -793,6 +798,7 @@ FayArray -> "array" FayList -> "list" FayString -> "string" + FayBool -> "bool" FayNone -> "" -- | Force an expression in a thunk. @@ -842,10 +848,10 @@ hjIdent = Qual (ModuleName "Fay") . Ident -- | Make a top-level binding. -bindToplevel :: QName -> JsExp -> Compile JsStmt -bindToplevel name exp = do +bindToplevel :: Bool -> QName -> JsExp -> Compile JsStmt +bindToplevel toplevel name exp = do exportAll <- gets stateExportAll - when exportAll $ emitExport (EVar name) + when (toplevel && exportAll) $ emitExport (EVar name) return (JsVar name exp) -- | Emit exported names. diff --git a/src/Language/Fay/Compiler.hs b/src/Language/Fay/Compiler.hs --- a/src/Language/Fay/Compiler.hs +++ b/src/Language/Fay/Compiler.hs @@ -68,7 +68,7 @@ -- | Print an this.x = x; export out. printExport :: Name -> String printExport name = - printJS (JsSetProp "this" + printJS (JsSetProp ":this" (UnQual name) (JsName (UnQual name))) diff --git a/src/Language/Fay/FFI.hs b/src/Language/Fay/FFI.hs --- a/src/Language/Fay/FFI.hs +++ b/src/Language/Fay/FFI.hs @@ -52,21 +52,37 @@ -> a -- ^ Bottom. foreignPure = error "Language.Fay.FFI.foreign: Used foreign function not in a JS engine context." +-- | Declare a foreign function. +foreignValue + :: Foreign a + => String -- ^ The foreign function name. + -> FayReturnType -- ^ JS return type. + -> a -- ^ Bottom. +foreignValue = error "Language.Fay.FFI.foreignValue: Used foreign function not in a JS engine context." + +-- | Declare a foreign function. +foreignProp + :: Foreign a + => String -- ^ The foreign function name. + -> FayReturnType -- ^ JS return type. + -> a -- ^ Bottom. +foreignProp = error "Language.Fay.FFI.foreignProp: Used foreign function not in a JS engine context." + -- | Declare a foreign action. -foreignPropFay +foreignMethodFay :: Foreign a => String -- ^ The foreign function name. -> FayReturnType -- ^ JS return type. -> a -- ^ Bottom. -foreignPropFay = error "Language.Fay.FFI.foreignPropFay: Used foreign function not in a JS engine context." +foreignMethodFay = error "Language.Fay.FFI.foreignMethodFay: Used foreign function not in a JS engine context." -- | Declare a foreign function. -foreignProp +foreignMethod :: Foreign a => String -- ^ The foreign function name. -> FayReturnType -- ^ JS return type. -> a -- ^ Bottom. -foreignProp = error "Language.Fay.FFI.foreignProp: Used foreign function not in a JS engine context." +foreignMethod = error "Language.Fay.FFI.foreignMethod: Used foreign function not in a JS engine context." -- | Declare a foreign action. foreignSetProp diff --git a/src/Language/Fay/Prelude.hs b/src/Language/Fay/Prelude.hs --- a/src/Language/Fay/Prelude.hs +++ b/src/Language/Fay/Prelude.hs @@ -50,9 +50,11 @@ (>>) :: Fay a -> Fay b -> Fay b (>>) = error "Language.Fay.Prelude.(>>): Used (>>) outside JS." +infixl 1 >> (>>=) :: Fay a -> (a -> Fay b) -> Fay b (>>=) = error "Language.Fay.Prelude.(>>=): Used (>>=) outside JS." +infixl 1 >>= fail :: String -> Fay a fail = error "Language.Fay.Prelude.fail: Used fail outside JS." diff --git a/src/Language/Fay/Print.hs b/src/Language/Fay/Print.hs --- a/src/Language/Fay/Print.hs +++ b/src/Language/Fay/Print.hs @@ -153,6 +153,11 @@ (concat ["(",printJS name,".",printJS prop," = ",printJS expr,")"]) printJS (JsInfix op x y) = printJS x ++ " " ++ op ++ " " ++ printJS y + -- Externs: Careful, here be dragons! Or at least warm lizards. + printJS (JsGetPropExtern exp prop) = + printJS exp ++ "['" ++ printJS prop ++ "']" + printJS (JsUpdatePropExtern name prop expr) = + (concat ["(",printJS name,"['",printJS prop,"'] = ",printJS expr,")"]) -------------------------------------------------------------------------------- -- Utilities @@ -162,8 +167,10 @@ -- Special symbols: jsEncodeName ":tmp" = "$tmp" jsEncodeName ":thunk" = "$" +jsEncodeName ":this" = "this" -- Used keywords: -jsEncodeName "null" = "_null" +jsEncodeName "null" = "_$null" +jsEncodeName "this" = "_$this" -- Anything else. jsEncodeName name = if isPrefixOf "$_" name diff --git a/src/Language/Fay/Stdlib.hs b/src/Language/Fay/Stdlib.hs --- a/src/Language/Fay/Stdlib.hs +++ b/src/Language/Fay/Stdlib.hs @@ -29,7 +29,9 @@ ,intersperse ,prependToAll ,intercalate - ,forM_) + ,forM_ + ,mapM_ + ,when) where import Prelude (Maybe(..),(==),(>>),return,(+),(<),(>),Bool(..),Ord,(||)) @@ -153,3 +155,6 @@ forM_ (x:xs) m = m x >> forM_ xs m forM_ [] _ = return () + +mapM_ m (x:xs) = m x >> mapM_ m xs +mapM_ _ [] = return () diff --git a/src/Language/Fay/Types.hs b/src/Language/Fay/Types.hs --- a/src/Language/Fay/Types.hs +++ b/src/Language/Fay/Types.hs @@ -133,6 +133,8 @@ | JsParen JsExp | JsGetProp JsExp JsName | JsUpdateProp JsExp JsName JsExp + | JsGetPropExtern JsExp JsName + | JsUpdatePropExtern JsExp JsName JsExp | JsList [JsExp] | JsNew JsName [JsExp] | JsThrowExp JsExp @@ -151,5 +153,5 @@ | JsBool Bool deriving (Show,Eq) -data FayReturnType = FayArray | FayList | FayString | FayNone +data FayReturnType = FayArray | FayList | FayString | FayBool | FayNone deriving (Read,Show,Eq) diff --git a/src/Tests.hs b/src/Tests.hs --- a/src/Tests.hs +++ b/src/Tests.hs @@ -1,3 +1,8 @@ +-- | Generate the web site/documentation for the Fay project. +-- +-- This depends on the Fay compiler to generate examples and the +-- javascript of the page is also built with Fay. + module Main where import Language.Fay.Compiler