fay 0.9.2.0 → 0.10.0.0

raw patch · 115 files changed

+3132/−24018 lines, 115 filesdep +containersdep +randomdep ~blaze-htmlPVP ok

version bump matches the API change (PVP)

Dependencies added: containers, random

Dependency ranges changed: blaze-html

API changes (from Hackage documentation)

Files

• docs/home.css +14/−1
• examples/alert.hs +1/−1
• examples/canvaswater.hs +1/−1
• examples/console.hs +1/−1
• examples/data.hs +1/−1
• examples/dom.hs +1/−1
• examples/ref.hs +1/−1
• examples/tailrecursive.hs +25/−7
• fay.cabal +77/−99
• hs/stdlib.hs +0/−7
• js/runtime.js +435/−264
• src/Data/List/Extra.hs +10/−0
• src/Docs.hs +62/−11
• src/Language/Fay.hs +169/−1232
• src/Language/Fay/Compiler.hs +950/−149
• src/Language/Fay/Compiler/FFI.hs +271/−0
• src/Language/Fay/Compiler/Misc.hs +234/−0
• src/Language/Fay/Compiler/Optimizer.hs +213/−0
• src/Language/Fay/Convert.hs +120/−64
• src/Language/Fay/FFI.hs +14/−6
• src/Language/Fay/Prelude.hs +6/−15
• src/Language/Fay/Print.hs +173/−114
• src/Language/Fay/Stdlib.hs +42/−5
• src/Language/Fay/Types.hs +119/−28
• src/Main.hs +79/−82
• src/Test/Api.hs +32/−3
• src/Test/Convert.hs +21/−0
• src/Tests.hs +2/−3
• tests/Bool.hs +1/−1
• tests/Bool.js +0/−532
• tests/Double.hs +1/−1
• tests/Double.js +0/−532
• tests/Double2.hs +1/−1
• tests/Double2.js +0/−532
• tests/Double3.hs +1/−1
• tests/Double3.js +0/−532
• tests/Double4.hs +1/−1
• tests/Double4.js +0/−532
• tests/Hierarchical/Export.hs +1/−1
• tests/Hierarchical/RecordDefined.hs +1/−1
• tests/HierarchicalImport.hs +1/−1
• tests/HierarchicalImport.js +0/−532
• tests/List.hs +1/−1
• tests/List.js +0/−535
• tests/List2.hs +1/−1
• tests/List2.js +0/−536
• tests/Monad.hs +1/−1
• tests/Monad.js +0/−532
• tests/Monad2.hs +1/−1
• tests/Monad2.js +0/−537
• tests/RecCon.hs +1/−1
• tests/RecCon.js +0/−534
• tests/RecDecl +1/−1
• tests/RecDecl.hs +1/−1
• tests/RecDecl.js +0/−547
• tests/RecordImport_Export.hs +2/−1
• tests/RecordImport_Export.js +0/−530
• tests/RecordImport_Import +1/−0
• tests/RecordImport_Import.hs +11/−2
• tests/RecordImport_Import.js +0/−534
• tests/String.hs +1/−1
• tests/String.js +0/−532
• tests/asPatternMatch.hs +1/−1
• tests/asPatternMatch.js +0/−535
• tests/basicFunctions.hs +1/−1
• tests/basicFunctions.js +0/−535
• tests/case.hs +1/−1
• tests/case.js +0/−532
• tests/case2.hs +1/−1
• tests/case2.js +0/−532
• tests/caseList.hs +1/−1
• tests/caseList.js +0/−532
• tests/caseWildcard.hs +1/−1
• tests/caseWildcard.js +0/−532
• tests/do.hs +1/−1
• tests/do.js +0/−532
• tests/doAssingPatternMatch.hs +1/−1
• tests/doAssingPatternMatch.js +0/−532
• tests/doBindAssign.hs +1/−1
• tests/doBindAssign.js +0/−532
• tests/emptyMain.hs +1/−1
• tests/emptyMain.js +0/−531
• tests/fix.hs +1/−1
• tests/fix.js +0/−535
• tests/fromInteger.hs +1/−1
• tests/fromInteger.js +0/−532
• tests/infixDataConst.hs +1/−1
• tests/infixDataConst.js +0/−533
• tests/ints.hs +1/−1
• tests/mutableReference.hs +1/−1
• tests/mutableReference.js +0/−535
• tests/patternGuards.hs +1/−1
• tests/patternGuards.js +0/−537
• tests/patternMatchFail.hs +1/−1
• tests/patternMatchFail.js +0/−532
• tests/recordFunctionPatternMatch.hs +1/−1
• tests/recordFunctionPatternMatch.js +0/−533
• tests/recordPatternMatch.hs +1/−1
• tests/recordPatternMatch.js +0/−532
• tests/recordPatternMatch2.hs +1/−1
• tests/recordPatternMatch2.js +0/−532
• tests/recordUseBeforeDefine.hs +1/−1
• tests/recordUseBeforeDefine.js +0/−533
• tests/records.hs +1/−1
• tests/records.js +0/−542
• tests/reservedWords.hs +1/−1
• tests/reservedWords.js +0/−532
• tests/tailRecursion.hs +2/−5
• tests/tailRecursion.js +0/−534
• tests/then.hs +1/−1
• tests/then.js +0/−532
• tests/utf8.hs +1/−1
• tests/utf8.js +0/−532
• tests/where.hs +1/−1
• tests/where.js +0/−532

@@ -25,6 +25,7 @@     font-size: 2em;     margin-bottom:0;     padding-bottom:0;+    margin-top:0;     color: #F40095 } h2 {@@ -36,6 +37,18 @@     color: #948091;     font-style: italic; }+.head {+    margin-top: 2em;+}+.head-logo {+    height: 50px;+    margin-top:5px;+    float: left;+    margin-right:1em+}+.head-text {+    margin-left: 1em;+} .subheadline {     font-size: 20px;     margin-bottom: 1em;@@ -44,7 +57,7 @@  /* Syntax highlighting */ .example {  }-.example pre { margin-top:0; +.example pre { margin-top:0; word-wrap: break-word; } .example pre .diff { color:#555 } .example pre code .title { color:#333 }

@@ -1,4 +1,4 @@-{-# LANGUAGE NoImplicitPrelude #-}+  module Alert where 

@@ -1,7 +1,7 @@ -- | Compile with: fay examples/canvaswater.hs  {-# LANGUAGE EmptyDataDecls    #-}-{-# LANGUAGE NoImplicitPrelude #-}+  -- | A demonstration of Fay using the canvas element to display a -- simple effect.

@@ -1,4 +1,4 @@-{-# LANGUAGE NoImplicitPrelude #-}+  module Console where 

@@ -4,7 +4,7 @@ -- $ node examples/data.js -- (Foo { x = 123, y = "abc", z = (Bar) }) -{-# LANGUAGE NoImplicitPrelude #-}+  module Data where 

@@ -1,5 +1,5 @@ {-# LANGUAGE EmptyDataDecls    #-}-{-# LANGUAGE NoImplicitPrelude #-}+  module Dom where 

@@ -1,7 +1,7 @@ -- | Mutable references.  {-# LANGUAGE EmptyDataDecls    #-}-{-# LANGUAGE NoImplicitPrelude #-}+  module Ref where 

@@ -4,25 +4,40 @@ -- See the ticket about optimizing tail-recursive functions for future -- work <https://github.com/faylang/fay/issues/19> -{-# LANGUAGE NoImplicitPrelude #-} + module Tailrecursive where  import           Language.Fay.FFI import           Language.Fay.Prelude  main = do-  benchmark-  benchmark-  benchmark-  benchmark+  benchmark $ printI (map (\x -> x+1) fibs !! 10)+  benchmark $ printI (fibs !! 80)+  benchmark $ printD (sum 1000000 0)+  benchmark $ printD (sum 1000000 0)+  benchmark $ printD (sum 1000000 0)+  benchmark $ printD (sum 1000000 0) -benchmark = do+fibs = 0 : 1 : zipWith (+) fibs (tail fibs)++tail (_:xs) = xs++xs !! k = go 0 xs where+  go n (x:xs) | n == k = x+              | otherwise = go (n+1) xs++benchmark m = do   start <- getSeconds-  printD (sum 1000000 0 :: Double)+  m   end <- getSeconds   printS (show (end-start) ++ "ms") +length' :: [a] -> Int+length' = go 0 where+  go acc (_:xs) = go (acc+1) xs+  go acc [] = acc+ -- tail recursive sum 0 acc = acc sum n acc = sum (n - 1) (acc + n)@@ -32,6 +47,9 @@  printD :: Double -> Fay () printD = ffi "console.log(%1)"++printI :: Int -> Fay ()+printI = ffi "console.log(%1)"  printS :: String -> Fay () printS = ffi "console.log(%1)"

@@ -1,5 +1,5 @@ name:                fay-version:             0.9.2.0+version:             0.10.0.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,50 +22,45 @@                      .                      /Release Notes/                      .-                     * Fix name encoding.-                     .-                     * Add content-type to HTML generation.-                     .-                     * Add calculator example.-                     .-                     * Support built-in operators as (+), (*), etc.-                     .-                     * Fix self-referential thunks (see #89).-                     .-                     * Don't import modules twice.+                     * Add TCO optimization.                      .-                     * Handle where bindings in function definitions.+                     * Added uncurrying optimization for non-partial applications.                      .-                     * Support record updates.+                     * Add simple benchmarking program.                      .-                     * Move to GHC type-checking (with --no-ghc).+                     * Add SVG logo.                      .-                     * Remove invalid chars from UTF-8 tests.+                     * Added Defined type and appropriate serialization.                      .-                     * Remove --autorun, now it's the default.+                     * Treat Maybe as a nullable value in conversions.                      .-                     * Fix nullary constructor comparison.+                     * Added oscillator example.                      .-                     * Replace . with $ in module name generation.+                     * Add optimization flag.++                     * Support tuple serialization.+                     * Fix list length in pats (closes #145).                      .-                     * Reverse -fdevel flag.+                     * Name resolution and some export list support.++                     * Add codeworld space invaders example.                      .-                     * Skip type declarations in where.+                     * NoImplicitPrelude is now passed automatically to GHC. Does not break code that uses the pragma (see #134).                      .-                     * Add true/false to keywords.+                     * Add support for list comprehensions using desugaring from Haskell report. See #40 and #132.                      .-                     * Add laziness back to infix operators.+                     * Make error messages a tiny bit friendlier, and some general house-keeping.                      .-                     * Switch to applicative parsing of options.+                     * Support negation expressions (see #116).                      .-                     * Fix parens in conversion functions.+                     * Rewrite readFromFay using only Data, no Read/Show requirements (see #112).                      .-                     See full history at: <https://github.com/chrisdone/fay/commits>+                     See full history at: <https://github.com/faylang/fay/commits> homepage:            http://fay-lang.org/ license:             BSD3 license-file:        LICENSE-author:              Chris Done-maintainer:          chrisdone@gmail.com+author:              Chris Done, Adam Bergmark+maintainer:          chrisdone@gmail.com, adam@edea.se copyright:           2012 Chris Done category:            Development build-type:          Custom@@ -77,72 +72,44 @@                      examples/tailrecursive.hs examples/data.hs examples/canvaswater.hs                      examples/canvaswater.html examples/haskell.png                      -- Test cases-                      tests/ints.hs tests/ints-                      tests/asPatternMatch tests/caseList.hs-                      tests/Double2.hs tests/fromInteger tests/List.hs-                      tests/RecCon tests/recordPatternMatch-                      tests/String.hs tests/asPatternMatch.hs-                      tests/caseList.js tests/Double2.js-                      tests/fromInteger.hs tests/List.js-                      tests/RecCon.hs tests/recordPatternMatch2-                      tests/String.js tests/asPatternMatch.js-                      tests/caseWildcard tests/Double3-                      tests/fromInteger.js tests/Monad tests/RecCon.js-                      tests/recordPatternMatch2.hs tests/tailRecursion-                      tests/basicFunctions tests/caseWildcard.hs-                      tests/Double3.hs-                      tests/Monad2 tests/RecDecl-                      tests/recordPatternMatch2.js-                      tests/tailRecursion.hs tests/basicFunctions.hs-                      tests/caseWildcard.js tests/Double3.js-                      tests/HierarchicalImport tests/Monad2.hs-                      tests/RecDecl.hs tests/recordPatternMatch.hs-                      tests/tailRecursion.js tests/basicFunctions.js-                      tests/do tests/Double4-                      tests/Monad2.js-                      tests/RecDecl.js tests/recordPatternMatch.js-                      tests/then tests/Bool tests/doAssingPatternMatch-                      tests/Double4.hs tests/HierarchicalImport.hs-                      tests/Monad.hs-                      tests/records tests/then.hs tests/Bool.hs-                      tests/doAssingPatternMatch.hs tests/Double4.js-                      tests/Monad.js-                      tests/recordFunctionPatternMatch-                      tests/records.hs tests/then.js tests/Bool.js-                      tests/doAssingPatternMatch.js tests/Double.hs-                      tests/HierarchicalImport.js-                      tests/mutableReference-                      tests/recordFunctionPatternMatch.hs-                      tests/records.js tests/utf8 tests/case-                      tests/doBindAssign tests/Double.js-                      tests/infixDataConst tests/mutableReference.hs-                      tests/recordFunctionPatternMatch.js-                      tests/recordUseBeforeDefine tests/utf8.hs-                      tests/case2 tests/doBindAssign.hs-                      tests/emptyMain tests/infixDataConst.hs-                      tests/mutableReference.js-                      tests/RecordImport_Export-                      tests/recordUseBeforeDefine.hs tests/utf8.js-                      tests/case2.hs tests/doBindAssign.js-                      tests/emptyMain.hs tests/infixDataConst.js-                      tests/patternGuards tests/RecordImport_Export.hs-                      tests/recordUseBeforeDefine.js tests/where-                      tests/case2.js tests/do.hs tests/emptyMain.js-                      tests/List tests/patternGuards.hs-                      tests/RecordImport_Export.js tests/reservedWords-                      tests/where.hs tests/case.hs tests/do.js-                      tests/fix tests/List2 tests/patternGuards.js-                      tests/RecordImport_Import tests/reservedWords.hs-                      tests/where.js tests/case.js tests/Double-                      tests/fix.hs tests/List2.hs-                      tests/patternMatchFail.hs-                      tests/RecordImport_Import.hs-                      tests/reservedWords.js tests/caseList-                      tests/Double2 tests/fix.js tests/List2.js-                      tests/patternMatchFail.js-                      tests/RecordImport_Import.js tests/String-                      tests/Hierarchical/Export.hs-                      tests/Hierarchical/RecordDefined.hs+                     tests/ints.hs tests/ints tests/asPatternMatch+                     tests/caseList.hs tests/Double2.hs+                     tests/fromInteger tests/List.hs tests/RecCon+                     tests/recordPatternMatch tests/String.hs+                     tests/asPatternMatch.hs tests/fromInteger.hs+                     tests/RecCon.hs tests/recordPatternMatch2+                     tests/caseWildcard tests/Double3 tests/Monad+                     tests/recordPatternMatch2.hs tests/tailRecursion+                     tests/basicFunctions tests/caseWildcard.hs+                     tests/Double3.hs tests/Monad2 tests/RecDecl+                     tests/tailRecursion.hs tests/basicFunctions.hs+                     tests/HierarchicalImport tests/Monad2.hs+                     tests/RecDecl.hs tests/recordPatternMatch.hs+                     tests/do tests/Double4 tests/then tests/Bool+                     tests/doAssingPatternMatch tests/Double4.hs+                     tests/HierarchicalImport.hs tests/Monad.hs+                     tests/records tests/then.hs tests/Bool.hs+                     tests/doAssingPatternMatch.hs+                     tests/recordFunctionPatternMatch tests/records.hs+                     tests/Double.hs tests/mutableReference+                     tests/recordFunctionPatternMatch.hs tests/utf8+                     tests/case tests/doBindAssign+                     tests/infixDataConst tests/mutableReference.hs+                     tests/recordUseBeforeDefine tests/utf8.hs+                     tests/case2 tests/doBindAssign.hs tests/emptyMain+                     tests/infixDataConst.hs tests/RecordImport_Export+                     tests/recordUseBeforeDefine.hs tests/case2.hs+                     tests/emptyMain.hs tests/patternGuards+                     tests/RecordImport_Export.hs tests/where+                     tests/do.hs tests/List tests/patternGuards.hs+                     tests/reservedWords tests/where.hs tests/case.hs+                     tests/fix tests/List2 tests/RecordImport_Import+                     tests/reservedWords.hs tests/Double tests/fix.hs+                     tests/List2.hs tests/patternMatchFail.hs+                     tests/RecordImport_Import.hs tests/caseList+                     tests/Double2 tests/String+                     tests/Hierarchical/Export.hs+                     tests/Hierarchical/RecordDefined.hs                      -- Documentation files                      docs/beautify.js docs/highlight.pack.js docs/home.css docs/jquery.js                      docs/analytics.js@@ -165,14 +132,15 @@  library   hs-source-dirs:    src-  exposed-modules:   Language.Fay, Language.Fay.Types, Language.Fay.FFI, Language.Fay.Prelude, Language.Fay.Convert, Language.Fay.Compiler-  other-modules:     Language.Fay.Print, Control.Monad.IO, Language.Fay.Stdlib, System.Process.Extra, Paths_fay+  exposed-modules:   Language.Fay, Language.Fay.Types, Language.Fay.FFI, Language.Fay.Prelude, Language.Fay.Convert, Language.Fay.Compiler, Language.Fay.Compiler.Misc, Language.Fay.Compiler.FFI, Language.Fay.Compiler.Optimizer+  other-modules:     Language.Fay.Print, Control.Monad.IO, Language.Fay.Stdlib, System.Process.Extra, Data.List.Extra, Paths_fay   ghc-options:       -O2 -Wall   build-depends:     base >= 4 && < 5,                      mtl,                      haskell-src-exts,                      aeson,                      unordered-containers,+                     containers,                      attoparsec,                      vector,                      text,@@ -186,9 +154,10 @@                      process,                      filepath,                      directory,-                     groom+                     groom,+                     random -  if flag(devel)+  if !flag(devel)     build-depends:                      -- Requirements for the executables which                      -- `cabal-dev ghci' needs.@@ -212,7 +181,9 @@                      mtl,                      haskell-src-exts,                      aeson,+                     syb,                      unordered-containers,+                     containers,                      attoparsec,                      vector,                      text,@@ -226,6 +197,7 @@                      directory,                      filepath,                      groom,+                     random,                      optparse-applicative,                      split,                      haskeline@@ -242,7 +214,9 @@                      mtl,                      haskell-src-exts,                      aeson,+                     syb,                      unordered-containers,+                     containers,                      attoparsec,                      vector,                      text,@@ -257,6 +231,7 @@                      safe,                      language-ecmascript,                      groom,+                     random,                      test-framework,                      test-framework-hunit,                      test-framework-th@@ -272,7 +247,9 @@                      mtl,                      haskell-src-exts,                      aeson,+                     syb,                      unordered-containers,+                     containers,                      attoparsec,                      vector,                      text,@@ -290,4 +267,5 @@                      data-default,                      safe,                      language-ecmascript,-                     groom+                     groom,+                     random

@@ -1,10 +1,3 @@ data Maybe a   = Just a   | Nothing--show :: (Foreign a,Show a) => a -> String-show = ffi "JSON.stringify(%1)"---- There is only Double in JS.-fromInteger x = x-fromRational x = x

@@ -7,25 +7,25 @@  // Force a thunk (if it is a thunk) until WHNF. function _(thunkish,nocache){-    while (thunkish instanceof $) {-        thunkish = thunkish.force(nocache);-    }-    return thunkish;+  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;+  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;+  this.forced = false;+  this.value = value; }  // Force the thunk.@@ -42,38 +42,66 @@  */  function Fay$$Monad(value){-    this.value = value;+  this.value = value; } +// This is used directly from Fay, but can be rebound or shadowed. See primOps in Types.hs. // >>-// encode_fay_to_js(">>=") → $62$$62$-// This is used directly from Fay, but can be rebound or shadowed.-function $62$$62$(a){-    return function(b){-        return new $(function(){-            _(a,true);-            return b;-        });-    };+function Fay$$then(a){+  return function(b){+    return Fay$$bind(a)(function(_){+      return b;+    });+  }; } +// This is used directly from Fay, but can be rebound or shadowed. See primOps in Types.hs.+// >>+function Fay$$then$36$uncurried(a,b){+  return Fay$$bind$36$uncurried(a,function(_){ return b; });+}+ // >>=-// encode_fay_to_js(">>=") → $62$$62$$61$+// This is used directly from Fay, but can be rebound or shadowed. See primOps in Types.hs.+function Fay$$bind(m){+  return function(f){+    return new $(function(){+      var monad = _(m,true);+      return f(monad.value);+    });+  };+}++// >>=+// This is used directly from Fay, but can be rebound or shadowed. See primOps in Types.hs.+function Fay$$bind$36$uncurried(m,f){+    return new $(function(){+      var monad = _(m,true);+      return f(monad.value);+    });+}+ // This is used directly from Fay, but can be rebound or shadowed.-function $62$$62$$61$(m){-    return function(f){-        return new $(function(){-            var monad = _(m,true);-            return f(monad.value);-        });-    };+function Fay$$$_return(a){+  return new Fay$$Monad(a); } +// Allow the programmer to access thunk forcing directly.+function Fay$$force(thunk){+  return function(type){+    return new $(function(){+      _(thunk,type);+      return new Fay$$Monad(Fay$$unit);+    })+  }+}+ // This is used directly from Fay, but can be rebound or shadowed.-function $_return(a){-    return new Fay$$Monad(a);+function Fay$$return$36$uncurried(a){+  return new Fay$$Monad(a); } +// Unit: (). var Fay$$unit = null;  /*******************************************************************************@@ -83,94 +111,115 @@  // Serialize a Fay object to JS. function Fay$$fayToJs(type,fayObj){-    var base = type[0];-    var args = type[1];-    var jsObj;-    switch(base){+  var base = type[0];+  var args = type[1];+  var jsObj;+  switch(base){     case "action": {-        // A nullary monadic action. Should become a nullary JS function.-        // Fay () -> function(){ return ... }-        jsObj = function(){-            return Fay$$fayToJs(args[0],_(fayObj,true).value);-        };-        break;+      // A nullary monadic action. Should become a nullary JS function.+      // Fay () -> function(){ return ... }+      jsObj = function(){+        return Fay$$fayToJs(args[0],_(fayObj,true).value);+      };+      break;     }     case "function": {-        // A proper function.-        jsObj = function(){-            var fayFunc = fayObj;-            var return_type = args[args.length-1];-            var len = args.length;-            // If some arguments.-            if (len > 1) {-                // Apply to all the arguments.-                fayFunc = _(fayFunc,true);-                // TODO: Perhaps we should throw an error when JS-                // passes more arguments than Haskell accepts.-                for (var i = 0, len = len; i < len - 1 && fayFunc instanceof Function; i++) {-                    // Unserialize the JS values to Fay for the Fay callback.-                    fayFunc = _(fayFunc(Fay$$jsToFay(args[i],arguments[i])),true);-                }-                // Finally, serialize the Fay return value back to JS.-                var return_base = return_type[0];-                var return_args = return_type[1];-                // If it's a monadic return value, get the value instead.-                if(return_base == "action") {-                    return Fay$$fayToJs(return_args[0],fayFunc.value);-                }-                // Otherwise just serialize the value direct.-                else {-                    return Fay$$fayToJs(return_type,fayFunc);-                }-            } else {-                throw new Error("Nullary function?");-            }-        };-        break;+      // A proper function.+      jsObj = function(){+        var fayFunc = fayObj;+        var return_type = args[args.length-1];+        var len = args.length;+        // If some arguments.+        if (len > 1) {+          // Apply to all the arguments.+          fayFunc = _(fayFunc,true);+          // TODO: Perhaps we should throw an error when JS+          // passes more arguments than Haskell accepts.+          for (var i = 0, len = len; i < len - 1 && fayFunc instanceof Function; i++) {+            // Unserialize the JS values to Fay for the Fay callback.+            fayFunc = _(fayFunc(Fay$$jsToFay(args[i],arguments[i])),true);+          }+          // Finally, serialize the Fay return value back to JS.+          var return_base = return_type[0];+          var return_args = return_type[1];+          // If it's a monadic return value, get the value instead.+          if(return_base == "action") {+            return Fay$$fayToJs(return_args[0],fayFunc.value);+          }+          // Otherwise just serialize the value direct.+          else {+            return Fay$$fayToJs(return_type,fayFunc);+          }+        } else {+          throw new Error("Nullary function?");+        }+      };+      break;     }     case "string": {-        // Serialize Fay string to JavaScript string.-        var str = "";-        fayObj = _(fayObj);-        while(fayObj instanceof Fay$$Cons) {-            str += fayObj.car;-            fayObj = _(fayObj.cdr);-        }-        jsObj = str;-        break;+      // Serialize Fay string to JavaScript string.+      var str = "";+      fayObj = _(fayObj);+      while(fayObj instanceof Fay$$Cons) {+        str += fayObj.car;+        fayObj = _(fayObj.cdr);+      }+      jsObj = str;+      break;     }     case "list": {-        // Serialize Fay list to JavaScript array.-        var arr = [];-        fayObj = _(fayObj);-        while(fayObj instanceof Fay$$Cons) {-            arr.push(Fay$$fayToJs(args[0],fayObj.car));-            fayObj = _(fayObj.cdr);-        }-        jsObj = arr;-        break;+      // Serialize Fay list to JavaScript array.+      var arr = [];+      fayObj = _(fayObj);+      while(fayObj instanceof Fay$$Cons) {+        arr.push(Fay$$fayToJs(args[0],fayObj.car));+        fayObj = _(fayObj.cdr);+      }+      jsObj = arr;+      break;     }+    case "tuple": {+      // Serialize Fay tuple to JavaScript array.+      var arr = [];+      fayObj = _(fayObj);+      var i = 0;+      while(fayObj instanceof Fay$$Cons) {+        arr.push(Fay$$fayToJs(args[i++],fayObj.car));+        fayObj = _(fayObj.cdr);+      }+      jsObj = arr;+      break;+    }+    case "defined": {+      fayObj = _(fayObj);+      if (fayObj instanceof $_Language$Fay$Stdlib$Undefined) {+        jsObj = undefined;+      } else {+        jsObj = Fay$$fayToJs(args[0],fayObj["slot1"]);+      }+      break;+    }     case "double": {-        // Serialize double, just force the argument. Doubles are unboxed.-        jsObj = _(fayObj);-        break;+      // Serialize double, just force the argument. Doubles are unboxed.+      jsObj = _(fayObj);+      break;     }     case "int": {-        // Serialize int, just force the argument. Ints are unboxed.-        jsObj = _(fayObj);-        break;+      // Serialize int, just force the argument. Ints are unboxed.+      jsObj = _(fayObj);+      break;     }     case "bool": {-        // Bools are unboxed.-        jsObj = _(fayObj);-        break;+      // Bools are unboxed.+      jsObj = _(fayObj);+      break;     }     case "unknown":     case "user": {-        if(fayObj instanceof $)-            fayObj = _(fayObj);-        jsObj = Fay$$fayToJsUserDefined(type,fayObj);-        break;+      if(fayObj instanceof $)+        fayObj = _(fayObj);+      jsObj = Fay$$fayToJsUserDefined(type,fayObj);+      break;     }     default: throw new Error("Unhandled Fay->JS translation type: " + base);     }@@ -179,61 +228,80 @@  // Unserialize an object from JS to Fay. function Fay$$jsToFay(type,jsObj){-    var base = type[0];-    var args = type[1];-    var fayObj;-    switch(base){+  var base = type[0];+  var args = type[1];+  var fayObj;+  switch(base){     case "action": {-        // Unserialize a "monadic" JavaScript return value into a monadic value.-        fayObj = new Fay$$Monad(Fay$$jsToFay(args[0],jsObj));-        break;+      // Unserialize a "monadic" JavaScript return value into a monadic value.+      fayObj = new Fay$$Monad(Fay$$jsToFay(args[0],jsObj));+      break;     }     case "string": {-        // Unserialize a JS string into Fay list (String).-        fayObj = Fay$$list(jsObj);-        break;+      // Unserialize a JS string into Fay list (String).+      fayObj = Fay$$list(jsObj);+      break;     }     case "list": {-        // Unserialize a JS array into a Fay list ([a]).-        var serializedList = [];-        for (var i = 0, len = jsObj.length; i < len; i++) {-            // Unserialize each JS value into a Fay value, too.-            serializedList.push(Fay$$jsToFay(args[0],jsObj[i]));-        }-        // Pop it all in a Fay list.-        fayObj = Fay$$list(serializedList);-        break;+      // Unserialize a JS array into a Fay list ([a]).+      var serializedList = [];+      for (var i = 0, len = jsObj.length; i < len; i++) {+        // Unserialize each JS value into a Fay value, too.+        serializedList.push(Fay$$jsToFay(args[0],jsObj[i]));+      }+      // Pop it all in a Fay list.+      fayObj = Fay$$list(serializedList);+      break;     }+    case "tuple": {+      // Unserialize a JS array into a Fay tuple ((a,b,c,...)).+      var serializedTuple = [];+      for (var i = 0, len = jsObj.length; i < len; i++) {+        // Unserialize each JS value into a Fay value, too.+        serializedTuple.push(Fay$$jsToFay(args[i],jsObj[i]));+      }+      // Pop it all in a Fay list.+      fayObj = Fay$$list(serializedTuple);+      break;+    }+    case "defined": {+      if (jsObj === undefined) {+        fayObj = new $_Language$Fay$Stdlib$Undefined();+      } else {+        fayObj = new $_Language$Fay$Stdlib$Defined(Fay$$jsToFay(args[0],jsObj));+      }+      break;+    }     case "double": {-        // Doubles are unboxed, so there's nothing to do.-        fayObj = jsObj;-        break;+      // Doubles are unboxed, so there's nothing to do.+      fayObj = jsObj;+      break;     }     case "int": {-        // Int are unboxed, so there's no forcing to do.-        // But we can do validation that the int has no decimal places.-        // E.g. Math.round(x)!=x? throw "NOT AN INTEGER, GET OUT!"-        fayObj = Math.round(jsObj);-        if(fayObj!==jsObj) throw "Argument " + jsObj + " is not an integer!";-        break;+      // Int are unboxed, so there's no forcing to do.+      // But we can do validation that the int has no decimal places.+      // E.g. Math.round(x)!=x? throw "NOT AN INTEGER, GET OUT!"+      fayObj = Math.round(jsObj);+      if(fayObj!==jsObj) throw "Argument " + jsObj + " is not an integer!";+      break;     }     case "bool": {-        // Bools are unboxed.-        fayObj = jsObj;-        break;+      // Bools are unboxed.+      fayObj = jsObj;+      break;     }     case "unknown":     case "user": {-        if (jsObj && jsObj['instance']) {-            fayObj = Fay$$jsToFayUserDefined(type,jsObj);-        }-        else-            fayObj = jsObj;-        break;-    }-    default: throw new Error("Unhandled JS->Fay translation type: " + base);+      if (jsObj && jsObj['instance']) {+        fayObj = Fay$$jsToFayUserDefined(type,jsObj);+      }+      else+        fayObj = jsObj;+      break;     }-    return fayObj;+  default: throw new Error("Unhandled JS->Fay translation type: " + base);+  }+  return fayObj; }  /*******************************************************************************@@ -242,223 +310,326 @@  // Cons object. function Fay$$Cons(car,cdr){-    this.car = car;-    this.cdr = 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;+  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);-    };+  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;-    };+  return function(list){+    for(var i = 0; i < index; i++) {+      list = _(list).cdr;+    }+    return list.car;+  }; } +// List length.+function Fay$$listLen(list,max){+  for(var i = 0; list !== null && i < max + 1; i++) {+    list = _(list).cdr;+  }+  return i == max;+}+ /*******************************************************************************  * Numbers.  */  // Built-in *. function Fay$$mult(x){-    return function(y){-        return new $(function(){-            return _(x) * _(y);-        });-    };+  return function(y){+    return new $(function(){+      return _(x) * _(y);+    });+  }; }-var $42$ = Fay$$mult; +function Fay$$mult$36$uncurried(x,y){++    return new $(function(){+      return _(x) * _(y);+    });++}+ // Built-in +. function Fay$$add(x){-    return function(y){-        return new $(function(){-            return _(x) + _(y);-        });-    };+  return function(y){+    return new $(function(){+      return _(x) + _(y);+    });+  }; }-var $43$ = Fay$$add; +// Built-in +.+function Fay$$add$36$uncurried(x,y){++    return new $(function(){+      return _(x) + _(y);+    });++}+ // Built-in -. function Fay$$sub(x){-    return function(y){-        return new $(function(){-            return _(x) - _(y);-        });-    };+  return function(y){+    return new $(function(){+      return _(x) - _(y);+    });+  }; }-var $45$ = Fay$$sub;+// Built-in -.+function Fay$$sub$36$uncurried(x,y){ +    return new $(function(){+      return _(x) - _(y);+    });++}+ // Built-in /. function Fay$$div(x){-    return function(y){-        return new $(function(){-            return _(x) / _(y);-        });-    };+  return function(y){+    return new $(function(){+      return _(x) / _(y);+    });+  }; }-var $47$ = Fay$$div; +// Built-in /.+function Fay$$div$36$uncurried(x,y){++    return new $(function(){+      return _(x) / _(y);+    });++}+ /*******************************************************************************  * Booleans.  */  // Are two values equal? function Fay$$equal(lit1, lit2) {-    // Simple case-    lit1 = _(lit1);-    lit2 = _(lit2);-    if (lit1 === lit2) {-        return true;+  // 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;     }-    // 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 && lit2 instanceof Fay$$Cons) {-        do {-            if (!Fay$$equal(lit1.car,lit2.car))-                return false;-            lit1 = _(lit1.cdr), lit2 = _(lit2.cdr);-            if (lit1 === null || lit2 === null)-                return lit1 === lit2;-        } while (true);-    } else if (typeof lit1 == 'object' && typeof lit2 == 'object' && lit1 && lit2 &&-              lit1.constructor === lit2.constructor) {-      for(var x in lit1) {-        if(!(lit1.hasOwnProperty(x) && lit2.hasOwnProperty(x) &&-            Fay$$equal(lit1[x],lit2[x])))-          return false;-      }-      return true;-    } else {-      return false;+    return true;+  } else if (lit1 instanceof Fay$$Cons && lit2 instanceof Fay$$Cons) {+    do {+      if (!Fay$$equal(lit1.car,lit2.car))+        return false;+      lit1 = _(lit1.cdr), lit2 = _(lit2.cdr);+      if (lit1 === null || lit2 === null)+        return lit1 === lit2;+    } while (true);+  } else if (typeof lit1 == 'object' && typeof lit2 == 'object' && lit1 && lit2 &&+             lit1.constructor === lit2.constructor) {+    for(var x in lit1) {+      if(!(lit1.hasOwnProperty(x) && lit2.hasOwnProperty(x) &&+           Fay$$equal(lit1[x],lit2[x])))+        return false;     }+    return true;+  } else {+    return false;+  } }  // Built-in ==. function Fay$$eq(x){-    return function(y){-        return new $(function(){-            return Fay$$equal(x,y);-        });-    };+  return function(y){+    return new $(function(){+      return Fay$$equal(x,y);+    });+  }; }-var $61$$61$ = Fay$$eq; +function Fay$$eq$36$uncurried(x,y){++    return new $(function(){+      return Fay$$equal(x,y);+    });++}+ // Built-in /=. function Fay$$neq(x){-    return function(y){-        return new $(function(){-            return !(Fay$$equal(x,y));-        });-    };+  return function(y){+    return new $(function(){+      return !(Fay$$equal(x,y));+    });+  }; }-var $47$$61$ = Fay$$neq; +// Built-in /=.+function Fay$$neq$36$uncurried(x,y){++    return new $(function(){+      return !(Fay$$equal(x,y));+    });++}+ // Built-in >. function Fay$$gt(x){-    return function(y){-        return new $(function(){-            return _(x) > _(y);-        });-    };+  return function(y){+    return new $(function(){+      return _(x) > _(y);+    });+  }; }-var $62$ = Fay$$gt; +// Built-in >.+function Fay$$gt$36$uncurried(x,y){++    return new $(function(){+      return _(x) > _(y);+    });++}+ // Built-in <. function Fay$$lt(x){-    return function(y){-        return new $(function(){-            return _(x) < _(y);-        });-    };+  return function(y){+    return new $(function(){+      return _(x) < _(y);+    });+  }; }-var $60$ = Fay$$lt; ++// Built-in <.+function Fay$$lt$36$uncurried(x,y){++    return new $(function(){+      return _(x) < _(y);+    });++}++ // Built-in >=. function Fay$$gte(x){-    return function(y){-        return new $(function(){-            return _(x) >= _(y);-        });-    };+  return function(y){+    return new $(function(){+      return _(x) >= _(y);+    });+  }; }-var $62$$61$ = Fay$$gte; +// Built-in >=.+function Fay$$gte$36$uncurried(x,y){++    return new $(function(){+      return _(x) >= _(y);+    });++}+ // Built-in <=. function Fay$$lte(x){-    return function(y){-        return new $(function(){-            return _(x) <= _(y);-        });-    };+  return function(y){+    return new $(function(){+      return _(x) <= _(y);+    });+  }; }-var $60$$61$ = Fay$$lte; +// Built-in <=.+function Fay$$lte$36$uncurried(x,y){++    return new $(function(){+      return _(x) <= _(y);+    });++}+ // Built-in &&. function Fay$$and(x){-    return function(y){-        return new $(function(){-            return _(x) && _(y);-        });-    };+  return function(y){+    return new $(function(){+      return _(x) && _(y);+    });+  }; }-var $38$$38$ = Fay$$and; +// Built-in &&.+function Fay$$and$36$uncurried(x,y){++    return new $(function(){+      return _(x) && _(y);+    });+ ;+}+ // Built-in ||. function Fay$$or(x){-    return function(y){-        return new $(function(){-            return _(x) || _(y);-        });-    };+  return function(y){+    return new $(function(){+      return _(x) || _(y);+    });+  }; }-var $124$$124$ = Fay$$or; +// Built-in ||.+function Fay$$or$36$uncurried(x,y){++    return new $(function(){+      return _(x) || _(y);+    });++}+ /*******************************************************************************  * Mutable references.  */  // Make a new mutable reference. function Fay$$Ref(x){-    this.value = x;+  this.value = x; }  // Write to the ref. function Fay$$writeRef(ref,x){-    ref.value = x;+  ref.value = x; }  // Get the value from the ref. function Fay$$readRef(ref,x){-    return ref.value;+  return ref.value; }  /*******************************************************************************  * Dates.  */ function Fay$$date(str){-    return window.Date.parse(str);+  return window.Date.parse(str); }  /*******************************************************************************

@@ -0,0 +1,10 @@+module Data.List.Extra where++import Data.List hiding (map)+import Prelude hiding (map)++unionOf :: (Eq a) => [[a]] -> [a]+unionOf = foldr union []++for :: (Functor f) => f a -> (a -> b) -> f b+for = flip fmap

@@ -1,21 +1,22 @@ {-# LANGUAGE CPP               #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards   #-} {-# OPTIONS -fno-warn-missing-signatures -fno-warn-unused-do-bind #-}  -- | Generate documentation for Fay.  module Main where -import           Language.Fay                (compileForDocs, compileViaStr)-import           Language.Fay.Compiler       (compileFromTo)-import           Language.Fay.Types          (CompileConfig(..))-- import           Control.Monad import qualified Data.ByteString.Lazy        as L import           Data.Char import           Data.Default import           Data.Time+import           Language.Fay                (compileFromTo)+import           Language.Fay.Compiler       (compileForDocs, compileViaStr)+import           Language.Fay.Types          (CompileConfig (..),+                                              PrintState (..))+ import           Prelude                     hiding (div, head) import           System.FilePath import           Text.Blaze.Extra@@ -23,6 +24,7 @@ import           Text.Blaze.Html5.Attributes as A hiding (title) import           Text.Blaze.Renderer.Utf8    (renderMarkup) + -- | Main entry point. main :: IO () main = do@@ -43,12 +45,13 @@   where compile file = do           contents <- readFile file           putStrLn $ "Generating " ++ file ++ " ..."-          result <- compileViaStr def { configFlattenApps = True-                                      , configTCO = True+          result <- compileViaStr file+                                  def { configFlattenApps = True+                                      , configOptimize = True                                       , configTypecheck = False }                                   compileForDocs contents           case result of-            Right (javascript,_) -> return javascript+            Right (PrintState{..},_) -> return (concat (reverse psOutput))             Left err -> error (show err)         titlize = takeWhile (/='.') . upperize . takeFileName           where upperize (x:xs) = toUpper x : xs@@ -59,7 +62,7 @@  generateJs = do   putStrLn $ "Compiling " ++ inp ++ " to " ++ out ++ " ..."-  compileFromTo def { configFlattenApps = True, configTypecheck = False } inp out+  compileFromTo def { configFlattenApps = True, configTypecheck = False } inp (Just out)    where docs = ("docs" </>)         inp = docs "home.hs"@@ -85,6 +88,7 @@   div !. "wrap" $ do     theheading     theintro+    thelinks     thesetup     thejsproblem     thecomparisons@@ -100,8 +104,11 @@         ! alt "Fork me on GitHub"  theheading = do-  h1 "Fay programming language"-  div !. "subheadline" $ "A proper subset of Haskell that compiles to JavaScript"+  div !. "head" $ do+    img !. "head-logo" ! src "logo-large.png"+    div !. "head-text" $ do+      h1 "Fay programming language"+      div !. "subheadline" $ "A proper subset of Haskell that compiles to JavaScript"  theexamples examples = do   a ! name "examples" $ return ()@@ -247,3 +254,47 @@          "For now it is best to simply try and see if you get an “Unsupported X” compile error or not. "          "It will not accept things that it doesn't support, apart from class and instance declarations, "          "which it ignores entirely. Inspect the compiler source if you are unsure, it is rather simple."++thelinks = do+  h2 "Fay in the Wild"+  ul $ do+    li $ do+      "Yesod Blog: "+      a ! href+        "http://www.yesodweb.com/blog/2012/10/yesod-fay-js" $+          "Yesod, AngularJS and Fay"+    li $ do+      "Happstack Blog: "+      a ! href+        "http://www.happstack.com/c/view-page-slug/15/happstack-fay-acid-state-shared-datatypes-are-awesome" $+          "Happstack, Fay, & Acid-State: Shared Datatypes are Awesome"+    li $ do+      a ! href+        "http://www.skybluetrades.net/blog/posts/2012/11/13/fay-ring-oscillator/index.html" $+          "Fun with Fay - A Ring Oscillator"+    li $ do+      a ! href+        "http://cdsmith.wordpress.com/2012/11/18/codeworld-and-the-future/" $+          "CodeWorld and the Future"+    li $ do+      a ! href+        "http://ide.fay-lang.org/" $+          "A Fay IDE written in Fay"+      ": "+      a ! href "https://github.com/faylang/fay-server" $ "github"+    li $ do+      "happstack-fay: "+      a ! href "http://hackage.haskell.org/package/happstack-fay" $ "hackage"+    li $ do+      H.span $ "snaplet-fay: "+      a ! href "https://github.com/faylang/snaplet-fay" $ "github"+      ", "+      a ! href "http://hackage.haskell.org/package/snaplet-fay" $ "hackage"+    li $ do+      "yesod-fay: "+      a ! href "https://github.com/snoyberg/yesod-fay" $ "github"+      ", "+      a ! href "http://hackage.haskell.org/package/yesod-fay" $ "hackage"+    li $ do+      "fay-jquery: "+      a ! href "https://github.com/faylang/fay-jquery" $ "hackage"

@@ -1,1232 +1,169 @@-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings     #-}-{-# LANGUAGE TupleSections         #-}-{-# LANGUAGE ViewPatterns          #-}-{-# OPTIONS -Wall -fno-warn-name-shadowing -fno-warn-orphans #-}---- | The Haskell→Javascript compiler.--module Language.Fay-  (compile-  ,runCompile-  ,compileViaStr-  ,compileForDocs-  ,compileToAst-  ,compileFromStr-  ,compileModule-  ,compileExp-  ,printCompile-  ,printTestCompile-  ,compileToplevelModule-  ,prettyPrintString)-  where--import           Language.Fay.Print          (jsEncodeName, printJSString)-import           Language.Fay.Types-import           System.Process.Extra--import           Control.Applicative-import           Control.Monad.Error-import           Control.Monad.IO-import           Control.Monad.State-import           Data.Char-import           Data.Default                (def)-import           Data.List-import           Data.Maybe-import           Data.String-import qualified Language.ECMAScript3.Parser as JS-import           Language.Haskell.Exts--import           Safe-import           System.Directory            (doesFileExist, findExecutable)-import           System.Exit-import           System.FilePath             ((</>))-import           System.IO-import           System.Process------------------------------------------------------------------------------------- Top level entry points---- | Compile something that compiles to something else.-compile :: CompilesTo from to => CompileConfig -> from -> IO (Either CompileError (to,CompileState))-compile config = runCompile (defaultCompileState config) . compileTo---- | Run the compiler.-runCompile :: CompileState -> Compile a -> IO (Either CompileError (a,CompileState))-runCompile state m = runErrorT (runStateT (unCompile m) state) where---- | Compile a Haskell source string to a JavaScript source string.-compileViaStr :: (Show from,Show to,CompilesTo from to)-              => CompileConfig-              -> (from -> Compile to)-              -> String-              -> IO (Either CompileError (String,CompileState))-compileViaStr config with from =-  runCompile (defaultCompileState config)-             (parseResult (throwError . uncurry ParseError)-                          (fmap printJSString . with)-                          (parseFay from))---- | Compile a Haskell source string to a JavaScript source string.-compileToAst :: (Show from,Show to,CompilesTo from to)-              => CompileState-              -> (from -> Compile to)-              -> String-              -> IO (Either CompileError (to,CompileState))-compileToAst state with from =-  runCompile state-             (parseResult (throwError . uncurry ParseError)-                          with-                          (parseFay from))---- | Compile from a string.-compileFromStr :: (Parseable a, MonadError CompileError m) => (a -> m a1) -> String -> m a1-compileFromStr with from =-  parseResult (throwError . uncurry ParseError)-              with-              (parseFay from)---- | Parse some Fay code.-parseFay :: Parseable ast => String -> ParseResult ast-parseFay = parseWithMode parseMode---- | The parse mode for Fay.-parseMode :: ParseMode-parseMode = defaultParseMode { extensions = [GADTs,StandaloneDeriving,EmptyDataDecls,TypeOperators] }---- | Compile the given input and print the output out prettily.-printCompile :: (Show from,Show to,CompilesTo from to)-              => CompileConfig-              -> (from -> Compile to)-              -> String-              -> IO ()-printCompile config with from = do-  result <- compileViaStr config with from-  case result of-    Left err -> print err-    Right (ok,_) -> prettyPrintString ok >>= putStr---- | Compile a String of Fay and print it as beautified JavaScript.-printTestCompile :: String -> IO ()-printTestCompile = printCompile def { configWarn = False } compileModule---- | Compile the given Fay code for the documentation. This is--- specialised because the documentation isn't really “real”--- compilation.-compileForDocs :: Module -> Compile [JsStmt]-compileForDocs mod = do-  initialPass mod-  compileModule mod---- | Compile the top-level Fay module.-compileToplevelModule :: Module -> Compile [JsStmt]-compileToplevelModule mod@(Module _ (ModuleName modulename) _ _ _ _ _)  = do-  cfg <- gets stateConfig-  when (configTypecheck cfg) $-    typecheck (configDirectoryIncludes cfg) [] (configWall cfg) $-      fromMaybe modulename $ configFilePath cfg-  initialPass mod-  modify $ \s -> s { stateImported = stateImported (defaultCompileState def) }-  stmts <- compileModule mod-  fay2js <- gets (fayToJsDispatcher . stateFayToJs)-  js2fay <- gets (jsToFayDispatcher . stateJsToFay)-  return (stmts ++ [fay2js,js2fay])------------------------------------------------------------------------------------- Initial pass-through collecting record definitions--initialPass :: Module -> Compile ()-initialPass (Module _ _ _ Nothing _ imports decls) = do-  mapM_ initialPass_import imports-  mapM_ (initialPass_decl True) decls--initialPass mod = throwError (UnsupportedModuleSyntax mod)--initialPass_import :: ImportDecl -> Compile ()-initialPass_import (ImportDecl _ (ModuleName name) False _ Nothing Nothing Nothing) = do-  void $ unlessImported name $ do-    dirs <- configDirectoryIncludes <$> gets stateConfig-    contents <- io (findImport dirs name)-    cs <- gets id-    result <- liftIO $ initialPass_records cs initialPass contents-    case result of-      Right ((),state) -> do-        -- Merges the state gotten from passing through an imported-        -- module with the current state. We can assume no duplicate-        -- records exist since GHC would pick that up.-        modify $ \s -> s { stateRecords = stateRecords state-                         , stateImported = stateImported state-                         }-      Left err -> throwError err-    return []--initialPass_import i =-  error $ "Initial pass: Import syntax not supported. " ++-        "The compiler writer was too lazy to support that.\n" ++-        "It was: " ++ show i--initialPass_records :: (Show from,Parseable from)-              => CompileState-              -> (from -> Compile ())-              -> String-              -> IO (Either CompileError ((),CompileState))-initialPass_records compileState with from =-  runCompile compileState-             (parseResult (throwError . uncurry ParseError)-                          with-                          (parseFay from))--initialPass_decl :: Bool -> Decl -> Compile ()-initialPass_decl toplevel decl =-  case decl of-    DataDecl _ DataType _ _ _ constructors _ -> initialPass_dataDecl toplevel decl constructors-    GDataDecl _ DataType _l _i _v _n decls _ -> initialPass_dataDecl toplevel decl (map convertGADT decls)-    _ -> return ()---- | Collect record definitions and store record name and field names.--- A ConDecl will have fields named slot1..slotN-initialPass_dataDecl :: Bool -> Decl -> [QualConDecl] -> Compile ()-initialPass_dataDecl _ _decl constructors =-  forM_ constructors $ \(QualConDecl _ _ _ condecl) ->-    case condecl of-      ConDecl (UnQual -> name) types  -> do-        let fields =  map (Ident . ("slot"++) . show . fst) . zip [1 :: Integer ..] $ types-        addRecordState name fields-      InfixConDecl _t1 (UnQual -> name) _t2 ->-        addRecordState name ["slot1", "slot2"]-      RecDecl (UnQual -> name) fields' -> do-        let fields = concatMap fst fields'-        addRecordState name fields--  where-    addRecordState :: QName -> [Name] -> Compile ()-    addRecordState name fields = modify $ \s -> s { stateRecords = (Ident (qname name), fields) : stateRecords s }------------------------------------------------------------------------------------- Typechecking--typecheck :: [FilePath] -> [String] -> Bool -> String -> Compile ()-typecheck includeDirs ghcFlags wall fp = do-  res <- liftIO $ readAllFromProcess' "ghc" (-    ["-fno-code", "-package fay", fp] ++ map ("-i" ++) includeDirs ++ ghcFlags ++ wallF) ""-  either error (warn . fst) res-  where-    wallF | wall = ["-Wall"]-          | otherwise = []------------------------------------------------------------------------------------- Compilers----- | Compile Haskell module.-compileModule :: Module -> Compile [JsStmt]-compileModule (Module _ modulename pragmas Nothing exports imports decls) = do-  checkModulePragmas pragmas-  modify $ \s -> s { stateModuleName = modulename-                   , stateExportAll = isNothing exports-                   }-  mapM_ emitExport (fromMaybe [] exports)-  imported <- fmap concat (mapM compileImport imports)-  current <- compileDecls True decls-  return (imported ++ current)-compileModule mod = throwError (UnsupportedModuleSyntax mod)--warn :: String -> Compile ()-warn "" = return ()-warn w = do-  shouldWarn <- configWarn <$> gets stateConfig-  when shouldWarn . liftIO . hPutStrLn stderr $ "Warning: " ++ w--checkModulePragmas :: [ModulePragma] -> Compile ()-checkModulePragmas pragmas =-  when (not $ any noImplicitPrelude pragmas) $-    warn "NoImplicitPrelude not specified"-  where-    noImplicitPrelude :: ModulePragma -> Bool-    noImplicitPrelude (LanguagePragma _ names) = any (== (Ident "NoImplicitPrelude")) names-    noImplicitPrelude _ = False--instance CompilesTo Module [JsStmt] where compileTo = compileModule--findImport :: [FilePath] -> String -> IO String-findImport (dir:dirs) name = do-  exists <- doesFileExist path-  if exists-    then readFile path-    else findImport dirs name-  where-    path = dir </> replace '.' '/' name ++ ".hs"-    replace c r = map (\x -> if x == c then r else x)-findImport [] name =-  error $ "Could not find import: " ++ name---- | Compile the given import.-compileImport :: ImportDecl -> Compile [JsStmt]-compileImport (ImportDecl _ (ModuleName name) False _ Nothing Nothing Nothing) = do-  unlessImported name $ do-    dirs <- configDirectoryIncludes <$> gets stateConfig-    contents <- io (findImport dirs name)-    state <- gets id-    result <- liftIO $ compileToAst state compileModule contents-    case result of-      Right (stmts,state) -> do-        modify $ \s -> s { stateFayToJs = stateFayToJs state-                         , stateJsToFay = stateJsToFay state-                         , stateImported = stateImported state-                         }-        return stmts-      Left err -> throwError err-compileImport i =-  error $ "compileImport: Import syntax not supported. " ++-        "The compiler writer was too lazy to support that.\n" ++-        "It was: " ++ show i---- | Don't re-import the same modules.-unlessImported :: String -> Compile [JsStmt] -> Compile [JsStmt]-unlessImported name importIt = do-  imported <- gets stateImported-  if elem name imported-     then return []-     else do-       modify $ \s -> s { stateImported = name : imported }-       importIt---- | Compile Haskell declaration.-compileDecls :: Bool -> [Decl] -> Compile [JsStmt]-compileDecls toplevel decls =-  case decls of-    [] -> return []-    (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 :: Bool -> Decl -> Compile [JsStmt]-compileDecl toplevel decl =-  case decl of-    pat@PatBind{} -> compilePatBind toplevel Nothing pat-    FunBind matches -> compileFunCase toplevel matches-    DataDecl _ DataType _ _ _ constructors _ -> compileDataDecl toplevel decl constructors-    GDataDecl _ DataType _l _i _v _n decls _ -> compileDataDecl toplevel decl (map convertGADT decls)-    -- Just ignore type aliases and signatures.-    TypeDecl{} -> return []-    TypeSig{} -> return []-    InfixDecl{} -> return []-    ClassDecl{} -> return []-    InstDecl{} -> return [] -- FIXME: Ignore.-    DerivDecl{} -> return []-    _ -> throwError (UnsupportedDeclaration decl)---- | Compile a top-level pattern bind.-compilePatBind :: Bool -> Maybe Type -> Decl -> Compile [JsStmt]-compilePatBind toplevel sig pat =-  case pat of-    PatBind srcloc (PVar ident) Nothing (UnGuardedRhs rhs) (BDecls []) ->-      case ffiExp rhs of-        Just formatstr -> case sig of-          Just sig -> compileFFI srcloc ident formatstr sig-          Nothing  -> throwError (FfiNeedsTypeSig pat)-        _ -> compileUnguardedRhs srcloc toplevel ident rhs-    PatBind srcloc (PVar ident) Nothing (UnGuardedRhs rhs) bdecls ->-      compileUnguardedRhs srcloc toplevel ident (Let bdecls rhs)-    _ -> throwError (UnsupportedDeclaration pat)--  where ffiExp (App (Var (UnQual (Ident "ffi"))) (Lit (String formatstr))) = Just formatstr-        ffiExp _ = Nothing---- | Compile an FFI call.-compileFFI :: SrcLoc -- ^ Location of the original FFI decl.-           -> Name   -- ^ Name of the to-be binding.-           -> String -- ^ The format string.-           -> Type   -- ^ Type signature.-           -> Compile [JsStmt]-compileFFI srcloc name formatstr sig = do-  inner <- formatFFI formatstr (zip params funcFundamentalTypes)-  case JS.parse JS.parseExpression (prettyPrint name) (printJSString (wrapReturn inner)) of-    Left err -> throwError (FfiFormatInvalidJavaScript inner (show err))-    Right{}  -> fmap return (bindToplevel srcloc True (UnQual name) (body inner))--  where body inner = foldr wrapParam (wrapReturn inner) params-        wrapParam name inner = JsFun [name] [] (Just inner)-        params = zipWith const uniqueNames [1..typeArity sig]-        wrapReturn inner = thunk $-          case lastMay funcFundamentalTypes of-            -- Returns a “pure” value;-            Just{} -> jsToFay returnType (JsRawExp inner)-            -- Base case:-            Nothing -> JsRawExp inner-        funcFundamentalTypes = functionTypeArgs sig-        returnType = last funcFundamentalTypes---- | Format the FFI format string with the given arguments.-formatFFI :: String                      -- ^ The format string.-          -> [(JsParam,FundamentalType)] -- ^ Arguments.-          -> Compile String              -- ^ The JS code.-formatFFI formatstr args = go formatstr where-  go ('%':'*':xs) = do-    these <- mapM inject (zipWith const [1..] args)-    rest <- go xs-    return (intercalate "," these ++ rest)-  go ('%':'%':xs) = do-    rest <- go xs-    return ('%' : rest)-  go ['%'] = throwError FfiFormatIncompleteArg-  go ('%':(span isDigit -> (op,xs))) =-    case readMay op of-     Nothing -> throwError (FfiFormatBadChars op)-     Just n -> do-       this <- inject n-       rest <- go xs-       return (this ++ rest)-  go (x:xs) = do rest <- go xs-                 return (x : rest)-  go [] = return []--  inject n =-    case listToMaybe (drop (n-1) args) of-      Nothing -> throwError (FfiFormatNoSuchArg n)-      Just (arg,typ) -> do-        return (printJSString (fayToJs (typeRep typ) (JsName arg)))---- | Translate: Fay → JS.-fayToJs :: JsExp -> JsExp -> JsExp-fayToJs typ exp = JsApp (JsName (hjIdent "fayToJs"))-                        [typ,exp]---- | Get a JS-representation of a fundamental type for encoding/decoding.-typeRep :: FundamentalType -> JsExp-typeRep typ =-  case typ of-    FunctionType xs     -> JsList [JsLit $ JsStr "function",JsList (map typeRep xs)]-    JsType x            -> JsList [JsLit $ JsStr "action",JsList [typeRep x]]-    ListType x          -> JsList [JsLit $ JsStr "list",JsList [typeRep x]]-    UserDefined name xs -> JsList [JsLit $ JsStr "user"-                                  ,JsLit $ JsStr (unname name)-                                  ,JsList (map typeRep xs)]-    typ -> JsList [JsLit $ JsStr nom]--      where nom = case typ of-              StringType -> "string"-              DoubleType -> "double"-              IntType    -> "int"-              BoolType   -> "bool"-              DateType   -> "date"-              _          -> "unknown"---- | Get arg types of a function type.-functionTypeArgs :: Type -> [FundamentalType]-functionTypeArgs t =-  case t of-    TyForall _ _ i -> functionTypeArgs i-    TyFun a b      -> argType a : functionTypeArgs b-    TyParen st     -> functionTypeArgs st-    r              -> [argType r]---- | Convert a Haskell type to an internal FFI representation.-argType :: Type -> FundamentalType-argType t =-  case t of-    TyCon "String"        -> StringType-    TyCon "Double"        -> DoubleType-    TyCon "Int"           -> IntType-    TyCon "Bool"          -> BoolType-    TyApp (TyCon "Fay") a -> JsType (argType a)-    TyFun x xs            -> FunctionType (argType x : functionTypeArgs xs)-    TyList x              -> ListType (argType x)-    TyParen st            -> argType st-    TyApp op arg          -> userDefined (reverse (arg : expandApp op))-    _                     ->-      -- No semantic point to this, merely to avoid GHC's broken-      -- warning.-      case t of-        TyCon (UnQual user)   -> UserDefined user []-        _ -> UnknownType---- | Generate a user-defined type.-userDefined :: [Type] -> FundamentalType-userDefined (TyCon (UnQual name):typs) = UserDefined name (map argType typs)-userDefined _ = UnknownType---- | Expand a type application.-expandApp :: Type -> [Type]-expandApp (TyParen t) = expandApp t-expandApp (TyApp op arg) = arg : expandApp op-expandApp x = [x]---- | Get the arity of a type.-typeArity :: Type -> Int-typeArity t =-  case t of-    TyForall _ _ i -> typeArity i-    TyFun _ b      -> 1 + typeArity b-    TyParen st     -> typeArity st-    _              -> 0---- | Compile a normal simple pattern binding.-compileUnguardedRhs :: SrcLoc -> Bool -> Name -> Exp -> Compile [JsStmt]-compileUnguardedRhs srcloc toplevel ident rhs = do-  body <- compileExp rhs-  bind <- bindToplevel srcloc toplevel (UnQual ident) (thunk body)-  return [bind]--convertGADT :: GadtDecl -> QualConDecl-convertGADT d =-  case d of-    GadtDecl srcloc name typ -> QualConDecl srcloc tyvars context-                                            (ConDecl name (convertFunc typ))-  where tyvars = []-        context = []-        convertFunc (TyCon _) = []-        convertFunc (TyFun x xs) = UnBangedTy x : convertFunc xs-        convertFunc (TyParen x) = convertFunc x-        convertFunc _ = []---- | Compile a data declaration.-compileDataDecl :: Bool -> Decl -> [QualConDecl] -> Compile [JsStmt]-compileDataDecl toplevel _decl constructors =-  fmap concat $-    forM constructors $ \(QualConDecl srcloc _ _ condecl) ->-      case condecl of-        ConDecl (UnQual -> name) types  -> do-          let fields =  map (Ident . ("slot"++) . show . fst) . zip [1 :: Integer ..] $ types-              fields' = (zip (map return fields) types)-          cons <- makeConstructor name fields-          func <- makeFunc name fields-          emitFayToJs name fields'-          emitJsToFay name fields'-          return [cons, func]-        InfixConDecl t1 (UnQual -> name) t2 -> do-          let slots = [Ident "slot1", Ident "slot2"]-              fields = zip (map return slots) [t1, t2]-          cons <- makeConstructor name slots-          func <- makeFunc name slots-          emitFayToJs name fields-          emitJsToFay name fields-          return [cons, func]-        RecDecl (UnQual -> name) fields' -> do-          let fields = concatMap fst fields'-          cons <- makeConstructor name fields-          func <- makeFunc name fields-          funs <- makeAccessors srcloc fields-          emitFayToJs name fields'-          emitJsToFay name fields'-          return (cons : func : funs)--  where-    -- Creates a constructor R_RecConstr for a Record-    makeConstructor name fields = do-          let fieldParams = map (fromString . unname) fields-          return $-            JsVar (constructorName name) $-              JsFun fieldParams-                  (flip map fields $ \field@(Ident s) ->-                     JsSetProp (fromString ":this") (UnQual field) (JsName (fromString s)))-                Nothing--    -- Creates a function to initialize the record by regular application-    makeFunc name fields = do-          let fieldParams = map (\(Ident s) -> fromString s) fields-          let fieldExps = map (JsName . UnQual) fields-          return $ JsVar name $-            foldr (\slot inner -> JsFun [slot] [] (Just inner))-              (thunk $ JsNew (constructorName name) fieldExps)-              fieldParams--    -- Creates getters for a RecDecl's values-    makeAccessors srcloc fields =-      forM fields $ \(Ident name) ->-           bindToplevel srcloc-                        toplevel-                        (fromString name)-                        (JsFun ["x"]-                               []-                               (Just (thunk (JsGetProp (force (JsName "x"))-                                                       (fromString name)))))--fayToJsDispatcher :: [JsStmt] -> JsStmt-fayToJsDispatcher cases =-  JsVar (hjIdent "fayToJsUserDefined")-        (JsFun ["type",transcodingObj]-               (decl ++ cases ++ [baseCase])-               Nothing)--  where decl = [JsVar transcodingObjForced-                      (force (JsName transcodingObj))-               ,JsVar "argTypes"-                      (JsLookup (JsName "type")-                                (JsLit (JsInt 2)))]-        baseCase =-          JsEarlyReturn (JsName transcodingObj)-          -- JsThrow (JsNew "Error"-          --                [JsLit (JsStr "No handler for translating this Fay value to a JS value.")])---- Make a Fay→JS encoder.-emitFayToJs :: QName -> [([Name], BangType)] -> Compile ()-emitFayToJs name (explodeFields -> fieldTypes) =-  modify $ \s -> s { stateFayToJs = translator : stateFayToJs s }--  where-    translator = JsIf (JsInstanceOf (JsName transcodingObjForced) (constructorName name))-                      [JsEarlyReturn (JsObj (("instance",JsLit (JsStr (qname name)))-                                                     : zipWith declField [0..] fieldTypes))]-                      []-    -- Declare/encode Fay→JS field-    declField :: Int -> (Name,BangType) -> (String,JsExp)-    declField _i (name,typ) =-      (unname name-      ,fayToJs (case argType (bangType typ) of-                 known -> typeRep known)-               (force (JsGetProp (JsName transcodingObjForced)-                                 (UnQual name))))--jsToFayDispatcher :: [JsStmt] -> JsStmt-jsToFayDispatcher cases =-  JsVar (hjIdent "jsToFayUserDefined")-        (JsFun ["type",transcodingObj]-               (cases ++ [baseCase])-               Nothing)--  where baseCase =-          JsEarlyReturn (JsName transcodingObj)-          -- JsThrow (JsNew "Error"-          --                [JsLit (JsStr "No handler for translating this JS value to a Fay value.")])---- Make a JS→Fay decoder-emitJsToFay ::  QName -> [([Name], BangType)] -> Compile ()-emitJsToFay name (explodeFields -> fieldTypes) =-  modify $ \s -> s { stateJsToFay = translator : stateJsToFay s }--  where-    translator =-      JsIf (JsEq (JsGetPropExtern (JsName transcodingObj) "instance")-                 (JsLit (JsStr (qname name))))-           [JsEarlyReturn (JsNew (constructorName name)-                                 (map decodeField fieldTypes))]-           []-    -- Decode JS→Fay field-    decodeField :: (Name,BangType) -> JsExp-    decodeField (name,typ) =-      jsToFay (argType (bangType typ))-              (JsGetPropExtern (JsName transcodingObj)-                               (unname name))--explodeFields :: [([a], t)] -> [(a, t)]-explodeFields = concatMap $ \(names,typ) -> map (,typ) names--transcodingObj :: JsName-transcodingObj = "obj"--transcodingObjForced :: JsName-transcodingObjForced = "_obj"---- | Extract the type.-bangType :: BangType -> Type-bangType typ =-  case typ of-    BangedTy ty   -> ty-    UnBangedTy ty -> ty-    UnpackedTy ty -> ty---- | Extract the string from a qname.-qname :: QName -> String-qname (UnQual (Ident str)) = str-qname (UnQual (Symbol sym)) = jsEncodeName sym-qname i = error $ "qname: Expected unqualified ident, found: " ++ show i -- FIXME:---- | Extra the string from an ident.-unname :: Name -> String-unname (Ident str) = str-unname _ = error "Expected ident from uname." -- FIXME:--constructorName :: QName -> QName-constructorName = fromString . ("$_" ++) . qname---- | Compile a function which pattern matches (causing a case analysis).-compileFunCase :: Bool -> [Match] -> Compile [JsStmt]-compileFunCase _toplevel [] = return []-compileFunCase toplevel matches@(Match srcloc name argslen _ _ _:_) = do-  tco  <- config configTCO-  pats <- fmap optimizePatConditions (mapM compileCase matches)-  bind <- bindToplevel srcloc-                       toplevel-                       (UnQual name)-                       (foldr (\arg inner -> JsFun [arg] [] (Just inner))-                              (stmtsThunk (let stmts = (concat pats ++ basecase)-                                           in if tco-                                                 then optimizeTailCalls args name stmts-                                                 else stmts))-                              args)-  return [bind]-  where args = zipWith const uniqueNames argslen--        isWildCardMatch (Match _ _ pats _ _ _) = all isWildCardPat pats--        compileCase :: Match -> Compile [JsStmt]-        compileCase match@(Match _ _ pats _ rhs _) = do-          whereDecls' <- whereDecls match-          exp  <- compileRhs rhs-          body <- if null whereDecls'-                    then return exp-                    else do-                        binds <- mapM compileLetDecl whereDecls'-                        return (JsApp (JsFun [] (concat binds) (Just exp)) [])-          foldM (\inner (arg,pat) ->-                  compilePat (JsName arg) pat inner)-                [JsEarlyReturn body]-                (zip args pats)--        whereDecls :: Match -> Compile [Decl]-        whereDecls (Match _ _ _ _ _ (BDecls decls)) = return decls-        whereDecls match = throwError (UnsupportedWhereInMatch match)--        basecase :: [JsStmt]-        basecase = if any isWildCardMatch matches-                      then []-                      else [throw ("unhandled case in " ++ show name)-                                  (JsList (map JsName args))]---- | Optimize functions in tail-call form.-optimizeTailCalls :: [JsParam] -- ^ The function parameters.-                  -> Name      -- ^ The function name.-                  -> [JsStmt]  -- ^ The body of the function.-                  -> [JsStmt]  -- ^ A new optimized function body.-optimizeTailCalls params name stmts = abandonIfNoChange $-  JsWhile (JsLit (JsBool True))-          (concatMap replaceTailStmt-                     (reverse (zip (reverse stmts) [0::Integer ..])))--  where replaceTailStmt (JsIf cond sothen orelse,i) = [JsIf cond (concatMap (replaceTailStmt . (,i)) sothen)-                                                                 (concatMap (replaceTailStmt . (,i)) orelse)]-        replaceTailStmt (JsEarlyReturn exp,i) = expTailReplace i exp-        replaceTailStmt (x,_) = [x]-        expTailReplace i (flatten -> Just (JsName (UnQual call):args@(_:_)))-          | call == name = updateParamsInstead i args-        expTailReplace _i original = [JsEarlyReturn original]-        updateParamsInstead i args = zipWith JsUpdate params args ++-                                     [JsContinue | i /= 0]-        abandonIfNoChange (JsWhile _ newstmts)-          | newstmts == stmts = stmts-        abandonIfNoChange new = [new]---- | Flatten an application expression into function : arg : arg : []-flatten :: JsExp -> Maybe [JsExp]-flatten (JsApp op@JsApp{} arg) = do-  inner <- expand op-  return (inner ++ arg)-flatten name@JsName{} = return [name]-flatten _ = Nothing---- | Expand a forced value into the value.-expand :: JsExp -> Maybe [JsExp]-expand (JsApp (JsName (UnQual (Ident "_"))) xs) =-  fmap concat (mapM flatten xs)-expand _ = Nothing---- | Format a JS string using "js-beautify", or return the JS as-is if---   "js-beautify" is unavailable.-prettyPrintString :: String -> IO String-prettyPrintString contents = do-    mexe <- findExecutable "js-beautify"-    case mexe of-      Nothing -> return $ contents ++ "\n"-      Just exe -> do-        (code,out,_) <- readProcessWithExitCode exe ["--stdin"] contents-        case code of-          ExitSuccess -> return out-          ExitFailure _ -> return $ contents ++ "\n"---- | Compile a right-hand-side expression.-compileRhs :: Rhs -> Compile JsExp-compileRhs (UnGuardedRhs exp) = compileExp exp-compileRhs (GuardedRhss rhss) = compileGuards rhss---- | Compile guards-compileGuards :: [GuardedRhs] -> Compile JsExp-compileGuards [] = return . JsThrowExp . JsLit . JsStr $ "Non-exhaustive guards"-compileGuards ((GuardedRhs _ (Qualifier (Var (UnQual (Ident "otherwise"))):_) exp):_) = compileExp exp-compileGuards (GuardedRhs _ (Qualifier guard:_) exp : rest) =-  JsTernaryIf <$> fmap force (compileExp guard)-              <*> compileExp exp-              <*> compileGuards rest-compileGuards rhss = throwError . UnsupportedRhs . GuardedRhss $ rhss---- | Compile Haskell expression.-compileExp :: Exp -> Compile JsExp-compileExp exp =-  case exp of-    Paren exp                     -> compileExp exp--- Commented out: See #59---    Var (UnQual (Ident "return")) -> return (JsName (hjIdent "return"))-    Var qname                     -> return (JsName qname)-    Lit lit                       -> compileLit lit-    App exp1 exp2                 -> compileApp exp1 exp2-    InfixApp exp1 op exp2         -> compileInfixApp exp1 op exp2-    Let (BDecls decls) exp        -> compileLet decls exp-    List []                       -> return JsNull-    List xs                       -> compileList xs-    Tuple xs                      -> compileList xs-    If cond conseq alt            -> compileIf cond conseq alt-    Case exp alts                 -> compileCase exp alts-    Con (UnQual (Ident "True"))   -> return (JsLit (JsBool True))-    Con (UnQual (Ident "False"))  -> return (JsLit (JsBool False))-    Con exp                       -> return (JsName exp)-    Do stmts                      -> compileDoBlock stmts-    Lambda _ pats exp             -> compileLambda pats exp-    EnumFrom i                    -> do e <- compileExp i-                                        return (JsApp (JsName "enumFrom") [e])-    EnumFromTo i i'               -> do f <- compileExp i-                                        t <- compileExp i'-                                        return (JsApp (JsApp (JsName "enumFromTo") [f])-                                                      [t])-    RecConstr name fieldUpdates -> compileRecConstr name fieldUpdates-    RecUpdate rec  fieldUpdates -> updateRec rec fieldUpdates-    ExpTypeSig _ e _ -> compileExp e--    exp -> throwError (UnsupportedExpression exp)--instance CompilesTo Exp JsExp where compileTo = compileExp----- | Compile simple application.-compileApp :: Exp -> Exp -> Compile JsExp-compileApp exp1 exp2 = do-   flattenApps <- config configFlattenApps-   if flattenApps then method2 else method1-   where-  -- Method 1:-  -- In this approach code ends up looking like this:-  -- a(a(a(a(a(a(a(a(a(a(L)(c))(b))(0))(0))(y))(t))(a(a(F)(3*a(a(d)+a(a(f)/20))))*a(a(f)/2)))(140+a(f)))(y))(t)})-  -- Which might be OK for speed, but increases the JS stack a fair bit.-  method1 =-    JsApp <$> (forceFlatName <$> compileExp exp1)-          <*> fmap return (compileExp exp2)-  forceFlatName name = JsApp (JsName "_") [name]--  -- Method 2:-  -- In this approach code ends up looking like this:-  -- d(O,a,b,0,0,B,w,e(d(I,3*e(e(c)+e(e(g)/20))))*e(e(g)/2),140+e(g),B,w)}),d(K,g,e(c)+0.05))-  -- Which should be much better for the stack and readability, but probably not great for speed.-  method2 = fmap flatten $-    JsApp <$> compileExp exp1-          <*> fmap return (compileExp exp2)-  flatten (JsApp op args) =-   case op of-     JsApp l r -> JsApp l (r ++ args)-     _        -> JsApp (JsName "__") (op : args)-  flatten x = x---- | Compile an infix application, optimizing the JS cases.-compileInfixApp :: Exp -> QOp -> Exp -> Compile JsExp-compileInfixApp exp1 op exp2 = do-  config <- config id-  case getOp op of-    UnQual (Symbol symbol)-      | symbol `elem` words "* + - / < > || &&" -> do-          e1 <- compileExp exp1-          e2 <- compileExp exp2-          fn <- resolveOpToVar >=> compileExp $ op-          return $ JsApp (JsApp (force fn) [(forceInlinable config e1)]) [(forceInlinable config e2)]-    _ -> do-      var <- resolveOpToVar op-      compileExp (App (App var exp1) exp2)--  where getOp (QVarOp op) = op-        getOp (QConOp op) = op---- | Compile a list expression.-compileList :: [Exp] -> Compile JsExp-compileList xs = do-  exps <- mapM compileExp xs-  return (makeList exps)--makeList :: [JsExp] -> JsExp-makeList exps = (JsApp (JsName (hjIdent "list")) [JsList exps])---- | Compile an if.-compileIf :: Exp -> Exp -> Exp -> Compile JsExp-compileIf cond conseq alt =-  JsTernaryIf <$> fmap force (compileExp cond)-              <*> compileExp conseq-              <*> compileExp alt---- | Compile a lambda.-compileLambda :: [Pat] -> Exp -> Compile JsExp-compileLambda pats exp = do-  exp <- compileExp exp-  stmts <- foldM (\inner (param,pat) -> do-                   stmts <- compilePat (JsName param) pat inner-                   return [JsEarlyReturn (JsFun [param] (stmts ++ [unhandledcase param | not allfree]) Nothing)])-                 [JsEarlyReturn exp]-                 (reverse (zip uniqueNames pats))-  case stmts of-    [JsEarlyReturn fun@JsFun{}] -> return fun-    _ -> error "Unexpected statements in compileLambda"--  where unhandledcase = throw "unhandled case" . JsName-        allfree = all isWildCardPat pats---- | Compile case expressions.-compileCase :: Exp -> [Alt] -> Compile JsExp-compileCase exp alts = do-  exp <- compileExp exp-  pats <- fmap optimizePatConditions $ mapM (compilePatAlt (JsName (tmpName exp))) alts-  return $-    JsApp (JsFun [tmpName exp]-                 (concat pats)-                 (if any isWildCardAlt alts-                     then Nothing-                     else Just (throwExp "unhandled case" (JsName (tmpName exp)))))-          [exp]---- | Compile a do block.-compileDoBlock :: [Stmt] -> Compile JsExp-compileDoBlock stmts = do-  doblock <- foldM compileStmt Nothing (reverse stmts)-  maybe (throwError EmptyDoBlock) compileExp doblock---- | Compile a statement of a do block.-compileStmt :: Maybe Exp -> Stmt -> Compile (Maybe Exp)-compileStmt inner stmt =-  case inner of-    Nothing -> initStmt-    Just inner -> subsequentStmt inner--  where initStmt =-          case stmt of-            Qualifier exp -> return (Just exp)-            LetStmt{}     -> throwError LetUnsupported-            _             -> throwError InvalidDoBlock--        subsequentStmt inner =-          case stmt of-            Generator loc pat exp -> compileGenerator loc pat inner exp-            Qualifier exp -> return (Just (InfixApp exp-                                                    (QVarOp (UnQual (Symbol ">>")))-                                                    inner))-            LetStmt (BDecls binds) -> return (Just (Let (BDecls binds) inner))-            LetStmt _ -> throwError LetUnsupported-            RecStmt{} -> throwError RecursiveDoUnsupported--        compileGenerator srcloc pat inner exp = do-          let body = Lambda srcloc [pat] inner-          return (Just (InfixApp exp-                                 (QVarOp (UnQual (Symbol ">>=")))-                                 body))---- | Compile the given pattern against the given expression.-compilePatAlt :: JsExp -> Alt -> Compile [JsStmt]-compilePatAlt exp (Alt _ pat rhs _) = do-  alt <- compileGuardedAlt rhs-  compilePat exp pat [JsEarlyReturn alt]---- | Compile the given pattern against the given expression.-compilePat :: JsExp -> Pat -> [JsStmt] -> Compile [JsStmt]-compilePat exp pat body =-  case pat of-    PVar name       -> return $ JsVar (UnQual name) exp : body-    PApp cons pats  -> compilePApp cons pats exp body-    PLit literal    -> compilePLit exp literal body-    PParen pat      -> compilePat exp pat body-    PWildCard       -> return body-    pat@PInfixApp{} -> compileInfixPat exp pat body-    PList pats      -> compilePList pats body exp-    PTuple pats     -> compilePList pats body exp-    PAsPat name pat -> compilePAsPat exp name pat body-    pat             -> throwError (UnsupportedPattern pat)---- | Compile a literal value from a pattern match.-compilePLit :: JsExp -> Literal -> [JsStmt] -> Compile [JsStmt]-compilePLit exp literal body = do-  lit <- compileLit literal-  return [JsIf (equalExps exp lit)-               body-               []]---- | Compile as binding in pattern match-compilePAsPat :: JsExp -> Name -> Pat -> [JsStmt] -> Compile [JsStmt]-compilePAsPat exp name pat body = do-  x <- compilePat exp pat body-  return ([JsVar (UnQual name) exp] ++ x ++ body)---- | Compile a record construction with named fields--- | GHC will warn on uninitialized fields, they will be undefined in JS.-compileRecConstr :: QName -> [FieldUpdate] -> Compile JsExp-compileRecConstr name fieldUpdates = do-    let o = UnQual (Ident (map toLower (qname name)))-    -- var obj = new $_Type()-    let record = JsVar o (JsNew (constructorName name) [])-    setFields <- forM fieldUpdates $-           -- obj.field = value-           \(FieldUpdate (UnQual field) value) -> JsSetProp o (UnQual field) <$> compileExp value-    return $ JsApp (JsFun [] (record:setFields) (Just (JsName o))) []--updateRec :: Exp -> [FieldUpdate] -> Compile JsExp-updateRec rec fieldUpdates = do-    record <- force <$> compileExp rec-    let copyName = UnQual (Ident "$_record_to_update")-        copy = JsVar copyName-                     (JsRawExp ("Object.create(" ++ printJSString record ++ ")"))-    setFields <- forM fieldUpdates $-        \(FieldUpdate (UnQual field) value) ->-            JsSetProp copyName (UnQual field) <$> compileExp value-    return $ JsApp (JsFun [] (copy:setFields) (Just (JsName copyName))) []---- | Equality test for two expressions, with some optimizations.-equalExps :: JsExp -> JsExp -> JsExp-equalExps a b-  | isConstant a && isConstant b = JsEq a b-  | isConstant a = JsEq a (force b)-  | isConstant b = JsEq (force a) b-  | otherwise =-     JsApp (JsName (hjIdent "equal")) [a,b]---- | Is a JS expression a literal (constant)?-isConstant :: JsExp -> Bool-isConstant JsLit{} = True-isConstant _       = False---- | Compile a pattern application.-compilePApp :: QName -> [Pat] -> JsExp -> [JsStmt] -> Compile [JsStmt]-compilePApp cons pats exp body = do-  let forcedExp = force exp-  let boolIf b = return [JsIf (JsEq forcedExp (JsLit (JsBool b))) body []]-  case cons of-    -- Special-casing on the booleans.-    "True" -> boolIf True-    "False" -> boolIf False-    -- Everything else, generic:-    _ -> do-      rf <- lookup (Ident (qname cons)) <$> gets stateRecords-      let recordFields =-            fromMaybe-              (error $ "Constructor '" ++ qname cons ++-                       "' was not found in stateRecords, did you try running this through GHC first?")-              rf-      substmts <- foldM (\body (Ident field,pat) ->-                             compilePat (JsGetProp forcedExp (fromString field)) pat body)-                  body-                  (reverse (zip recordFields pats))-      return [JsIf (forcedExp `JsInstanceOf` constructorName cons)-                   substmts-                   []]---- | Compile a pattern list.-compilePList :: [Pat] -> [JsStmt] -> JsExp -> Compile [JsStmt]-compilePList [] body exp =-  return [JsIf (JsEq (force exp) JsNull) body []]-compilePList pats body exp = do-  let forcedExp = force exp-  foldM (\body (i,pat) -> compilePat (JsApp (JsApp (JsName (hjIdent "index"))-                                                   [JsLit (JsInt i)])-                                            [forcedExp])-                                     pat body)-        body-        (reverse (zip [0..] pats))---- | Compile an infix pattern (e.g. cons and tuples.)-compileInfixPat :: JsExp -> Pat -> [JsStmt] -> Compile [JsStmt]-compileInfixPat exp pat@(PInfixApp left (Special cons) right) body =-  case cons of-    Cons -> do-      let forcedExp = JsName (tmpName exp)-          x = JsGetProp forcedExp "car"-          xs = JsGetProp forcedExp "cdr"-      rightMatch <- compilePat xs right body-      leftMatch <- compilePat x left rightMatch-      return [JsVar (tmpName exp) (force exp)-             ,JsIf (JsInstanceOf forcedExp (hjIdent "Cons"))-                   leftMatch-                   []]-    _ -> throwError (UnsupportedPattern pat)-compileInfixPat _ pat _ = throwError (UnsupportedPattern pat)---- | Compile a guarded alt.-compileGuardedAlt :: GuardedAlts -> Compile JsExp-compileGuardedAlt alt =-  case alt of-    UnGuardedAlt exp -> compileExp exp-    alt -> throwError (UnsupportedGuardedAlts alt)---- | Compile a let expression.-compileLet :: [Decl] -> Exp -> Compile JsExp-compileLet decls exp = do-  body <- compileExp exp-  binds <- mapM compileLetDecl decls-  return (JsApp (JsFun [] (concat binds) (Just body)) [])---- | Compile let declaration.-compileLetDecl :: Decl -> Compile [JsStmt]-compileLetDecl decl =-  case decl of-    decl@PatBind{} -> compileDecls False [decl]-    decl@FunBind{} -> compileDecls False [decl]-    TypeSig{}      -> return []-    _              -> throwError (UnsupportedLetBinding decl)---- | Compile Haskell literal.-compileLit :: Literal -> Compile JsExp-compileLit lit =-  case lit of-    Char ch       -> return (JsLit (JsChar ch))-    Int integer   -> return (JsLit (JsInt (fromIntegral integer))) -- FIXME:-    Frac rational -> return (JsLit (JsFloating (fromRational rational)))-    -- TODO: Use real JS strings instead of array, probably it will-    -- lead to the same result.-    String string -> return (JsApp (JsName (hjIdent "list"))-                                   [JsLit (JsStr string)])-    lit           -> throwError (UnsupportedLiteral lit)------------------------------------------------------------------------------------- Compilation utilities---- | Generate unique names.-uniqueNames :: [JsParam]-uniqueNames = map (fromString . ("$_" ++))-            $ map return "abcxyz" ++-              zipWith (:) (cycle "v")-                          (map show [1 :: Integer ..])---- | Optimize pattern matching conditions by merging conditions in common.-optimizePatConditions :: [[JsStmt]] -> [[JsStmt]]-optimizePatConditions = concatMap merge . groupBy sameIf where-  sameIf [JsIf cond1 _ _] [JsIf cond2 _ _] = cond1 == cond2-  sameIf _ _ = False-  merge xs@([JsIf cond _ _]:_) =-    [[JsIf cond (concat (optimizePatConditions (map getIfConsequent xs))) []]]-  merge noifs = noifs-  getIfConsequent [JsIf _ cons _] = cons-  getIfConsequent other = other---- | Throw a JS exception.-throw :: String -> JsExp -> JsStmt-throw msg exp = JsThrow (JsList [JsLit (JsStr msg),exp])---- | Throw a JS exception (in an expression).-throwExp :: String -> JsExp -> JsExp-throwExp msg exp = JsThrowExp (JsList [JsLit (JsStr msg),exp])---- | Is an alt a wildcard?-isWildCardAlt :: Alt -> Bool-isWildCardAlt (Alt _ pat _ _) = isWildCardPat pat---- | Is a pattern a wildcard?-isWildCardPat :: Pat -> Bool-isWildCardPat PWildCard{} = True-isWildCardPat PVar{}      = True-isWildCardPat _           = False---- | A temporary name for testing conditions and such.-tmpName :: JsExp -> JsName-tmpName exp =-  fromString $-    case exp of-      JsName (qname -> x) -> "$_" ++ x-      _ -> ":tmp"---- | Wrap an expression in a thunk.-thunk :: JsExp -> JsExp--- thunk exp = JsNew (hjIdent "Thunk") [JsFun [] [] (Just exp)]-thunk exp =-  case exp of-    -- JS constants don't need to be in thunks, they're already strict.-    JsLit{} -> exp-    JsName "true" -> exp-    JsName "false" -> exp-    -- Functions (e.g. lets) used for introducing a new lexical scope-    -- aren't necessary inside a thunk. This is a simple aesthetic-    -- optimization.-    JsApp fun@JsFun{} [] -> JsNew ":thunk" [fun]-    -- Otherwise make a regular thunk.-    _ -> JsNew ":thunk" [JsFun [] [] (Just exp)]---- | Wrap an expression in a thunk.-stmtsThunk :: [JsStmt] -> JsExp-stmtsThunk stmts = JsNew ":thunk" [JsFun [] stmts Nothing]---- | Translate: JS → Fay.-jsToFay :: FundamentalType -> JsExp -> JsExp-jsToFay typ exp = JsApp (JsName (hjIdent "jsToFay"))-                        [typeRep typ,exp]---- | Force an expression in a thunk.-force :: JsExp -> JsExp-force exp-  | isConstant exp = exp-  | otherwise = JsApp (JsName "_") [exp]---- | Force an expression in a thunk.-forceInlinable :: CompileConfig -> JsExp -> JsExp-forceInlinable config exp-  | isConstant exp = exp-  | configInlineForce config =-    JsParen (JsTernaryIf (exp `JsInstanceOf` ":thunk")-                         (JsApp (JsName "_") [exp])-                         exp)-  | otherwise = JsApp (JsName "_") [exp]---- | Resolve operators to only built-in (for now) functions.-resolveOpToVar :: QOp -> Compile Exp-resolveOpToVar op =-  case getOp op of-    UnQual (Symbol symbol)-      | symbol == "*"   -> return (Var (hjIdent "mult"))-      | symbol == "+"   -> return (Var (hjIdent "add"))-      | symbol == "-"   -> return (Var (hjIdent "sub"))-      | symbol == "/"   -> return (Var (hjIdent "div"))-      | symbol == "=="  -> return (Var (hjIdent "eq"))-      | symbol == "/="  -> return (Var (hjIdent "neq"))-      | symbol == ">"   -> return (Var (hjIdent "gt"))-      | symbol == "<"   -> return (Var (hjIdent "lt"))-      | symbol == ">="  -> return (Var (hjIdent "gte"))-      | symbol == "<="  -> return (Var (hjIdent "lte"))-      | symbol == "&&"  -> return (Var (hjIdent "and"))-      | symbol == "||"  -> return (Var (hjIdent "or"))-      | otherwise       -> return (Var (fromString symbol))-    n@(UnQual Ident{})  -> return (Var n)-    Special Cons        -> return (Var (hjIdent "cons"))-    _                   -> throwError (UnsupportedOperator op)--  where getOp (QVarOp op) = op-        getOp (QConOp op) = op---- | Make an identifier from the built-in HJ module.-hjIdent :: String -> QName-hjIdent = Qual (ModuleName "Fay") . Ident---- | Make a top-level binding.-bindToplevel :: SrcLoc -> Bool -> QName -> JsExp -> Compile JsStmt-bindToplevel srcloc toplevel name exp = do-  exportAll <- gets stateExportAll-  when (toplevel && exportAll) $ emitExport (EVar name)-  return (JsMappedVar srcloc name exp)---- | Emit exported names.-emitExport :: ExportSpec -> Compile ()-emitExport spec =-  case spec of-    EVar (UnQual name) -> modify $ \s -> s { stateExports = name : stateExports s }-    EVar _             -> error "Emitted a qualifed export, not supported."-    _ -> throwError (UnsupportedExportSpec spec)------------------------------------------------------------------------------------- Utilities---- | Parse result.-parseResult :: ((SrcLoc,String) -> b) -> (a -> b) -> ParseResult a -> b-parseResult fail ok result =-  case result of-    ParseOk a -> ok a-    ParseFailed srcloc msg -> fail (srcloc,msg)---- | Get a config option.-config :: (CompileConfig -> a) -> Compile a-config f = gets (f . stateConfig)--instance IsString Name where fromString = Ident+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE RecordWildCards       #-}+{-# LANGUAGE TypeSynonymInstances  #-}+{-# LANGUAGE ViewPatterns          #-}++module Language.Fay+  (module Language.Fay.Types+  ,compileFile+  ,compileFromTo+  ,compileFromToAndGenerateHtml+  ,toJsName+  ,showCompileError)+   where++import           Language.Fay.Compiler        (compileToplevelModule,+                                               compileViaStr)+import           Language.Fay.Print+import           Language.Fay.Types++import           Control.Monad+import           Data.List+import           Language.Haskell.Exts        (prettyPrint)+import           Language.Haskell.Exts.Syntax+import           Paths_fay+import           System.FilePath++-- | Compile the given file and write the output to the given path, or+-- if nothing given, stdout.+compileFromTo :: CompileConfig -> FilePath -> Maybe FilePath -> IO ()+compileFromTo config filein fileout = do+  result <- maybe (compileFile config filein)+                  (compileFromToAndGenerateHtml config filein)+                  fileout+  case result of+    Right out -> maybe (putStrLn out) (flip writeFile out) fileout+    Left err -> error $ showCompileError $ err++-- | Compile the given file and write to the output, also generate any HTML.+compileFromToAndGenerateHtml :: CompileConfig -> FilePath -> FilePath -> IO (Either CompileError String)+compileFromToAndGenerateHtml config filein fileout = do+  result <- compileFile config { configFilePath = Just filein } filein+  case result of+    Right out -> do+      when (configHtmlWrapper config) $+        writeFile (replaceExtension fileout "html") $ unlines [+            "<!doctype html>"+          , "<html>"+          , "  <head>"+          ,"    <meta http-equiv='Content-Type' content='text/html; charset=utf-8'>"+          , unlines . map ("    "++) . map makeScriptTagSrc $ configHtmlJSLibs config+          , "    " ++ makeScriptTagSrc relativeJsPath+          , "    </script>"+          , "  </head>"+          , "  <body>"+          , "  </body>"+          , "</html>"]+      return (Right out)+            where relativeJsPath = makeRelative (dropFileName fileout) fileout+                  makeScriptTagSrc :: FilePath -> String+                  makeScriptTagSrc = \s ->+                    "<script type=\"text/javascript\" src=\"" ++ s ++ "\"></script>"+    Left err -> return (Left err)++-- | Compile the given file.+compileFile :: CompileConfig -> FilePath -> IO (Either CompileError String)+compileFile config filein = do+  runtime <- getDataFileName "js/runtime.js"+  srcdir <- fmap (takeDirectory . takeDirectory . takeDirectory) (getDataFileName "src/Language/Fay/Stdlib.hs")+  raw <- readFile runtime+  hscode <- readFile filein+  compileToModule filein+                  config { configDirectoryIncludes = configDirectoryIncludes config ++ [srcdir]+                         }+                  raw+                  compileToplevelModule+                  hscode++-- | Compile the given module to a runnable module.+compileToModule :: (Show from,Show to,CompilesTo from to)+               => FilePath+               -> CompileConfig -> String -> (from -> Compile to) -> String+               -> IO (Either CompileError String)+compileToModule filepath config raw with hscode = do+  result <- compileViaStr filepath config with hscode+  case result of+    Left err -> return (Left err)+    Right (PrintState{..},state) ->+      return $ Right $ (generate (concat (reverse psOutput))+                                 (stateExports state)+                                 (stateModuleName state))++  where generate jscode exports (ModuleName (clean -> modulename)) = unlines+          ["/** @constructor"+          ,"*/"+          ,"var " ++ modulename ++ " = function(){"+          ,raw+          ,jscode+          ,"// Exports"+          ,unlines (map printExport exports)+          ,"// Built-ins"+          ,"this._ = _;"+          ,if configExportBuiltins config+              then unlines ["this.$           = $;"+                           ,"this.$fayToJs    = Fay$$fayToJs;"+                           ,"this.$jsToFay    = Fay$$jsToFay;"+                           ]+              else ""+          ,"};"+          ,if not (configLibrary config)+              then unlines [";"+                           ,"var main = new " ++ modulename ++ "();"+                           ,"main._(main." ++ modulename ++ "$main);"+                           ]+              else ""+          ]+        clean ('.':cs) = '$' : clean cs+        clean (c:cs)   = c : clean cs+        clean [] = []++-- | Print an this.x = x; export out.+printExport :: QName -> String+printExport name =+  printJSString (JsSetProp JsThis+                           (JsNameVar name)+                           (JsName (JsNameVar name)))++-- | Convert a Haskell filename to a JS filename.+toJsName :: String -> String+toJsName x = case reverse x of+               ('s':'h':'.': (reverse -> file)) -> file ++ ".js"+               _ -> x++-- | Print a compile error for human consumption.+showCompileError :: CompileError -> String+showCompileError e =+  case e of+    ParseError _ err -> err+    UnsupportedDeclaration d -> "unsupported declaration: " ++ prettyPrint d+    UnsupportedExportSpec es -> "unsupported export specification: " ++ prettyPrint es+    UnsupportedMatchSyntax m -> "unsupported match/binding syntax: " ++ prettyPrint m+    UnsupportedWhereInMatch m -> "unsupported `where' syntax: " ++ prettyPrint m+    UnsupportedExpression expr -> "unsupported expression syntax: " ++ prettyPrint expr+    UnsupportedQualStmt stmt -> "unsupported list qualifier: " ++ prettyPrint stmt+    UnsupportedLiteral lit -> "unsupported literal syntax: " ++ prettyPrint lit+    UnsupportedLetBinding d -> "unsupported let binding: " ++ prettyPrint d+    UnsupportedOperator qop -> "unsupported operator syntax: " ++ prettyPrint qop+    UnsupportedPattern pat -> "unsupported pattern syntax: " ++ prettyPrint pat+    UnsupportedRhs rhs -> "unsupported right-hand side syntax: " ++ prettyPrint rhs+    UnsupportedGuardedAlts ga -> "unsupported guarded alts: " ++ prettyPrint ga+    EmptyDoBlock -> "empty `do' block"+    UnsupportedModuleSyntax{} -> "unsupported module syntax (may be supported later)"+    LetUnsupported -> "let not supported here"+    InvalidDoBlock -> "invalid `do' block"+    RecursiveDoUnsupported -> "recursive `do' isn't supported"+    FfiNeedsTypeSig d -> "your FFI declaration needs a type signature: " ++ prettyPrint d+    FfiFormatBadChars cs -> "invalid characters for FFI format string: " ++ show cs+    FfiFormatNoSuchArg i -> "no such argument in FFI format string: " ++ show i+    FfiFormatIncompleteArg -> "incomplete `%' syntax in FFI format string"+    FfiFormatInvalidJavaScript code err -> "invalid JavaScript code in FFI format string:\n"+                                           ++ err ++ "\nin " ++ code+    UnsupportedFieldPattern p -> "unsupported field pattern: " ++ prettyPrint p+    UnsupportedImport i -> "unsupported import syntax, we're too lazy: " ++ prettyPrint i+    Couldn'tFindImport i places ->+      "could not find an import in the path: " ++ prettyPrint i ++ ", \n" +++      "searched in these places: " ++ intercalate ", " places+    UnableResolveUnqualified name -> "unable to resolve unqualified name " ++ prettyPrint name+    UnableResolveQualified qname -> "unable to resolve qualified names " ++ prettyPrint qname

@@ -1,149 +1,950 @@-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings     #-}-{-# LANGUAGE TypeSynonymInstances  #-}-{-# LANGUAGE ViewPatterns          #-}--module Language.Fay.Compiler where--import           Language.Fay                 (compileToplevelModule, compileViaStr, prettyPrintString)-import           Language.Fay.Types-import           Language.Fay.Print--import           Control.Monad-import           Language.Haskell.Exts.Syntax-import           Paths_fay-import           System.FilePath-import           Text.Groom---- | A result of something the compiler writes.-class Writer a where-  writeout :: a -> String -> IO ()---- | Something to feed into the compiler.-class Reader a where-  readin :: a -> IO String---- | Simple file writer.-instance Writer FilePath where-  writeout = writeFile---- | Simple file reader.-instance Reader FilePath where-  readin = readFile---- | Compile file program to…-compileFromTo :: CompileConfig -> FilePath -> FilePath -> IO ()-compileFromTo config filein fileout = do-  result <- compileFromToReturningStatus config filein fileout-  case result of-    Right () -> return ()-    Left err -> error . groom $ err---- | Compile file program to…-compileFromToReturningStatus :: CompileConfig -> FilePath -> FilePath -> IO (Either CompileError ())-compileFromToReturningStatus config filein fileout = do-  result <- compileFile config { configFilePath = Just filein } filein-  case result of-    Right out -> do-      writeFile fileout out-      when (configHtmlWrapper config) $-        writeFile (replaceExtension fileout "html") $ unlines [-            "<!doctype html>"-          , "<html>"-          , "  <head>"-          ,"    <meta http-equiv='Content-Type' content='text/html; charset=utf-8'>"-          , unlines . map ("    "++) . map makeScriptTagSrc $ configHtmlJSLibs config-          , "    " ++ makeScriptTagSrc relativeJsPath-          , "    </script>"-          , "  </head>"-          , "  <body>"-          , "  </body>"-          , "</html>"]-      return (Right ())-            where relativeJsPath = makeRelative (dropFileName fileout) fileout-                  makeScriptTagSrc :: FilePath -> String-                  makeScriptTagSrc = \s ->-                    "<script type=\"text/javascript\" src=\"" ++ s ++ "\"></script>"-    Left err -> return (Left err)---- | Compile readable/writable values.-compileReadWrite :: (Reader r, Writer w) => CompileConfig -> r -> w -> IO ()-compileReadWrite config reader writer = do-  result <- compileFile config reader-  case result of-    Right out -> do-      writeout writer out-    Left err -> error . groom $ err---- | Compile the given file.-compileFile :: (Reader r) => CompileConfig -> r -> IO (Either CompileError String)-compileFile config filein = do-  runtime <- getDataFileName "js/runtime.js"-  stdlibpath <- getDataFileName "hs/stdlib.hs"-  stdlibpathprelude <- getDataFileName "src/Language/Fay/Stdlib.hs"-  raw <- readFile runtime-  stdlib <- readFile stdlibpath-  stdlibprelude <- readFile stdlibpathprelude-  hscode <- readin filein-  compileProgram config-                 raw-                 compileToplevelModule-                 (hscode ++ "\n" ++ stdlib ++ "\n" ++ strip stdlibprelude)--  where strip = unlines . dropWhile (/="-- START") . lines---- | Compile the given module to a runnable program.-compileProgram :: (Show from,Show to,CompilesTo from to)-               => CompileConfig -> String -> (from -> Compile to) -> String-               -> IO (Either CompileError String)-compileProgram config raw with hscode = do-  result <- compileViaStr config with hscode-  case result of-    Left err -> return (Left err)-    Right (jscode,state) -> fmap Right $-      let out = generate jscode (stateExports state) (stateModuleName state)-      in if configPrettyPrint config-            then prettyPrintString out-            else return out--  where generate jscode exports (ModuleName (clean -> modulename)) = unlines-          ["/** @constructor"-          ,"*/"-          ,"var " ++ modulename ++ " = function(){"-          ,raw-          ,jscode-          ,"// Exports"-          ,unlines (map printExport exports)-          ,"// Built-ins"-          ,"this._ = _;"-          ,if configExportBuiltins config-              then unlines ["this.$           = $;"-                           ,"this.$fayToJs    = Fay$$fayToJs;"-                           ,"this.$jsToFay    = Fay$$jsToFay;"-                           ]-              else ""-          ,"};"-          ,if not (configLibrary config)-              then unlines [";"-                           ,"var main = new " ++ modulename ++ "();"-                           ,"main._(main.main);"-                           ]-              else ""-          ]-        clean ('.':cs) = '$' : clean cs-        clean (c:cs)   = c : clean cs-        clean [] = []---- | Print an this.x = x; export out.-printExport :: Name -> String-printExport name =-  printJSString (JsSetProp ":this"-                           (UnQual name)-                           (JsName (UnQual name)))---- | Convert a Haskell filename to a JS filename.-toJsName :: String -> String-toJsName x = case reverse x of-               ('s':'h':'.': (reverse -> file)) -> file ++ ".js"-               _ -> x+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE RecordWildCards       #-}+{-# LANGUAGE TupleSections         #-}+{-# LANGUAGE ViewPatterns          #-}+{-# OPTIONS -Wall -fno-warn-name-shadowing -fno-warn-orphans #-}++-- | The Haskell→Javascript compiler.++module Language.Fay.Compiler+  (runCompile+  ,compileViaStr+  ,compileForDocs+  ,compileToAst+  ,compileModule+  ,compileExp+  ,compileDecl+  ,printCompile+  ,printTestCompile+  ,compileToplevelModule)+  where++import           Language.Fay.Compiler.FFI+import           Language.Fay.Compiler.Optimizer+import           Language.Fay.Compiler.Misc+import           Language.Fay.Print         (printJSString)+import           Language.Fay.Types++import           Control.Applicative+import           Control.Monad.Error+import           Control.Monad.IO+import           Control.Monad.State+import           Data.Default               (def)+import           Data.List+import           Data.List.Extra+import           Data.Map                   (Map)+import qualified Data.Map                   as M+import           Data.Maybe+import           Language.Haskell.Exts+import           System.Directory           (doesFileExist)+import           System.FilePath            ((</>))+import           System.IO+import           System.Process.Extra++--------------------------------------------------------------------------------+-- Top level entry points++-- | Run the compiler.+runCompile :: CompileState -> Compile a -> IO (Either CompileError (a,CompileState))+runCompile state m = runErrorT (runStateT (unCompile m) state) where++-- | Compile a Haskell source string to a JavaScript source string.+compileViaStr :: (Show from,Show to,CompilesTo from to)+              => FilePath+              -> CompileConfig+              -> (from -> Compile to)+              -> String+              -> IO (Either CompileError (PrintState,CompileState))+compileViaStr filepath config with from = do+  cs <- defaultCompileState config+  runCompile (cs { stateFilePath = filepath })+             (parseResult (throwError . uncurry ParseError)+                          (fmap (\x -> execState (runPrinter (printJS x)) printConfig) . with)+                          (parseFay filepath from))++  where printConfig = def { psPretty = configPrettyPrint config }++-- | Compile a Haskell source string to a JavaScript source string.+compileToAst :: (Show from,Show to,CompilesTo from to)+              => FilePath+              -> CompileState+              -> (from -> Compile to)+              -> String+              -> IO (Either CompileError (to,CompileState))+compileToAst filepath state with from =+  runCompile state+             (parseResult (throwError . uncurry ParseError)+                          with+                          (parseFay filepath from))++-- | Parse some Fay code.+parseFay :: Parseable ast => FilePath -> String -> ParseResult ast+parseFay filepath = parseWithMode parseMode { parseFilename = filepath }++-- | The parse mode for Fay.+parseMode :: ParseMode+parseMode = defaultParseMode { extensions =+  [GADTs,StandaloneDeriving,EmptyDataDecls,TypeOperators,RecordWildCards,NamedFieldPuns] }++-- | Compile the given input and print the output out prettily.+printCompile :: (Show from,Show to,CompilesTo from to)+              => CompileConfig+              -> (from -> Compile to)+              -> String+              -> IO ()+printCompile config with from = do+  result <- compileViaStr "<interactive>" config { configPrettyPrint = True } with from+  case result of+    Left err -> print err+    Right (PrintState{..},_) -> do+      putStrLn (concat (reverse (psOutput)))++-- | Compile a String of Fay and print it as beautified JavaScript.+printTestCompile :: String -> IO ()+printTestCompile = printCompile def { configWarn = False,+  configDirectoryIncludes = [] } compileModule++-- | Compile the given Fay code for the documentation. This is+-- specialised because the documentation isn't really “real”+-- compilation.+compileForDocs :: Module -> Compile [JsStmt]+compileForDocs mod = do+  initialPass mod+  compileModule mod++-- | Compile the top-level Fay module.+compileToplevelModule :: Module -> Compile [JsStmt]+compileToplevelModule mod@(Module _ (ModuleName modulename) _ _ _ _ _)  = do+  cfg <- gets stateConfig+  when (configTypecheck cfg) $+    typecheck (configDirectoryIncludes cfg) [] (configWall cfg) $+      fromMaybe modulename $ configFilePath cfg+  initialPass mod+  cs <- liftIO $ defaultCompileState def+  modify $ \s -> s { stateImported = stateImported cs }+  stmts <- compileModule mod+  fay2js <- do syms <- gets stateFayToJs+               return $ if null syms then [] else [fayToJsDispatcher syms]+  js2fay <- do syms <- gets stateJsToFay+               return $ if null syms then [] else [jsToFayDispatcher syms]+  let maybeOptimize = if configOptimize cfg then runOptimizer optimizeToplevel else id+  return (maybeOptimize (stmts ++ fay2js ++ js2fay))++--------------------------------------------------------------------------------+-- Initial pass-through collecting record definitions++initialPass :: Module -> Compile ()+initialPass (Module _ _ _ Nothing _ imports decls) = do+  mapM_ initialPass_import (map translateModuleName imports)+  mapM_ (initialPass_decl True) decls++initialPass mod = throwError (UnsupportedModuleSyntax mod)++initialPass_import :: ImportDecl -> Compile ()+initialPass_import (ImportDecl _ "Prelude" _ _ _ _ _) = return ()+initialPass_import (ImportDecl _ name False _ Nothing Nothing Nothing) = do+  void $ unlessImported name $ \filepath contents -> do+    state <- gets id+    result <- liftIO $ initialPass_records filepath state initialPass contents+    case result of+      Right ((),st) -> do+        -- Merges the state gotten from passing through an imported+        -- module with the current state. We can assume no duplicate+        -- records exist since GHC would pick that up.+        modify $ \s -> s { stateRecords = stateRecords st+                         , stateImported = stateImported st+                         }+      Left err -> throwError err+    return []++initialPass_import i = throwError $ UnsupportedImport i++initialPass_records :: (Show from,Parseable from)+                    => FilePath+                    -> CompileState+                    -> (from -> Compile ())+                    -> String+                    -> IO (Either CompileError ((),CompileState))+initialPass_records filepath compileState with from =+  runCompile compileState+             (parseResult (throwError . uncurry ParseError)+                          with+                          (parseFay filepath from))++initialPass_decl :: Bool -> Decl -> Compile ()+initialPass_decl toplevel decl =+  case decl of+    DataDecl _ DataType _ _ _ constructors _ -> initialPass_dataDecl toplevel decl constructors+    GDataDecl _ DataType _l _i _v _n decls _ -> initialPass_dataDecl toplevel decl (map convertGADT decls)+    _ -> return ()++-- | Collect record definitions and store record name and field names.+-- A ConDecl will have fields named slot1..slotN+initialPass_dataDecl :: Bool -> Decl -> [QualConDecl] -> Compile ()+initialPass_dataDecl _ _decl constructors =+  forM_ constructors $ \(QualConDecl _ _ _ condecl) ->+    case condecl of+      ConDecl name types -> do+        let fields =  map (Ident . ("slot"++) . show . fst) . zip [1 :: Integer ..] $ types+        addRecordState name fields+      InfixConDecl _t1 name _t2 ->+        addRecordState name ["slot1", "slot2"]+      RecDecl name fields' -> do+        let fields = concatMap fst fields'+        addRecordState name fields++  where+    addRecordState :: Name -> [Name] -> Compile ()+    addRecordState name fields = modify $ \s -> s+      { stateRecords = (UnQual name,map UnQual fields) : stateRecords s }++--------------------------------------------------------------------------------+-- Typechecking++typecheck :: [FilePath] -> [String] -> Bool -> String -> Compile ()+typecheck includeDirs ghcFlags wall fp = do+  res <- liftIO $ readAllFromProcess' "ghc" (+    ["-fno-code", "-package fay", "-XNoImplicitPrelude", fp] ++ map ("-i" ++) includeDirs ++ ghcFlags ++ wallF) ""+  either error (warn . fst) res+   where+    wallF | wall = ["-Wall"]+          | otherwise = []++--------------------------------------------------------------------------------+-- Compilers++-- | Compile Haskell module.+compileModule :: Module -> Compile [JsStmt]+compileModule (Module _ modulename _pragmas Nothing exports imports decls) = do+  modify $ \s -> s { stateModuleName = modulename+                   , stateExportAll = isNothing exports+                   , stateExports = []+                   }+  imported <- fmap concat (mapM (compileImport . translateModuleName) imports)+  current <- compileDecls True decls+  -- If an export list is given we populate it beforehand,+  -- if not then bindToplevel will export each declaration when it's visited.+  mapM_ emitExport (fromMaybe [] exports)+  return (imported ++ current)+compileModule mod = throwError (UnsupportedModuleSyntax mod)++translateModuleName :: ImportDecl -> ImportDecl+-- The *.Prelude module doesn't contain actual code, but code to+-- appease GHC. The real code is in Stdlib, which could also be+-- imported directly, but it seems nicer to use Prelude. And maybe we+-- can fix this in the future so that Prelude contains the real+-- code. Doubt it, but it could happen.+translateModuleName (ImportDecl a (ModuleName "Language.Fay.Prelude") b c d e f) =+  (ImportDecl a (ModuleName "Language.Fay.Stdlib") b c d e f)+translateModuleName x = x++warn :: String -> Compile ()+warn "" = return ()+warn w = do+  shouldWarn <- configWarn <$> gets stateConfig+  when shouldWarn . liftIO . hPutStrLn stderr $ "Warning: " ++ w++instance CompilesTo Module [JsStmt] where compileTo = compileModule++findImport :: [FilePath] -> ModuleName -> Compile (FilePath,String)+findImport alldirs mname = go alldirs mname where+  go (dir:dirs) name = do+    exists <- io (doesFileExist path)+    if exists+      then fmap (path,) (fmap stdlibHack (io (readFile path)))+      else go dirs name+    where+      path = dir </> replace '.' '/' (prettyPrint name) ++ ".hs"+      replace c r = map (\x -> if x == c then r else x)+  go [] name =+    throwError $ Couldn'tFindImport name alldirs++  stdlibHack+    | mname == ModuleName "Language.Fay.Stdlib" = \s -> s ++ "\n\ndata Maybe a = Just a | Nothing"+    | otherwise = id++-- | Compile the given import.+compileImport :: ImportDecl -> Compile [JsStmt]+compileImport (ImportDecl _ "Prelude" _ _ _ _ _) = return []+compileImport (ImportDecl _ name False _ Nothing Nothing Nothing) = do+  unlessImported name $ \filepath contents -> do+    state <- gets id+    result <- liftIO $ compileToAst filepath state compileModule contents+    case result of+      Right (stmts,state) -> do+        modify $ \s -> s { stateFayToJs  = stateFayToJs state+                         , stateJsToFay  = stateJsToFay state+                         , stateImported = stateImported state+                         , stateScope    = mergeScopes (addExportsToScope (stateExports state) (stateScope s))+                                                       (stateScope state)+                         }+        return stmts+      Left err -> throwError err+compileImport i = throwError $ UnsupportedImport i++-- | Add the new scopes to the old one, stripping out local bindings.+mergeScopes :: Map Name [NameScope] -> Map Name [NameScope] -> Map Name [NameScope]+mergeScopes old new =+  M.map (filter (/=ScopeBinding))+        (foldr (\(key,val) -> M.insertWith (++) key val) old (M.assocs new))++-- | Add+addExportsToScope :: [QName] -> Map Name [NameScope] -> Map Name [NameScope]+addExportsToScope exports mapping = foldr copy mapping exports where+  copy e =+    case e of+      Qual modname name -> M.insertWith (++) name [ScopeImported modname Nothing]+      UnQual name       -> error $ "Exports should not be unqualified: " ++ prettyPrint name+      Special{}         -> error $ "Don't be silly."++-- | Don't re-import the same modules.+unlessImported :: ModuleName -> (FilePath -> String -> Compile [JsStmt]) -> Compile [JsStmt]+unlessImported name importIt = do+  imported <- gets stateImported+  case lookup name imported of+    Just _ -> return []+    Nothing -> do+      dirs <- configDirectoryIncludes <$> gets stateConfig+      (filepath,contents) <- findImport dirs name+      modify $ \s -> s { stateImported = (name,filepath) : imported }+      importIt filepath contents++-- | Compile Haskell declaration.+compileDecls :: Bool -> [Decl] -> Compile [JsStmt]+compileDecls toplevel decls =+  case decls of+    [] -> return []+    (TypeSig _ _ sig:bind@PatBind{}:decls) -> appendM (scoped (compilePatBind toplevel (Just sig) bind))+                                                      (compileDecls toplevel decls)+    (decl:decls) -> appendM (scoped (compileDecl toplevel decl))+                            (compileDecls toplevel decls)++  where appendM m n = do x <- m+                         xs <- n+                         return (x ++ xs)+        scoped = if toplevel then withScope else id++-- | Compile a declaration.+compileDecl :: Bool -> Decl -> Compile [JsStmt]+compileDecl toplevel decl =+  case decl of+    pat@PatBind{} -> compilePatBind toplevel Nothing pat+    FunBind matches -> compileFunCase toplevel matches+    DataDecl _ DataType _ _ _ constructors _ -> compileDataDecl toplevel decl constructors+    GDataDecl _ DataType _l _i _v _n decls _ -> compileDataDecl toplevel decl (map convertGADT decls)+    -- Just ignore type aliases and signatures.+    TypeDecl{} -> return []+    TypeSig{} -> return []+    InfixDecl{} -> return []+    ClassDecl{} -> return []+    InstDecl{} -> return [] -- FIXME: Ignore.+    DerivDecl{} -> return []+    _ -> throwError (UnsupportedDeclaration decl)++instance CompilesTo Decl [JsStmt] where compileTo = compileDecl True++-- | Compile a top-level pattern bind.+compilePatBind :: Bool -> Maybe Type -> Decl -> Compile [JsStmt]+compilePatBind toplevel sig pat =+  case pat of+    PatBind srcloc (PVar ident) Nothing (UnGuardedRhs rhs) (BDecls []) ->+      case ffiExp rhs of+        Just formatstr -> case sig of+          Just sig -> compileFFI srcloc ident formatstr sig+          Nothing  -> throwError (FfiNeedsTypeSig pat)+        _ -> compileUnguardedRhs srcloc toplevel ident rhs+    PatBind srcloc (PVar ident) Nothing (UnGuardedRhs rhs) bdecls -> do+      compileUnguardedRhs srcloc toplevel ident (Let bdecls rhs)+    _ -> throwError (UnsupportedDeclaration pat)++  where ffiExp (App (Var (UnQual (Ident "ffi"))) (Lit (String formatstr))) = Just formatstr+        ffiExp _ = Nothing++-- | Compile a normal simple pattern binding.+compileUnguardedRhs :: SrcLoc -> Bool -> Name -> Exp -> Compile [JsStmt]+compileUnguardedRhs srcloc toplevel ident rhs = do+  bindVar ident+  withScope $ do+    body <- compileExp rhs+    bind <- bindToplevel srcloc toplevel ident (thunk body)+    return [bind]++convertGADT :: GadtDecl -> QualConDecl+convertGADT d =+  case d of+    GadtDecl srcloc name typ -> QualConDecl srcloc tyvars context+                                            (ConDecl name (convertFunc typ))+  where tyvars = []+        context = []+        convertFunc (TyCon _) = []+        convertFunc (TyFun x xs) = UnBangedTy x : convertFunc xs+        convertFunc (TyParen x) = convertFunc x+        convertFunc _ = []++-- | Compile a data declaration.+compileDataDecl :: Bool -> Decl -> [QualConDecl] -> Compile [JsStmt]+compileDataDecl toplevel _decl constructors =+  fmap concat $+    forM constructors $ \(QualConDecl srcloc _ _ condecl) ->+      case condecl of+        ConDecl name types  -> do+          let fields =  map (Ident . ("slot"++) . show . fst) . zip [1 :: Integer ..] $ types+              fields' = (zip (map return fields) types)+          cons <- makeConstructor name fields+          func <- makeFunc name fields+          emitFayToJs name fields'+          emitJsToFay name fields'+          return [cons, func]+        InfixConDecl t1 name t2 -> do+          let slots = ["slot1","slot2"]+              fields = zip (map return slots) [t1, t2]+          cons <- makeConstructor name slots+          func <- makeFunc name slots+          emitFayToJs name fields+          emitJsToFay name fields+          return [cons, func]+        RecDecl name fields' -> do+          let fields = concatMap fst fields'+          cons <- makeConstructor name fields+          func <- makeFunc name fields+          funs <- makeAccessors srcloc fields+          emitFayToJs name fields'+          emitJsToFay name fields'+          return (cons : func : funs)++  where+    -- Creates a constructor R_RecConstr for a Record+    makeConstructor :: Name -> [Name] -> Compile JsStmt+    makeConstructor name (map (JsNameVar . UnQual) -> fields) = do+      qname <- qualify name+      emitExport (EVar qname)+      return $+        JsVar (JsConstructor qname) $+          JsFun fields (for fields $ \field -> JsSetProp JsThis field (JsName field))+            Nothing++    -- Creates a function to initialize the record by regular application+    makeFunc :: Name -> [Name] -> Compile JsStmt+    makeFunc name (map (JsNameVar . UnQual) -> fields) = do+      let fieldExps = map JsName fields+      qname <- qualify name+      return $ JsVar (JsNameVar qname) $+        foldr (\slot inner -> JsFun [slot] [] (Just inner))+          (thunk $ JsNew (JsConstructor qname) fieldExps)+          fields++    -- Creates getters for a RecDecl's values+    makeAccessors :: SrcLoc -> [Name] -> Compile [JsStmt]+    makeAccessors srcloc fields =+      forM fields $ \name ->+           bindToplevel srcloc+                        toplevel+                        name+                        (JsFun [JsNameVar "x"]+                               []+                               (Just (thunk (JsGetProp (force (JsName (JsNameVar "x")))+                                                       (JsNameVar (UnQual name))))))++-- | Compile a function which pattern matches (causing a case analysis).+compileFunCase :: Bool -> [Match] -> Compile [JsStmt]+compileFunCase _toplevel [] = return []+compileFunCase toplevel matches@(Match srcloc name argslen _ _ _:_) = do+  pats <- fmap optimizePatConditions (mapM compileCase matches)+  bindVar name+  bind <- bindToplevel srcloc+                       toplevel+                       name+                       (foldr (\arg inner -> JsFun [arg] [] (Just inner))+                              (stmtsThunk (concat pats ++ basecase))+                              args)+  return [bind]+  where args = zipWith const uniqueNames argslen++        isWildCardMatch (Match _ _ pats _ _ _) = all isWildCardPat pats++        compileCase :: Match -> Compile [JsStmt]+        compileCase match@(Match _ _ pats _ rhs _) = do+          withScope $ do+            whereDecls' <- whereDecls match+            generateScope $ mapM (\(arg,pat) -> compilePat (JsName arg) pat []) (zip args pats)+            generateScope $ mapM compileLetDecl whereDecls'+            rhsform <- compileRhs rhs+            body <- if null whereDecls'+                      then return $ either id JsEarlyReturn rhsform+                      else do+                          binds <- mapM compileLetDecl whereDecls'+                          return $ case rhsform of+                            Right exp ->+                              (JsEarlyReturn (JsApp (JsFun [] (concat binds) (Just exp)) []))+                            Left stmt ->+                              (JsEarlyReturn (JsApp (JsFun [] (concat binds ++ [stmt]) Nothing) []))+            foldM (\inner (arg,pat) ->+                    compilePat (JsName arg) pat inner)+                  [body]+                  (zip args pats)++        whereDecls :: Match -> Compile [Decl]+        whereDecls (Match _ _ _ _ _ (BDecls decls)) = return decls+        whereDecls match = throwError (UnsupportedWhereInMatch match)++        basecase :: [JsStmt]+        basecase = if any isWildCardMatch matches+                      then []+                      else [throw ("unhandled case in " ++ prettyPrint name)+                                  (JsList (map JsName args))]++-- | Compile a right-hand-side expression.+compileRhs :: Rhs -> Compile (Either JsStmt JsExp)+compileRhs (UnGuardedRhs exp) = Right <$> compileExp exp+compileRhs (GuardedRhss rhss) = Left <$> compileGuards rhss++-- | Compile guards+compileGuards :: [GuardedRhs] -> Compile JsStmt+compileGuards ((GuardedRhs _ (Qualifier (Var (UnQual (Ident "otherwise"))):_) exp):_) =+  (\e -> JsIf (JsLit (JsBool True)) [JsEarlyReturn e] []) <$> compileExp exp+compileGuards (GuardedRhs _ (Qualifier guard:_) exp : rest) =+  makeIf <$> fmap force (compileExp guard)+         <*> compileExp exp+         <*> if null rest then (return []) else do+           gs' <- compileGuards rest+           return [gs']+    where makeIf gs e gss = JsIf gs [JsEarlyReturn e] gss++compileGuards rhss = throwError . UnsupportedRhs . GuardedRhss $ rhss++-- | Compile Haskell expression.+compileExp :: Exp -> Compile JsExp+compileExp exp =+  case exp of+    Paren exp                     -> compileExp exp+    Var qname                     -> compileVar qname+    Lit lit                       -> compileLit lit+    App exp1 exp2                 -> compileApp exp1 exp2+    NegApp exp                    -> compileNegApp exp+    InfixApp exp1 op exp2         -> compileInfixApp exp1 op exp2+    Let (BDecls decls) exp        -> compileLet decls exp+    List []                       -> return JsNull+    List xs                       -> compileList xs+    Tuple xs                      -> compileList xs+    If cond conseq alt            -> compileIf cond conseq alt+    Case exp alts                 -> compileCase exp alts+    Con (UnQual (Ident "True"))   -> return (JsLit (JsBool True))+    Con (UnQual (Ident "False"))  -> return (JsLit (JsBool False))+    Con qname                     -> compileVar qname+    Do stmts                      -> compileDoBlock stmts+    Lambda _ pats exp             -> compileLambda pats exp+    EnumFrom i                    -> do e <- compileExp i+                                        name <- resolveName "enumFrom"+                                        return (JsApp (JsName (JsNameVar name)) [e])+    EnumFromTo i i'               -> do f <- compileExp i+                                        t <- compileExp i'+                                        name <- resolveName "enumFromTo"+                                        return (JsApp (JsApp (JsName (JsNameVar name)) [f])+                                                      [t])+    RecConstr name fieldUpdates -> compileRecConstr name fieldUpdates+    RecUpdate rec  fieldUpdates -> updateRec rec fieldUpdates+    ListComp exp stmts            -> compileExp =<< desugarListComp exp stmts+    ExpTypeSig _ e _ -> compileExp e++    exp -> throwError (UnsupportedExpression exp)++instance CompilesTo Exp JsExp where compileTo = compileExp++compileVar :: QName -> Compile JsExp+compileVar qname = do+  qname <- resolveName qname+  return (JsName (JsNameVar qname))++-- | Compile simple application.+compileApp :: Exp -> Exp -> Compile JsExp+compileApp exp1 exp2 = do+   flattenApps <- config configFlattenApps+   if flattenApps then method2 else method1+   where+  -- Method 1:+  -- In this approach code ends up looking like this:+  -- a(a(a(a(a(a(a(a(a(a(L)(c))(b))(0))(0))(y))(t))(a(a(F)(3*a(a(d)+a(a(f)/20))))*a(a(f)/2)))(140+a(f)))(y))(t)})+  -- Which might be OK for speed, but increases the JS stack a fair bit.+  method1 =+    JsApp <$> (forceFlatName <$> compileExp exp1)+          <*> fmap return (compileExp exp2)+  forceFlatName name = JsApp (JsName JsForce) [name]++  -- Method 2:+  -- In this approach code ends up looking like this:+  -- d(O,a,b,0,0,B,w,e(d(I,3*e(e(c)+e(e(g)/20))))*e(e(g)/2),140+e(g),B,w)}),d(K,g,e(c)+0.05))+  -- Which should be much better for the stack and readability, but probably not great for speed.+  method2 = fmap flatten $+    JsApp <$> compileExp exp1+          <*> fmap return (compileExp exp2)+  flatten (JsApp op args) =+   case op of+     JsApp l r -> JsApp l (r ++ args)+     _        -> JsApp (JsName JsApply) (op : args)+  flatten x = x++-- | Compile a negate application+compileNegApp :: Exp -> Compile JsExp+compileNegApp e = JsNegApp . force <$> compileExp e++-- | Compile an infix application, optimizing the JS cases.+compileInfixApp :: Exp -> QOp -> Exp -> Compile JsExp+compileInfixApp exp1 ap exp2 = do+  qname <- resolveName op+  case qname of+    -- We can optimize prim ops. :-)+    Qual "Fay$" _+      | prettyPrint ap `elem` words "* + - / < > || &&" -> do+        e1 <- compileExp exp1+        e2 <- compileExp exp2+        fn <- compileExp (Var op)+        return $ JsApp (JsApp (force fn) [force e1]) [force e2]+    _ -> compileExp (App (App (Var qname) exp1) exp2)++  where op = getOp ap+        getOp (QVarOp op) = op+        getOp (QConOp op) = op++-- | Compile a list expression.+compileList :: [Exp] -> Compile JsExp+compileList xs = do+  exps <- mapM compileExp xs+  return (makeList exps)++makeList :: [JsExp] -> JsExp+makeList exps = (JsApp (JsName (JsBuiltIn "list")) [JsList exps])++-- | Compile an if.+compileIf :: Exp -> Exp -> Exp -> Compile JsExp+compileIf cond conseq alt =+  JsTernaryIf <$> fmap force (compileExp cond)+              <*> compileExp conseq+              <*> compileExp alt++-- | Compile a lambda.+compileLambda :: [Pat] -> Exp -> Compile JsExp+compileLambda pats exp = do+  withScope $ do+    generateScope $ generateStatements JsNull+    exp <- compileExp exp+    stmts <- generateStatements exp+    case stmts of+      [JsEarlyReturn fun@JsFun{}] -> return fun+      _ -> error "Unexpected statements in compileLambda"++  where unhandledcase = throw "unhandled case" . JsName+        allfree = all isWildCardPat pats+        generateStatements exp =+          foldM (\inner (param,pat) -> do+                  stmts <- compilePat (JsName param) pat inner+                  return [JsEarlyReturn (JsFun [param] (stmts ++ [unhandledcase param | not allfree]) Nothing)])+                [JsEarlyReturn exp]+                (reverse (zip uniqueNames pats))++-- | Compile list comprehensions.+desugarListComp :: Exp -> [QualStmt] -> Compile Exp+desugarListComp e [] =+    return (List [ e ])+desugarListComp e (QualStmt (Generator loc p e2) : stmts) = do+    nested <- desugarListComp e stmts+    withScopedTmpName $ \f ->+      return (Let (BDecls [ FunBind [+          Match loc f [ p         ] Nothing (UnGuardedRhs nested)    (BDecls []),+          Match loc f [ PWildCard ] Nothing (UnGuardedRhs (List [])) (BDecls [])+          ]]) (App (App (Var (UnQual (Ident "concatMap"))) (Var (UnQual f))) e2))+desugarListComp e (QualStmt (Qualifier e2)       : stmts) = do+    nested <- desugarListComp e stmts+    return (If e2 nested (List []))+desugarListComp e (QualStmt (LetStmt bs)         : stmts) = do+    nested <- desugarListComp e stmts+    return (Let bs nested)+desugarListComp _ (s                             : _    ) =+    throwError (UnsupportedQualStmt s)++-- | Compile case expressions.+compileCase :: Exp -> [Alt] -> Compile JsExp+compileCase exp alts = do+  exp <- compileExp exp+  withScopedTmpJsName $ \tmpName -> do+    pats <- fmap optimizePatConditions $ mapM (compilePatAlt (JsName tmpName)) alts+    return $+      JsApp (JsFun [tmpName]+                   (concat pats)+                   (if any isWildCardAlt alts+                       then Nothing+                       else Just (throwExp "unhandled case" (JsName tmpName))))+            [exp]++-- | Compile a do block.+compileDoBlock :: [Stmt] -> Compile JsExp+compileDoBlock stmts = do+  doblock <- foldM compileStmt Nothing (reverse stmts)+  maybe (throwError EmptyDoBlock) compileExp doblock++-- | Compile a statement of a do block.+compileStmt :: Maybe Exp -> Stmt -> Compile (Maybe Exp)+compileStmt inner stmt =+  case inner of+    Nothing -> initStmt+    Just inner -> subsequentStmt inner++  where initStmt =+          case stmt of+            Qualifier exp -> return (Just exp)+            LetStmt{}     -> throwError LetUnsupported+            _             -> throwError InvalidDoBlock++        subsequentStmt inner =+          case stmt of+            Generator loc pat exp -> compileGenerator loc pat inner exp+            Qualifier exp -> return (Just (InfixApp exp+                                                    (QVarOp (UnQual (Symbol ">>")))+                                                    inner))+            LetStmt (BDecls binds) -> return (Just (Let (BDecls binds) inner))+            LetStmt _ -> throwError LetUnsupported+            RecStmt{} -> throwError RecursiveDoUnsupported++        compileGenerator srcloc pat inner exp = do+          let body = Lambda srcloc [pat] inner+          return (Just (InfixApp exp+                                 (QVarOp (UnQual (Symbol ">>=")))+                                 body))++-- | Compile the given pattern against the given expression.+compilePatAlt :: JsExp -> Alt -> Compile [JsStmt]+compilePatAlt exp (Alt _ pat rhs _) = do+  withScope $ do+    generateScope $ compilePat exp pat []+    alt <- compileGuardedAlt rhs+    compilePat exp pat [JsEarlyReturn alt]++-- | Compile the given pattern against the given expression.+compilePat :: JsExp -> Pat -> [JsStmt] -> Compile [JsStmt]+compilePat exp pat body =+  case pat of+    PVar name       -> compilePVar name exp body+    PApp cons pats  -> compilePApp cons pats exp body+    PLit literal    -> compilePLit exp literal body+    PParen pat      -> compilePat exp pat body+    PWildCard       -> return body+    pat@PInfixApp{} -> compileInfixPat exp pat body+    PList pats      -> compilePList pats body exp+    PTuple pats     -> compilePList pats body exp+    PAsPat name pat -> compilePAsPat exp name pat body+    PRec name pats  -> compilePatFields exp name pats body+    pat             -> throwError (UnsupportedPattern pat)++-- | Compile a pattern variable e.g. x.+compilePVar :: Name -> JsExp -> [JsStmt] -> Compile [JsStmt]+compilePVar name exp body = do+  bindVar name+  return $ JsVar (JsNameVar (UnQual name)) exp : body++-- | Compile a record field pattern.+compilePatFields :: JsExp -> QName -> [PatField] -> [JsStmt] -> Compile [JsStmt]+compilePatFields exp name pats body = do+    c <- liftM (++ body) (compilePats' [] pats)+    qname <- resolveName name+    return [JsIf (force exp `JsInstanceOf` JsConstructor qname) c []]+  where -- compilePats' collects field names that had already been matched so that+        -- wildcard generates code for the rest of the fields.+        compilePats' :: [QName] -> [PatField] -> Compile [JsStmt]+        compilePats' names (PFieldPun name:xs) =+          compilePats' names (PFieldPat (UnQual name) (PVar name):xs)++        compilePats' names (PFieldPat fieldname (PVar varName):xs) = do+          r <- compilePats' (fieldname : names) xs+          bindVar varName+          return $ JsVar (JsNameVar (UnQual varName))+                         (JsGetProp (force exp) (JsNameVar fieldname))+                   : r -- TODO: think about this force call++        compilePats' names (PFieldWildcard:xs) = do+          records <- liftM stateRecords get+          let fields = fromJust (lookup name records)+              fields' = fields \\ names+          f <- mapM (\fieldName -> do bindVar (unQual fieldName)+                                      return (JsVar (JsNameVar fieldName)+                                             (JsGetProp (force exp) (JsNameVar fieldName))))+                   fields'+          r <- compilePats' names xs+          return $ f ++ r++        compilePats' _ [] = return []++        compilePats' _ (pat:_) = throwError (UnsupportedFieldPattern pat)++        unQual (Qual _ n) = n+        unQual (UnQual n) = n+        unQual Special{} = error "Trying to unqualify a Special..."++-- | Compile a literal value from a pattern match.+compilePLit :: JsExp -> Literal -> [JsStmt] -> Compile [JsStmt]+compilePLit exp literal body = do+  lit <- compileLit literal+  return [JsIf (equalExps exp lit)+               body+               []]++  where -- Equality test for two expressions, with some optimizations.+        equalExps :: JsExp -> JsExp -> JsExp+        equalExps a b+          | isConstant a && isConstant b = JsEq a b+          | isConstant a = JsEq a (force b)+          | isConstant b = JsEq (force a) b+          | otherwise =+             JsApp (JsName (JsBuiltIn "equal")) [a,b]++-- | Compile as binding in pattern match+compilePAsPat :: JsExp -> Name -> Pat -> [JsStmt] -> Compile [JsStmt]+compilePAsPat exp name pat body = do+  bindVar name+  x <- compilePat exp pat body+  return ([JsVar (JsNameVar (UnQual name)) exp] ++ x ++ body)++-- | Compile a record construction with named fields+-- | GHC will warn on uninitialized fields, they will be undefined in JS.+compileRecConstr :: QName -> [FieldUpdate] -> Compile JsExp+compileRecConstr name fieldUpdates = do+    -- var obj = new $_Type()+    qname <- resolveName name+    let record = JsVar (JsNameVar name) (JsNew (JsConstructor qname) [])+    setFields <- liftM concat (forM fieldUpdates (updateStmt name))+    return $ JsApp (JsFun [] (record:setFields) (Just (JsName (JsNameVar name)))) []+  where updateStmt :: QName -> FieldUpdate -> Compile [JsStmt]+        updateStmt o (FieldUpdate field value) = do+          exp <- compileExp value+          return [JsSetProp (JsNameVar o) (JsNameVar field) exp]+        updateStmt name FieldWildcard = do+          records <- liftM stateRecords get+          let fields = fromJust (lookup name records)+          return (map (\fieldName -> JsSetProp (JsNameVar name)+                                               (JsNameVar fieldName)+                                               (JsName (JsNameVar fieldName)))+                      fields)+        -- TODO: FieldPun+        -- I couldn't find a code that generates (FieldUpdate (FieldPun ..))+        updateStmt _ u = error ("updateStmt: " ++ show u)++updateRec :: Exp -> [FieldUpdate] -> Compile JsExp+updateRec rec fieldUpdates = do+    record <- force <$> compileExp rec+    let copyName = UnQual (Ident "$_record_to_update")+        copy = JsVar (JsNameVar copyName)+                     (JsRawExp ("Object.create(" ++ printJSString record ++ ")"))+    setFields <- forM fieldUpdates (updateExp copyName)+    return $ JsApp (JsFun [] (copy:setFields) (Just (JsName (JsNameVar copyName)))) []+  where updateExp :: QName -> FieldUpdate -> Compile JsStmt+        updateExp copyName (FieldUpdate field value) =+          JsSetProp (JsNameVar copyName) (JsNameVar field) <$> compileExp value+        updateExp copyName (FieldPun name) =+          -- let a = 1 in C {a}+          return $ JsSetProp (JsNameVar copyName)+                             (JsNameVar (UnQual name))+                             (JsName (JsNameVar (UnQual name)))+        -- TODO: FieldWildcard+        -- I also couldn't find a code that generates (FieldUpdate FieldWildCard)+        updateExp _ FieldWildcard = error "unsupported update: FieldWildcard"++-- | Compile a pattern application.+compilePApp :: QName -> [Pat] -> JsExp -> [JsStmt] -> Compile [JsStmt]+compilePApp cons pats exp body = do+  let forcedExp = force exp+  let boolIf b = return [JsIf (JsEq forcedExp (JsLit (JsBool b))) body []]+  case cons of+    -- Special-casing on the booleans.+    "True" -> boolIf True+    "False" -> boolIf False+    -- Everything else, generic:+    _ -> do+      rf <- fmap (lookup cons) (gets stateRecords)+      let recordFields =+            fromMaybe+              (error $ "Constructor '" ++ prettyPrint cons +++                       "' was not found in stateRecords, did you try running this through GHC first?")+              rf+      substmts <- foldM (\body (field,pat) ->+                             compilePat (JsGetProp forcedExp (JsNameVar field)) pat body)+                  body+                  (reverse (zip recordFields pats))+      qcons <- resolveName cons+      return [JsIf (forcedExp `JsInstanceOf` JsConstructor qcons)+                   substmts+                   []]++-- | Compile a pattern list.+compilePList :: [Pat] -> [JsStmt] -> JsExp -> Compile [JsStmt]+compilePList [] body exp =+  return [JsIf (JsEq (force exp) JsNull) body []]+compilePList pats body exp = do+  let forcedExp = force exp+  stmts <- foldM (\body (i,pat) -> compilePat (JsApp (JsApp (JsName (JsBuiltIn "index"))+                                                   [JsLit (JsInt i)])+                                            [forcedExp])+                                     pat body)+        body+        (reverse (zip [0..] pats))+  let patsLen = JsLit (JsInt (length pats))+  return [JsIf (JsApp (JsName (JsBuiltIn "listLen")) [forcedExp,patsLen])+               stmts+               []]++-- | Compile an infix pattern (e.g. cons and tuples.)+compileInfixPat :: JsExp -> Pat -> [JsStmt] -> Compile [JsStmt]+compileInfixPat exp pat@(PInfixApp left (Special cons) right) body =+  case cons of+    Cons -> do+      withScopedTmpJsName $ \tmpName -> do+        let forcedExp = JsName tmpName+            x = JsGetProp forcedExp (JsNameVar "car")+            xs = JsGetProp forcedExp (JsNameVar "cdr")+        rightMatch <- compilePat xs right body+        leftMatch <- compilePat x left rightMatch+        return [JsVar tmpName (force exp)+               ,JsIf (JsInstanceOf forcedExp (JsBuiltIn "Cons"))+                     leftMatch+                     []]+    _ -> throwError (UnsupportedPattern pat)+compileInfixPat _ pat _ = throwError (UnsupportedPattern pat)++-- | Compile a guarded alt.+compileGuardedAlt :: GuardedAlts -> Compile JsExp+compileGuardedAlt alt =+  case alt of+    UnGuardedAlt exp -> compileExp exp+    alt -> throwError (UnsupportedGuardedAlts alt)++-- | Compile a let expression.+compileLet :: [Decl] -> Exp -> Compile JsExp+compileLet decls exp = do+  withScope $ do+    generateScope $ mapM compileLetDecl decls+    binds <- mapM compileLetDecl decls+    body <- compileExp exp+    return (JsApp (JsFun [] (concat binds) (Just body)) [])++-- | Compile let declaration.+compileLetDecl :: Decl -> Compile [JsStmt]+compileLetDecl decl = do+  v <- case decl of+    decl@PatBind{} -> compileDecls False [decl]+    decl@FunBind{} -> compileDecls False [decl]+    TypeSig{}      -> return []+    _              -> throwError (UnsupportedLetBinding decl)+  return v++-- | Compile Haskell literal.+compileLit :: Literal -> Compile JsExp+compileLit lit =+  case lit of+    Char ch       -> return (JsLit (JsChar ch))+    Int integer   -> return (JsLit (JsInt (fromIntegral integer))) -- FIXME:+    Frac rational -> return (JsLit (JsFloating (fromRational rational)))+    -- TODO: Use real JS strings instead of array, probably it will+    -- lead to the same result.+    String string -> return (JsApp (JsName (JsBuiltIn "list"))+                                   [JsLit (JsStr string)])+    lit           -> throwError (UnsupportedLiteral lit)

@@ -0,0 +1,271 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections     #-}+{-# LANGUAGE ViewPatterns      #-}+{-# OPTIONS -Wall #-}++-- | Compiling the FFI support.++module Language.Fay.Compiler.FFI+  (emitFayToJs+  ,emitJsToFay+  ,compileFFI+  ,jsToFayDispatcher+  ,fayToJsDispatcher)+  where++import           Language.Fay.Compiler.Misc+import           Language.Fay.Print           (printJSString)+import           Language.Fay.Types++import           Control.Monad.Error+import           Control.Monad.State+import           Data.Char+import           Data.List+import           Data.Maybe+import qualified Language.ECMAScript3.Parser  as JS+import           Language.Haskell.Exts        (prettyPrint)+import           Language.Haskell.Exts.Syntax+import           Prelude                      hiding (exp)+import           Safe++-- | Compile an FFI call.+compileFFI :: SrcLoc -- ^ Location of the original FFI decl.+           -> Name  -- ^ Name of the to-be binding.+           -> String -- ^ The format string.+           -> Type   -- ^ Type signature.+           -> Compile [JsStmt]+compileFFI srcloc name formatstr sig = do+  inner <- formatFFI formatstr (zip params funcFundamentalTypes)+  case JS.parse JS.parseExpression (prettyPrint name) (printJSString (wrapReturn inner)) of+    Left err -> throwError (FfiFormatInvalidJavaScript inner (show err))+    Right{}  -> fmap return (bindToplevel srcloc True name (body inner))++  where body inner = foldr wrapParam (wrapReturn inner) params+        wrapParam pname inner = JsFun [pname] [] (Just inner)+        params = zipWith const uniqueNames [1..typeArity sig]+        wrapReturn inner = thunk $+          case lastMay funcFundamentalTypes of+            -- Returns a “pure” value;+            Just{} -> jsToFay returnType (JsRawExp inner)+            -- Base case:+            Nothing -> JsRawExp inner+        funcFundamentalTypes = functionTypeArgs sig+        returnType = last funcFundamentalTypes++-- Make a Fay→JS encoder.+emitFayToJs :: Name -> [([Name],BangType)] -> Compile ()+emitFayToJs name (explodeFields -> fieldTypes) = do+  qname <- qualify name+  modify $ \s -> s { stateFayToJs = translator qname : stateFayToJs s }++  where+    translator qname =+      JsIf (JsInstanceOf (JsName transcodingObjForced) (JsConstructor qname))+           (obj : fieldStmts fieldTypes ++ [ret])+           []++    obj :: JsStmt+    obj = JsVar obj_ $+      JsObj [("instance",JsLit (JsStr (printJSString name)))]++    fieldStmts :: [(Name,BangType)] -> [JsStmt]+    fieldStmts [] = []+    fieldStmts (fieldType:fts) =+      (JsVar obj_v field) :+        (JsIf (JsNeq JsUndefined (JsName obj_v))+          [JsSetProp obj_ decl (JsName obj_v)]+          []) :+        fieldStmts fts+      where+        obj_v = JsNameVar (UnQual (Ident $ "obj_" ++ d))+        decl = JsNameVar (UnQual (Ident d))+        (d, field) = declField fieldType++    obj_ = JsNameVar (UnQual (Ident "obj_"))++    ret :: JsStmt+    ret = JsEarlyReturn (JsName obj_)++    -- Declare/encode Fay→JS field+    declField :: (Name,BangType) -> (String,JsExp)+    declField (fname,typ) =+      (prettyPrint fname+      ,fayToJs (case argType (bangType typ) of+                 known -> typeRep known)+               (force (JsGetProp (JsName transcodingObjForced)+                                 (JsNameVar (UnQual fname)))))++transcodingObj :: JsName+transcodingObj = JsNameVar "obj"++transcodingObjForced :: JsName+transcodingObjForced = JsNameVar "_obj"++-- | Get arg types of a function type.+functionTypeArgs :: Type -> [FundamentalType]+functionTypeArgs t =+  case t of+    TyForall _ _ i -> functionTypeArgs i+    TyFun a b      -> argType a : functionTypeArgs b+    TyParen st     -> functionTypeArgs st+    r              -> [argType r]++-- | Convert a Haskell type to an internal FFI representation.+argType :: Type -> FundamentalType+argType t =+  case t of+    TyCon "String"        -> StringType+    TyCon "Double"        -> DoubleType+    TyCon "Int"           -> IntType+    TyCon "Bool"          -> BoolType+    TyApp (TyCon "Defined") a -> Defined (argType a)+    TyApp (TyCon "Fay") a -> JsType (argType a)+    TyFun x xs            -> FunctionType (argType x : functionTypeArgs xs)+    TyList x              -> ListType (argType x)+    TyTuple _ xs          -> TupleType (map argType xs)+    TyParen st            -> argType st+    TyApp op arg          -> userDefined (reverse (arg : expandApp op))+    _                     ->+      -- No semantic point to this, merely to avoid GHC's broken+      -- warning.+      case t of+        TyCon (UnQual user)   -> UserDefined user []+        _ -> UnknownType++-- | Extract the type.+bangType :: BangType -> Type+bangType typ =+  case typ of+    BangedTy ty   -> ty+    UnBangedTy ty -> ty+    UnpackedTy ty -> ty++-- | Expand a type application.+expandApp :: Type -> [Type]+expandApp (TyParen t) = expandApp t+expandApp (TyApp op arg) = arg : expandApp op+expandApp x = [x]++-- | Generate a user-defined type.+userDefined :: [Type] -> FundamentalType+userDefined (TyCon (UnQual name):typs) = UserDefined name (map argType typs)+userDefined _ = UnknownType++-- | Translate: JS → Fay.+jsToFay :: FundamentalType -> JsExp -> JsExp+jsToFay typ exp = JsApp (JsName (JsBuiltIn "jsToFay"))+                        [typeRep typ,exp]++-- | Translate: Fay → JS.+fayToJs :: JsExp -> JsExp -> JsExp+fayToJs typ exp = JsApp (JsName (JsBuiltIn "fayToJs"))+                        [typ,exp]++-- | Get a JS-representation of a fundamental type for encoding/decoding.+typeRep :: FundamentalType -> JsExp+typeRep typ =+  case typ of+    FunctionType xs     -> JsList [JsLit $ JsStr "function",JsList (map typeRep xs)]+    JsType x            -> JsList [JsLit $ JsStr "action",JsList [typeRep x]]+    ListType x          -> JsList [JsLit $ JsStr "list",JsList [typeRep x]]+    TupleType xs        -> JsList [JsLit $ JsStr "tuple",JsList (map typeRep xs)]+    UserDefined name xs -> JsList [JsLit $ JsStr "user"+                                  ,JsLit $ JsStr (unname name)+                                  ,JsList (map typeRep xs)]+    Defined x           -> JsList [JsLit $ JsStr "defined",JsList [typeRep x]]+    _ -> JsList [JsLit $ JsStr nom]++      where nom = case typ of+              StringType -> "string"+              DoubleType -> "double"+              IntType    -> "int"+              BoolType   -> "bool"+              DateType   -> "date"+              _          -> "unknown"++-- | Get the arity of a type.+typeArity :: Type -> Int+typeArity t =+  case t of+    TyForall _ _ i -> typeArity i+    TyFun _ b      -> 1 + typeArity b+    TyParen st     -> typeArity st+    _              -> 0++-- | Format the FFI format string with the given arguments.+formatFFI :: String                      -- ^ The format string.+          -> [(JsName,FundamentalType)] -- ^ Arguments.+          -> Compile String              -- ^ The JS code.+formatFFI formatstr args = go formatstr where+  go ('%':'*':xs) = do+    these <- mapM inject (zipWith const [1..] args)+    rest <- go xs+    return (intercalate "," these ++ rest)+  go ('%':'%':xs) = do+    rest <- go xs+    return ('%' : rest)+  go ['%'] = throwError FfiFormatIncompleteArg+  go ('%':(span isDigit -> (op,xs))) =+    case readMay op of+     Nothing -> throwError (FfiFormatBadChars op)+     Just n -> do+       this <- inject n+       rest <- go xs+       return (this ++ rest)+  go (x:xs) = do rest <- go xs+                 return (x : rest)+  go [] = return []++  inject n =+    case listToMaybe (drop (n-1) args) of+      Nothing -> throwError (FfiFormatNoSuchArg n)+      Just (arg,typ) -> do+        return (printJSString (fayToJs (typeRep typ) (JsName arg)))++explodeFields :: [([a], t)] -> [(a, t)]+explodeFields = concatMap $ \(names,typ) -> map (,typ) names++fayToJsDispatcher :: [JsStmt] -> JsStmt+fayToJsDispatcher cases =+  JsVar (JsBuiltIn "fayToJsUserDefined")+        (JsFun [JsNameVar "type",transcodingObj]+               (decl ++ cases ++ [baseCase])+               Nothing)++  where decl = [JsVar transcodingObjForced+                      (force (JsName transcodingObj))+               ,JsVar (JsNameVar "argTypes")+                      (JsLookup (JsName (JsNameVar "type"))+                                (JsLit (JsInt 2)))]+        baseCase =+          JsEarlyReturn (JsName transcodingObj)++jsToFayDispatcher :: [JsStmt] -> JsStmt+jsToFayDispatcher cases =+  JsVar (JsBuiltIn "jsToFayUserDefined")+        (JsFun [JsNameVar "type",transcodingObj]+               (cases ++ [baseCase])+               Nothing)++  where baseCase =+          JsEarlyReturn (JsName transcodingObj)++-- Make a JS→Fay decoder+emitJsToFay ::  Name -> [([Name], BangType)] -> Compile ()+emitJsToFay name (explodeFields -> fieldTypes) = do+  qname <- qualify name+  modify $ \s -> s { stateJsToFay = translator qname : stateJsToFay s }++  where+    translator qname =+      JsIf (JsEq (JsGetPropExtern (JsName transcodingObj) "instance")+                 (JsLit (JsStr (printJSString name))))+           [JsEarlyReturn (JsNew (JsConstructor qname)+                                 (map decodeField fieldTypes))]+           []+    -- Decode JS→Fay field+    decodeField :: (Name,BangType) -> JsExp+    decodeField (fname,typ) =+      jsToFay (argType (bangType typ))+              (JsGetPropExtern (JsName transcodingObj)+                               (prettyPrint fname))

@@ -0,0 +1,234 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS -Wall -fno-warn-orphans  #-}++-- | Miscellaneous functions used throughout the compiler.++module Language.Fay.Compiler.Misc where++import           Language.Fay.Types++import           Control.Applicative+import           Control.Monad.Error+import           Control.Monad.State+import           Data.List+import qualified Data.Map                     as M+import           Data.Maybe+import           Data.String+import           Language.Haskell.Exts        (ParseResult(..))+import           Language.Haskell.Exts.Syntax+import           Prelude                      hiding (exp)++-- | Extra the string from an ident.+unname :: Name -> String+unname (Ident str) = str+unname _ = error "Expected ident from uname." -- FIXME:++-- | Make an identifier from the built-in HJ module.+fayBuiltin :: String -> QName+fayBuiltin = Qual (ModuleName "Fay$") . Ident++-- | Wrap an expression in a thunk.+thunk :: JsExp -> JsExp+-- thunk exp = JsNew (fayBuiltin "Thunk") [JsFun [] [] (Just exp)]+thunk expr =+  case expr of+    -- JS constants don't need to be in thunks, they're already strict.+    JsLit{} -> expr+    -- Functions (e.g. lets) used for introducing a new lexical scope+    -- aren't necessary inside a thunk. This is a simple aesthetic+    -- optimization.+    JsApp fun@JsFun{} [] -> JsNew JsThunk [fun]+    -- Otherwise make a regular thunk.+    _ -> JsNew JsThunk [JsFun [] [] (Just expr)]++-- | Wrap an expression in a thunk.+stmtsThunk :: [JsStmt] -> JsExp+stmtsThunk stmts = JsNew JsThunk [JsFun [] stmts Nothing]++-- | Generate unique names.+uniqueNames :: [JsName]+uniqueNames = map JsParam [1::Integer ..]++-- | Resolve a given maybe-qualified name to a fully qualifed name.+resolveName :: QName -> Compile QName+resolveName special@Special{} = return special+resolveName (UnQual name) = do+--  let echo = io . putStrLn+--  echo $ "Resolving name " ++ prettyPrint name+  names <- gets stateScope+--  echo $ "Names are: " ++ show names+  case M.lookup name names of+    -- Unqualified and not imported? Current module.+    Nothing -> qualify name+    Just scopes -> case find localBinding scopes of+      Just ScopeBinding -> return (UnQual name)+      _ ->+        case find simpleImport scopes of+          Just (ScopeImported modulename replacement) -> return (Qual modulename (fromMaybe name replacement))+          _ -> case find asImport scopes of+            Just (ScopeImportedAs _ modulename _) -> return (Qual modulename name)+            _ -> throwError $ UnableResolveUnqualified name++  where asImport ScopeImportedAs{} = True+        asImport _ = False++        localBinding ScopeBinding = True+        localBinding _ = False++resolveName (Qual modulename name) = do+  names <- gets stateScope+  case M.lookup name names of+    -- Qualified and not imported? It's correct, leave it as-is.+    Nothing -> return (Qual modulename name)+    Just scopes -> case find simpleImport scopes of+      Just (ScopeImported _ replacement) -> return (Qual modulename (fromMaybe name replacement))+      _ -> case find asMatch scopes of+        Just (ScopeImported realname replacement) -> return (Qual realname (fromMaybe name replacement))+        _ -> throwError $ UnableResolveQualified (Qual modulename name)++  where asMatch i = case i of+          ScopeImported{} -> True+          ScopeImportedAs _ _ qmodulename -> qmodulename == moduleToName modulename+          ScopeBinding -> False+          where moduleToName (ModuleName n) = Ident n++-- | Do have have a simple "import X" import on our hands?+simpleImport :: NameScope -> Bool+simpleImport ScopeImported{} = True+simpleImport _ = False++-- | Qualify a name for the current module.+qualify :: Name -> Compile QName+qualify name = do+  modulename <- gets stateModuleName+  return (Qual modulename name)++-- | Make a top-level binding.+bindToplevel :: SrcLoc -> Bool -> Name -> JsExp -> Compile JsStmt+bindToplevel srcloc toplevel name expr = do+  qname <- (if toplevel then qualify else return . UnQual) name+  exportAll <- gets stateExportAll+  -- If exportAll is set this declaration has not been added to stateExports yet.+  when (toplevel && exportAll) $ emitExport (EVar qname)+  return (JsMappedVar srcloc (JsNameVar qname) expr)++-- | Create a temporary scope and discard it after the given computation.+withScope :: Compile a -> Compile a+withScope m = do+  scope <- gets stateScope+  value <- m+  modify $ \s -> s { stateScope = scope }+  return value++-- | Run a compiler and just get the scope information.+generateScope :: Compile a -> Compile ()+generateScope m = do+  st <- get+  _ <- m+  scope <- gets stateScope+  put st { stateScope = scope }++-- | Bind a variable in the current scope.+bindVar :: Name -> Compile ()+bindVar name = do+  modify $ \s -> s { stateScope = M.insertWith (++) name [ScopeBinding] (stateScope s) }++-- | Emit exported names.+emitExport :: ExportSpec -> Compile ()+emitExport spec =+  case spec of+    EVar (UnQual name) -> emitVar (UnQual name)+    EVar name@Qual{} -> modify $ \s -> s { stateExports = name : stateExports s }+    EThingAll (UnQual name) -> do+      emitVar (UnQual name)+      r <- lookup (UnQual name) <$> gets stateRecords+      maybe (return ()) (mapM_ emitVar) r+    EThingWith (UnQual name) ns -> do+      emitVar (UnQual name)+      mapM_ emitCName ns+    EAbs _ -> return () -- Type only, skip+    _ -> do+      name <- gets stateModuleName+      unless (name == "Language.Fay.Stdlib") $+        throwError (UnsupportedExportSpec spec)+ where+   emitVar n = resolveName n >>= emitExport . EVar+   emitCName (VarName n) = emitVar (UnQual n)+   emitCName (ConName n) = emitVar (UnQual n)++-- | Force an expression in a thunk.+force :: JsExp -> JsExp+force expr+  | isConstant expr = expr+  | otherwise = JsApp (JsName JsForce) [expr]++-- | Is a JS expression a literal (constant)?+isConstant :: JsExp -> Bool+isConstant JsLit{} = True+isConstant _       = False++-- | Extract the string from a qname.+-- qname :: QName -> String+-- qname (UnQual (Ident str)) = str+-- qname (UnQual (Symbol sym)) = jsEncodeName sym+-- qname i = error $ "qname: Expected unqualified ident, found: " ++ show i -- FIXME:++-- | Deconstruct a parse result (a la maybe, foldr, either).+parseResult :: ((SrcLoc,String) -> b) -> (a -> b) -> ParseResult a -> b+parseResult die ok result =+  case result of+    ParseOk a -> ok a+    ParseFailed srcloc msg -> die (srcloc,msg)++-- | Get a config option.+config :: (CompileConfig -> a) -> Compile a+config f = gets (f . stateConfig)++-- | Optimize pattern matching conditions by merging conditions in common.+optimizePatConditions :: [[JsStmt]] -> [[JsStmt]]+optimizePatConditions = concatMap merge . groupBy sameIf where+  sameIf [JsIf cond1 _ _] [JsIf cond2 _ _] = cond1 == cond2+  sameIf _ _ = False+  merge xs@([JsIf cond _ _]:_) =+    [[JsIf cond (concat (optimizePatConditions (map getIfConsequent xs))) []]]+  merge noifs = noifs+  getIfConsequent [JsIf _ cons _] = cons+  getIfConsequent other = other++-- | Throw a JS exception.+throw :: String -> JsExp -> JsStmt+throw msg expr = JsThrow (JsList [JsLit (JsStr msg),expr])++-- | Throw a JS exception (in an expression).+throwExp :: String -> JsExp -> JsExp+throwExp msg expr = JsThrowExp (JsList [JsLit (JsStr msg),expr])++-- | Is an alt a wildcard?+isWildCardAlt :: Alt -> Bool+isWildCardAlt (Alt _ pat _ _) = isWildCardPat pat++-- | Is a pattern a wildcard?+isWildCardPat :: Pat -> Bool+isWildCardPat PWildCard{} = True+isWildCardPat PVar{}      = True+isWildCardPat _           = False++-- | Generate a temporary, SCOPED name for testing conditions and+-- such.+withScopedTmpJsName :: (JsName -> Compile a) -> Compile a+withScopedTmpJsName withName = do+  depth <- gets stateNameDepth+  modify $ \s -> s { stateNameDepth = depth + 1 }+  ret <- withName $ JsTmp depth+  modify $ \s -> s { stateNameDepth = depth }+  return ret++-- | Generate a temporary, SCOPED name for testing conditions and+-- such. We don't have name tracking yet, so instead we use this.+withScopedTmpName :: (Name -> Compile a) -> Compile a+withScopedTmpName withName = do+  depth <- gets stateNameDepth+  modify $ \s -> s { stateNameDepth = depth + 1 }+  ret <- withName $ Ident $ "$gen" ++ show depth+  modify $ \s -> s { stateNameDepth = depth }+  return ret

@@ -0,0 +1,213 @@+{-# OPTIONS -fno-warn-orphans #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE PatternGuards #-}++module Language.Fay.Compiler.Optimizer where++import Control.Applicative+import Control.Arrow (first)+import Control.Monad.Error+import Control.Monad.Writer+import Control.Monad.State+import Data.List+import Data.Maybe+import Language.Fay.Print+import Language.Fay.Types+import Language.Haskell.Exts (QName(..),ModuleName(..),Name(..))+import Language.Haskell.Exts (SrcLoc(..))+import Prelude hiding (exp)++-- | The arity of a function. Arity here is defined to be the number+-- of arguments that can be directly uncurried from a curried lambda+-- abstraction. So \x y z -> if x then (\a -> a) else (\a -> a) has an+-- arity of 3, not 4.+type FuncArity = (QName,Int)++-- | Optimize monad.+type Optimize = State OptState++-- | State.+data OptState = OptState+  { optStmts   :: [JsStmt]+  , optUncurry :: [QName]+  }++-- | Run an optimizer, which may output additional statements.+runOptimizer :: ([JsStmt] -> Optimize [JsStmt]) -> [JsStmt] -> [JsStmt]+runOptimizer optimizer stmts =+  let (newstmts,OptState _ uncurried) = flip runState st $ optimizer stmts+  in (newstmts ++ (tco (catMaybes (map (uncurryBinding newstmts) uncurried))))+  where st = OptState stmts []++-- | Perform any top-level cross-module optimizations and GO DEEP to+-- optimize further.+optimizeToplevel :: [JsStmt] -> Optimize [JsStmt]+optimizeToplevel = stripAndUncurry++-- | Perform tail-call optimization.+tco :: [JsStmt] -> [JsStmt]+tco = map inStmt where+  inStmt stmt =+    case stmt of+      JsMappedVar srcloc name exp -> JsMappedVar srcloc name (inject name exp)+      JsVar name exp -> JsVar name (inject name exp)+      e -> e+  inject name exp =+    case exp of+      JsFun params [] (Just (JsNew JsThunk [JsFun [] stmts ret])) ->+        JsFun params+              []+              (Just+                (JsNew JsThunk+                       [JsFun []+                              (optimize params name (stmts ++ [ JsEarlyReturn e | Just e <- [ret] ]))+                              Nothing]))+      _ -> exp+  optimize params name stmts = result where+    result = let (newstmts,w) = runWriter makeWhile+             in if null w+                   then stmts+                   else newstmts+    makeWhile = do+      newstmts <- fmap concat (mapM swap stmts)+      return [JsWhile (JsLit (JsBool True)) newstmts]+    swap stmt =+      case stmt of+        JsEarlyReturn e+          | tailCall e -> do tell [()]+                             return (rebind e ++ [JsContinue])+          | otherwise  -> return [stmt]+        JsIf p ithen ielse -> do+          newithen <- fmap concat (mapM swap ithen)+          newielse <- fmap concat (mapM swap ielse)+          return [JsIf p newithen newielse]+        e -> return [e]+    tailCall (JsApp (JsName cname) _) = cname == name+    tailCall _ = False+    rebind (JsApp _ args) = zipWith go args params where+      go arg param = JsUpdate param arg+    rebind e = error . show $ e++-- | Strip redundant forcing from the whole generated code.+stripAndUncurry :: [JsStmt] -> Optimize [JsStmt]+stripAndUncurry = applyToExpsInStmts stripFuncForces where+  stripFuncForces arities exp =+    case exp of+      JsApp (JsName JsForce) [JsName (JsNameVar f)]+        | Just _ <- lookup f arities -> return (JsName (JsNameVar f))+      JsFun ps stmts body            -> do substmts <- mapM stripInStmt stmts+                                           sbody <- maybe (return Nothing) (fmap Just . go) body+                                           return (JsFun ps substmts sbody)+      JsApp a b                      -> do+        result <- walkAndStripForces arities exp+        case result of+          Just strippedExp             -> go strippedExp+          Nothing                      -> JsApp <$> go a <*> mapM go b+      JsNegApp e                     -> JsNegApp <$> go e+      JsTernaryIf a b c              -> JsTernaryIf <$> go a <*> go b <*> go c+      JsParen e                      -> JsParen <$> go e+      JsUpdateProp e n a             -> JsUpdateProp <$> go e <*> pure n <*> go a+      JsList xs                      -> JsList <$> mapM go xs+      JsEq a b                       -> JsEq <$> go a <*> go b+      JsInfix op a b                 -> JsInfix op <$> go a <*> go b+      JsObj xs                       -> JsObj <$> mapM (\(x,y) -> (x,) <$> go y) xs+      JsNew name xs                  -> JsNew name <$> mapM go xs+      e                              -> return e++      where go = stripFuncForces arities+            stripInStmt = applyToExpsInStmt arities stripFuncForces++-- | Strip redundant forcing from an application if possible.+walkAndStripForces :: [FuncArity] -> JsExp -> Optimize (Maybe JsExp)+walkAndStripForces arities = go True [] where+  go frst args app = case app of+    JsApp (JsName JsForce) [e] -> if frst+                                     then do result <- go False args e+                                             case result of+                                               Nothing -> return Nothing+                                               Just ex -> return (Just (JsApp (JsName JsForce) [ex]))+                                     else go False args e+    JsApp op [arg] -> go False (arg:args) op+    JsName (JsNameVar f)+      | Just arity <- lookup f arities, length args == arity -> do+        modify $ \s -> s { optUncurry = f : optUncurry s }+        return (Just (JsApp (JsName (JsNameVar (renameUncurried f))) args))+    _ -> return Nothing++-- | Apply the given function to the top-level expressions in the+-- given statements.+applyToExpsInStmts :: ([FuncArity] -> JsExp -> Optimize JsExp) -> [JsStmt] -> Optimize [JsStmt]+applyToExpsInStmts f stmts = mapM (applyToExpsInStmt (collectFuncs stmts) f) stmts++-- | Apply the given function to the top-level expressions in the+-- given statement.+applyToExpsInStmt :: [FuncArity] -> ([FuncArity] -> JsExp -> Optimize JsExp) -> JsStmt -> Optimize JsStmt+applyToExpsInStmt funcs f stmts = uncurryInStmt stmts where+  transform = f funcs+  uncurryInStmt stmt =+    case stmt of+      JsMappedVar srcloc name exp -> JsMappedVar srcloc name <$> transform exp+      JsVar name exp              -> JsVar name <$> transform exp+      JsEarlyReturn exp           -> JsEarlyReturn <$> transform exp+      JsIf op ithen ielse         -> JsIf <$> transform op+                                          <*> mapM uncurryInStmt ithen+                                          <*> mapM uncurryInStmt ielse+      s -> pure s++-- | Collect functions and their arity from the whole codeset.+collectFuncs :: [JsStmt] -> [FuncArity]+collectFuncs = (++ prim) . concat . map collectFunc where+  collectFunc (JsMappedVar _ name exp) = collectFunc (JsVar name exp)+  collectFunc (JsVar (JsNameVar name) exp) | arity > 0 = [(name,arity)]+    where arity = expArity exp+  collectFunc _ = []+  prim = map (first (Qual (ModuleName "Fay$"))) (unary ++ binary)+  unary = map (,1) [Ident "return"]+  binary = map ((,2) . Ident)+               ["then","bind","mult","mult","add","sub","div"+               ,"eq","neq","gt","lt","gte","lte","and","or"]++-- | Get the arity of an expression.+expArity :: JsExp -> Int+expArity (JsFun _ _ mexp) = 1 + maybe 0 expArity mexp+expArity _ = 0++test :: IO ()+test = do+  let (newstmts,OptState _ uncurried) = flip runState st $ optimizeToplevel stmts+  putStrLn $ printJSPretty newstmts+  putStrLn $ printJSPretty (catMaybes (map (uncurryBinding newstmts) uncurried))++    where+      st = OptState stmts []+      stmts = [JsMappedVar (SrcLoc {srcFilename = "", srcLine = 1, srcColumn = 1}) (JsNameVar (Qual (ModuleName "Main") (Ident "sum$uncurried"))) (JsFun [JsParam 1,JsParam 2] [] (Just (JsNew JsThunk [JsFun [] [JsVar (JsNameVar (UnQual (Ident "acc"))) (JsName (JsParam 2)),JsIf (JsEq (JsApp (JsName JsForce) [JsName (JsParam 1)]) (JsLit (JsInt 0))) [JsEarlyReturn (JsName (JsNameVar (UnQual (Ident "acc"))))] [],JsVar (JsNameVar (UnQual (Ident "acc"))) (JsName (JsParam 2)),JsVar (JsNameVar (UnQual (Ident "n"))) (JsName (JsParam 1)),JsEarlyReturn (JsApp (JsName (JsNameVar (Qual (ModuleName "Main") (Ident "sum$uncurried")))) [JsApp (JsName (JsNameVar (Qual (ModuleName "Fay$") (Ident "sub$uncurried")))) [JsApp (JsName JsForce) [JsName (JsNameVar (UnQual (Ident "n")))],JsLit (JsInt 1)],JsApp (JsName (JsNameVar (Qual (ModuleName "Fay$") (Ident "add$uncurried")))) [JsApp (JsName JsForce) [JsName (JsNameVar (UnQual (Ident "acc")))],JsApp (JsName JsForce) [JsName (JsNameVar (UnQual (Ident "n")))]]])] Nothing])))]++uncurryBinding :: [JsStmt] -> QName -> Maybe JsStmt+uncurryBinding stmts qname = listToMaybe (mapMaybe funBinding stmts)++  where funBinding stmt =+          case stmt of+            JsMappedVar srcloc (JsNameVar name) body+              | name == qname -> JsMappedVar srcloc (JsNameVar (renameUncurried name)) <$> uncurryIt body+            JsVar (JsNameVar name) body+              | name == qname -> JsVar (JsNameVar (renameUncurried name)) <$> uncurryIt body+            _ -> Nothing++        uncurryIt = Just . go [] where+          go args exp =+              case exp of+                JsFun [arg] [] (Just body) -> go (arg : args) body+                inner -> JsFun (reverse args) [] (Just inner)++-- | Rename an uncurried copy of a curried function.+renameUncurried :: QName -> QName+renameUncurried q =+          case q of+            Qual m n -> Qual m (renameUnQual n)+            UnQual n -> UnQual (renameUnQual n)+            s -> s+  where renameUnQual n =+          case n of+            Ident nom -> Ident (nom ++ postfix)+            Symbol nom -> Symbol (nom ++ postfix)+        postfix = "$uncurried"

@@ -1,6 +1,6 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TupleSections     #-}-{-# LANGUAGE ViewPatterns      #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings  #-}+{-# LANGUAGE TupleSections      #-} {-# OPTIONS -fno-warn-type-defaults #-}  -- | Convert a Haskell value to a (JSON representation of a) Fay value.@@ -11,18 +11,18 @@   where  import           Control.Applicative-import           Control.Arrow import           Control.Monad+import           Control.Monad.State import           Data.Aeson import           Data.Attoparsec.Number- import           Data.Char import           Data.Data import           Data.Function+import           Data.Generics.Aliases+import           Data.HashMap.Strict    (HashMap) import qualified Data.HashMap.Strict    as Map-import           Data.List import           Data.Maybe-import           Data.Ord+import           Data.Text              (Text) import qualified Data.Text              as Text import qualified Data.Vector            as Vector import           Numeric@@ -40,6 +40,11 @@     Show.Con "True" _    -> return (Bool True)     Show.Con "False" _   -> return (Bool False) +    -- Just x => x+    Show.Con "Just"   [v] -> convert v+    -- Nothing -> null+    Show.Con "Nothing" [] -> return Null+     -- Objects/records     Show.Con name values -> fmap (Object . Map.fromList . (("instance",string name) :))                                  (slots values)@@ -63,19 +68,19 @@           int = convertInt value    -- Number converters-  convertDouble = fmap (Number . D) . parseDouble-  convertInt = fmap (Number . I) . parseInt+  convertDouble = fmap (Number . D) . pDouble+  convertInt = fmap (Number . I) . pInt    -- Number parsers-  parseDouble :: Show.Value -> Maybe Double-  parseDouble value = case value of+  pDouble :: Show.Value -> Maybe Double+  pDouble value = case value of     Show.Float str   -> getDouble str-    Show.Ratio x y   -> liftM2 (on (/) fromIntegral) (parseInt x) (parseInt y)-    Show.Neg str     -> fmap (* (-1)) (parseDouble str)+    Show.Ratio x y   -> liftM2 (on (/) fromIntegral) (pInt x) (pInt y)+    Show.Neg str     -> fmap (* (-1)) (pDouble str)     _ -> Nothing-  parseInt value = case value of+  pInt value = case value of     Show.Integer str -> getInt str-    Show.Neg str     -> fmap (* (-1)) (parseInt str)+    Show.Neg str     -> fmap (* (-1)) (pInt str)     _ -> Nothing    -- Number readers@@ -91,57 +96,108 @@   keyval key val = fmap (Text.pack key,) (convert val)  -- | Convert a value representing a Fay value to a Haskell value.-readFromFay :: (Data a,Read a) => Value -> Maybe a-readFromFay value = result where-  result = (convert >=> readMay) value-  convert v =-    case v of-      Object obj -> do-        name <- Map.lookup "instance" obj >>= getText-        fmap parens (readRecord name obj <|> readData name obj)-      Array array -> do-        elems <- mapM convert (Vector.toList array)-        return $ concat ["[",intercalate "," elems,"]"]-      String str -> return (show str)-      Number num -> return $ case num of-        I integer -> show integer-        D double -> show double-      Bool bool -> return $ show bool-      Null -> Nothing -  getText i = case i of-    String s -> return s-    _ -> Nothing+readFromFay :: Data a => Value -> Maybe a+readFromFay value = do+  parseData value+  `ext1R` parseMaybe value+  `ext1R` parseArray value+  `extR` parseDouble value+  `extR` parseInt value+  `extR` parseBool value+  `extR` parseString value -  readData name obj = do-    fields <- forM assocs $ \(_,v) -> do-      cvalue <- convert v-      return cvalue-    return (intercalate " " (Text.unpack name : fields))-      where assocs = sortBy (comparing fst)-                            (filter ((/="instance").fst) (Map.toList obj))+-- | Parse a data type or record.+parseData :: Data a => Value -> Maybe a+parseData value = result where+  result = getObject value >>= parseObject typ+  typ = dataTypeOf (fromJust result)+  getObject x =+    case x of+      Object obj -> return obj+      _ -> mzero -  readRecord name (Map.toList -> assocs) = go (dataTypeConstrs typ)-    where go (cons:conses) =-            readConstructor name assocs cons <|> go conses-          go [] = Nothing+-- | Parse a data constructor from an object.+parseObject :: Data a => DataType -> HashMap Text Value -> Maybe a+parseObject typ obj = listToMaybe (catMaybes choices) where+  choices = map makeConstructor constructors+  constructors = dataTypeConstrs typ+  makeConstructor cons = do+    name <- Map.lookup (Text.pack "instance") obj >>= parseString+    guard (showConstr cons == name)+    if null fields+      then makeSimple obj cons+      else makeRecord obj cons fields -  readConstructor name assocs cons = do-    let getField key =-          case lookup key (map (first Text.unpack) assocs) of-            Just v  -> return (key,v)-            Nothing -> Nothing-    fields <- forM (constrFields cons) $ \field -> do-      (key,v) <- getField field-      cvalue <- convert v-      return (unwords [key,"=",cvalue])-    guard $ not $ null fields-    return (Text.unpack name ++-            if null fields-               then ""-               else " {" ++ intercalate ", " fields ++ "}")+      where fields = constrFields cons -  typ = dataTypeOf $ resType result-  resType :: Maybe a -> a-  resType = undefined-  parens x = "(" ++ x ++ ")"+-- | Make a simple ADT constructor from an object: { "slot1": 1, "slot2": 2} -> Foo 1 2+makeSimple :: Data a => HashMap Text Value -> Constr -> Maybe a+makeSimple obj cons =+  evalStateT (fromConstrM (do i:next <- get+                              put next+                              value <- lift (Map.lookup (Text.pack ("slot" ++ show i)) obj)+                              lift (readFromFay value))+                          cons)+             [1..]++-- | Make a record from a key-value: { "x": 1 } -> Foo { x = 1 }+makeRecord :: Data a => HashMap Text Value -> Constr -> [String] -> Maybe a+makeRecord obj cons fields =+  evalStateT (fromConstrM (do key:next <- get+                              put next+                              value <- lift (Map.lookup (Text.pack key) obj)+                              lift (readFromFay value))+                          cons)+             fields++-- | Parse a double.+parseDouble :: Value -> Maybe Double+parseDouble value = do+  number <- parseNumber value+  case number of+    D n -> return n+    _ -> mzero++-- | Parse an int.+parseInt :: Value -> Maybe Int+parseInt value = do+  number <- parseNumber value+  case number of+    I n -> return (fromIntegral n)+    _ -> mzero++-- | Parse a number.+parseNumber :: Value -> Maybe Number+parseNumber value =+  case value of+    Number n -> return n+    _ -> mzero++-- | Parse a bool.+parseBool :: Value -> Maybe Bool+parseBool value =+  case value of+    Bool n -> return n+    _ -> mzero++-- | Parse a string.+parseString :: Value -> Maybe String+parseString value =+  case value of+    String s -> return (Text.unpack s)+    _ -> mzero++-- | Parse an array.+parseArray :: Data a => Value -> Maybe [a]+parseArray value =+  case value of+    Array xs -> mapM readFromFay (Vector.toList xs)+    _ -> mzero++-- | Parse a nullable value to Maybe.+parseMaybe :: Data a => Value -> Maybe (Maybe a)+parseMaybe value =+  case value of+    Null -> Just Nothing+    v -> fmap Just (readFromFay v)

@@ -5,10 +5,7 @@ module Language.Fay.FFI where  import           Language.Fay.Types (Fay)-import           Prelude            (Bool, Char, Double, String, Int, error)---- | In case you want to distinguish values with a JsPtr.-data JsPtr a+import           Prelude            (Bool, Char, Double, String, Int, Maybe, error)  -- | Contains allowed foreign function types. class Foreign a@@ -31,14 +28,25 @@ -- | Lists → arrays are OK. instance Foreign a => Foreign [a] --- | Pointers to arbitrary objects are OK.-instance Foreign (JsPtr a)+-- | Tuples → arrays are OK.+instance (Foreign a, Foreign b) => Foreign (a,b)+instance (Foreign a, Foreign b, Foreign c) => Foreign (a,b,c)+instance (Foreign a, Foreign b, Foreign c, Foreign d) => Foreign (a,b,c,d)+instance (Foreign a, Foreign b, Foreign c, Foreign d,+          Foreign e) => Foreign (a,b,c,d,e)+instance (Foreign a, Foreign b, Foreign c, Foreign d,+          Foreign e, Foreign f) => Foreign (a,b,c,d,e,f)+instance (Foreign a, Foreign b, Foreign c, Foreign d,+          Foreign e, Foreign f, Foreign g) => Foreign (a,b,c,d,e,f,g)  -- | JS values are foreignable. instance Foreign a => Foreign (Fay a)  -- | Functions are foreignable. instance (Foreign a,Foreign b) => Foreign (a -> b)++-- | Maybes are pretty common.+instance Foreign a => Foreign (Maybe a)  -- | Declare a foreign action. ffi

@@ -8,7 +8,7 @@   ,Double   ,Int   ,Bool(..)-  ,Show(show)+  ,Show   ,Read   ,Maybe(..)   ,Typeable(..)@@ -16,8 +16,6 @@   ,Monad   ,Eq(..)   ,read-  ,fromInteger-  ,fromRational   ,(>>)   ,(>>=)   ,(+)@@ -32,27 +30,17 @@   ,(&&)   ,fail   ,return+  ,force   ,module Language.Fay.Stdlib)   where  import           Language.Fay.Stdlib import           Language.Fay.Types  (Fay)- import           Data.Data--import           GHC.Real            (Ratio) import           Prelude             (Bool(..), Char, Double, Eq(..), Int, Integer, Maybe(..), Monad,- Ord, Read(..), Show(..), String, error, read, (&&), (*), (+), (-),+ Ord, Read(..), Show(), String, error, read, (&&), (*), (+), (-),  (/), (/=), (<), (<=), (==), (>), (>=), (||)) --- | Just to satisfy GHC.-fromInteger :: Integer -> Double-fromInteger = error "Language.Fay.Prelude.fromInteger: Used fromInteger outside JS."---- | Just to satisfy GHC.-fromRational :: Ratio Integer -> Double-fromRational = error "Language.Fay.Prelude.fromRational Used fromRational outside JS."- (>>) :: Fay a -> Fay b -> Fay b (>>) = error "Language.Fay.Prelude.(>>): Used (>>) outside JS." infixl 1 >>@@ -66,3 +54,6 @@  return :: a -> Fay a return = error "Language.Fay.Prelude.return: Used return outside JS."++force :: a -> Bool -> Fay a+force = error "Language.Fay.Prelude.force: Used force outside JS."

@@ -1,7 +1,6 @@ {-# OPTIONS -fno-warn-orphans #-} {-# OPTIONS -fno-warn-unused-do-bind #-} {-# LANGUAGE FlexibleInstances    #-}-{-# LANGUAGE OverloadedStrings    #-} {-# LANGUAGE RecordWildCards      #-} {-# LANGUAGE TypeSynonymInstances #-} @@ -21,11 +20,12 @@ import           Control.Monad import           Control.Monad.State import           Data.Aeson.Encode-import qualified Data.ByteString.Lazy.UTF8 as UTF8+import qualified Data.ByteString.Lazy.UTF8    as UTF8 import           Data.Default import           Data.List import           Data.String import           Language.Haskell.Exts.Syntax+ import           Prelude                      hiding (exp)  --------------------------------------------------------------------------------@@ -34,6 +34,9 @@ printJSString :: Printable a => a -> String printJSString x = concat $ reverse $ psOutput $ execState (runPrinter (printJS x)) def +printJSPretty :: Printable a => a -> String+printJSPretty x = concat $ reverse $ psOutput $ execState (runPrinter (printJS x)) def { psPretty = True }+ -- | Print literals. These need some special encoding for -- JS-format literals. Could use the Text.JSON library. instance Printable JsLit where@@ -50,38 +53,35 @@ instance Printable QName where   printJS qname =     case qname of-      Qual moduleName name -> do printJS moduleName-                                 "$$"-                                 printJS name+      Qual moduleName name -> moduleName +> "$" +> name       UnQual name -> printJS name       Special con -> printJS con +-- | Print module name.+instance Printable ModuleName where+  printJS (ModuleName "Fay$") =+    write "Fay$"+  printJS (ModuleName moduleName) = write $ go moduleName++    where go ('.':xs) = '$' : go xs+          go (x:xs) = normalizeName [x] ++ go xs+          go [] = []+ -- | Print special constructors (tuples, list, etc.) instance Printable SpecialCon where   printJS specialCon =-    printJS $ (Qual "Fay" . Ident) $+    printJS $ (Qual (ModuleName "Fay$") . Ident) $       case specialCon of-        UnitCon          -> "unit"-        ListCon          -> "emptyList"-        FunCon           -> "funCon"-        TupleCon boxed n -> (if boxed == Boxed-                                then "boxed"-                                else "unboxed" ++-                                "TupleOf" ++ show n)-        Cons             -> "cons"-        UnboxedSingleCon -> "unboxedSingleCon"---- | Print module name.-instance Printable ModuleName where-  printJS (ModuleName moduleName) =-    write $ jsEncodeName moduleName+        UnitCon -> "unit"+        Cons    -> "cons"+        _       -> error $ "Special constructor not supported: " ++ show specialCon  -- | Print (and properly encode) a name. instance Printable Name where   printJS name = write $     case name of-      Ident ident -> jsEncodeName ident-      Symbol sym -> jsEncodeName sym+      Ident ident -> encodeName ident+      Symbol sym -> encodeName sym  -- | Print a list of statements. instance Printable [JsStmt] where@@ -89,76 +89,116 @@  -- | Print a single statement. instance Printable JsStmt where-  printJS (JsBlock stmts) = do-    "{ "; mapM printJS stmts; "}"-  printJS (JsVar name expr) = do "var "; printJS name; " = "; printJS expr; ";"-  printJS (JsUpdate name expr) = do printJS name; " = "; printJS expr; ";"-  printJS (JsSetProp name prop expr) = do-    printJS name; "."; printJS prop; " = "; printJS expr; ";"-  printJS (JsIf exp thens elses) = do-    "if ("; printJS exp; ") {"-    printJS thens-    "}"-    when (length elses > 0) $ do-      " else {"-      printJS elses-      "}"-  printJS (JsEarlyReturn exp) = do-    "return "; printJS exp; ";"+  printJS (JsBlock stmts) =+    "{ " +> stmts +> "}"+  printJS (JsVar name expr) =+    "var " +> name +> " = " +> expr +> ";" +> newline+  printJS (JsUpdate name expr) =+    name +> " = " +> expr +> ";" +> newline+  printJS (JsSetProp name prop expr) =+    name +> "." +> prop +> " = " +> expr +> ";" +> newline+  printJS (JsIf exp thens elses) =+    "if (" +> exp +> ") {" +> newline +>+    indented (printJS thens) +>+    "}" +>+    (when (length elses > 0) $ " else {" +>+    indented (printJS elses) +>+    "}") +> newline+  printJS (JsEarlyReturn exp) =+    "return " +> exp +> ";" +> newline   printJS (JsThrow exp) = do-    "throw "; printJS exp; ";"-  printJS (JsWhile cond stmts) = do-    "while ("; printJS cond; ") {"-    printJS stmts-    "}"-  printJS JsContinue = "continue;"-  printJS (JsMappedVar _ name expr) = do "var "; printJS name; " = "; printJS expr; ";"+    "throw " +> exp +> ";" +> newline+  printJS (JsWhile cond stmts) =+    "while (" +> cond +> ") {"  +> newline +>+    indented (printJS stmts) +>+    "}" +> newline+  printJS JsContinue =+    printJS "continue;" +> newline+  printJS (JsMappedVar _ name expr) =+    "var " +> name +> " = " +> expr +> ";" +> newline  -- | Print an expression. instance Printable JsExp where-  printJS (JsRawExp name) = write name-  printJS (JsThrowExp exp) = do "(function(){ throw ("; printJS exp; "); })()"-  printJS JsNull = "null"+  printJS (JsRawExp e) = write e   printJS (JsName name) = printJS name-  printJS (JsLit lit) = printJS lit-  printJS (JsParen exp) = do "("; printJS exp; ")"-  printJS (JsList exps) = do "["; intercalateM "," (map printJS exps); "]"-  printJS (JsNew name args) = do "new "; printJS (JsApp (JsName name) args)-  printJS (JsIndex i exp) = do "("; printJS exp; ")["; write (show i); "]"-  printJS (JsEq exp1 exp2) = do printJS exp1; " === "; printJS exp2-  printJS (JsGetProp exp prop) = do printJS exp; "."; printJS prop-  printJS (JsLookup exp1 exp2) = do printJS exp1; "["; printJS exp2; "]"-  printJS (JsUpdateProp name prop expr) = do-    "("; printJS name; "."; printJS prop; " = "; printJS expr; ")"-  printJS (JsInfix op x y) = do printJS x; " "; write op; " "; printJS y-  printJS (JsGetPropExtern exp prop) = do-    printJS exp; "["; printJS (JsLit (JsStr prop)); "]"-  printJS (JsUpdatePropExtern name prop expr) = do-    "("; printJS name; "['"; printJS prop; "'] = "; printJS expr; ")"-  printJS (JsTernaryIf cond conseq alt) = do-    printJS cond; " ? "; printJS conseq; " : "; printJS alt-  printJS (JsInstanceOf exp classname) = do-    printJS exp; " instanceof "; printJS classname-  printJS (JsObj assoc) = do "{"; intercalateM "," (map cons assoc); "}"-     where cons (key,value) = do "\""; write key; "\": "; printJS value-  printJS (JsFun params stmts ret) = do+  printJS (JsThrowExp exp) =+    "(function(){ throw (" +> exp +> "); })()"+  printJS JsNull =+    printJS "null"+  printJS JsUndefined =+    printJS "undefined"+  printJS (JsLit lit) =+    printJS lit+  printJS (JsParen exp) =+    "(" +> exp +> ")"+  printJS (JsList exps) =+    "[" +> intercalateM "," (map printJS exps) +> printJS "]"+  printJS (JsNew name args) =+    "new " +> (JsApp (JsName name) args)+  printJS (JsIndex i exp) =+    "(" +> exp +> ")[" +> show i +> "]"+  printJS (JsEq exp1 exp2) =+    exp1 +> " === " +> exp2+  printJS (JsNeq exp1 exp2) =+    exp1 +> " !== " +> exp2+  printJS (JsGetProp exp prop) = exp +> "." +> prop+  printJS (JsLookup exp1 exp2) =+    exp1 +> "[" +> exp2 +> "]"+  printJS (JsUpdateProp name prop expr) =+    "(" +> name +> "." +> prop +> " = " +> expr +> ")"+  printJS (JsInfix op x y) =+    x +> " " +> op +> " " +> y+  printJS (JsGetPropExtern exp prop) =+    exp +> "[" +> (JsLit . JsStr) prop +> "]"+  printJS (JsUpdatePropExtern name prop expr) =+    "(" +> name +> "['" +> prop +> "'] = " +> expr +> ")"+  printJS (JsTernaryIf cond conseq alt) =+    cond +> " ? " +> conseq +> " : " +> alt+  printJS (JsInstanceOf exp classname) =+    exp +> " instanceof " +> classname+  printJS (JsObj assoc) =+    "{" +> (intercalateM "," (map cons assoc)) +> "}"+      where cons (key,value) = "\"" +> key +> "\": " +> value+  printJS (JsFun params stmts ret) =     "function("-    intercalateM "," (map printJS params)-    "){"-    printJS stmts-    case ret of-      Just ret' -> do "return "; printJS ret'; ";"-      Nothing   -> return ()-    "}"-  printJS (JsApp op args) = do-    printJS (if isFunc op then JsParen op else op)-    "("-    intercalateM "," (map (printJS) args)-    ")"+    +> (intercalateM "," (map printJS params))+    +> "){" +> newline+    +> indented (stmts +>+                 case ret of+                   Just ret' -> "return " +> ret' +> ";" +> newline+                   Nothing   -> return ())+    +> "}"+  printJS (JsApp op args) =+    (if isFunc op then JsParen op else op)+    +> "("+    +> (intercalateM "," (map printJS args))+    +> ")"      where isFunc JsFun{..} = True; isFunc _ = False+  printJS (JsNegApp args) =+      "(-(" +> printJS args +> "))" +-- | Print one of the kinds of names.+instance Printable JsName where+  printJS name =+    case name of+      JsNameVar qname -> printJS qname+      JsThis -> write "this"+      JsThunk -> write "$"+      JsForce -> write "_"+      JsApply -> write "__"+      JsParam i -> write ("$p" ++ show i)+      JsTmp i -> write ("$tmp" ++ show i)+      JsConstructor qname -> "$_" +> printJS qname+      JsBuiltIn qname -> "Fay$$" +> printJS qname++instance Printable String where+  printJS = write++instance Printable (Printer ()) where+  printJS = id+ ----------------------------------------------------------------------------------- Utilities+-- Name encoding  -- Words reserved in haskell as well are not needed here: -- case, class, do, else, if, import, in, let@@ -171,38 +211,66 @@   "var", "void", "while", "window", "with", "yield","true","false"]  -- | Encode a Haskell name to JavaScript.--- TODO: Fix this hack.-jsEncodeName :: String -> String--- Special symbols:-jsEncodeName ":tmp" = "$tmp"-jsEncodeName ":thunk" = "$"-jsEncodeName ":this" = "this"--- jsEncodeName ":return" = "return"--- Used keywords:-jsEncodeName name-  | "$_" `isPrefixOf` name = normalize name-  | name `elem` reservedWords = "$_" ++ normalize name--- Anything else.-jsEncodeName name = normalize name+encodeName :: String -> String+-- | This is a hack for names generated in the Haskell AST. Should be+-- removed once it's no longer needed.+encodeName ('$':'g':'e':'n':name) = "$gen_" ++ normalizeName name+encodeName name+  | name `elem` reservedWords = "$_" ++ normalizeName name+  | otherwise                 = normalizeName name  -- | Normalize the given name to JavaScript-valid names.-normalize :: [Char] -> [Char]-normalize name =+normalizeName :: [Char] -> [Char]+normalizeName name =   concatMap encodeChar name    where     encodeChar c | c `elem` allowed = [c]-                 | otherwise      = escapeChar c+                 | otherwise        = escapeChar c     allowed = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_"     escapeChar c = "$" ++ charId c ++ "$"     charId c = show (fromEnum c) --- |-write :: String -> Printer a+--------------------------------------------------------------------------------+-- Printing+++-- | Print the given printer indented.+indented :: Printer a -> Printer ()+indented p = do+  PrintState{..} <- get+  if psPretty+     then do modify $ \s -> s { psIndentLevel = psIndentLevel + 1 }+             p+             modify $ \s -> s { psIndentLevel = psIndentLevel }+     else p >> return ()++-- | Output a newline.+newline :: Printer ()+newline = do+  PrintState{..} <- get+  when psPretty $ do+    write "\n"+    modify $ \s -> s { psNewline = True }++-- | Write out a string, updating the current position information.+write :: String -> Printer () write x = do-  modify $ \s -> s { psOutput = x : psOutput s }+  PrintState{..} <- get+  let out = if psNewline then replicate (2*psIndentLevel) ' ' ++ x else x+  modify $ \s -> s { psOutput  = out : psOutput+                   , psLine    = psLine + additionalLines+                   , psColumn  = if additionalLines > 0+                                    then length (concat (take 1 (reverse srclines)))+                                    else psColumn + length x+                   , psNewline = False+                   }   return (error "Nothing to return for writer string.") +  where srclines = lines x+        additionalLines = length (filter (=='\n') x)++-- | Intercalate monadic action. intercalateM :: String -> [Printer a] -> Printer () intercalateM _ [] = return () intercalateM _ [x] = x >> return ()@@ -211,15 +279,6 @@   write str   intercalateM str xs ---- | Helpful for writing qualified symbols (Fay.*).-instance IsString ModuleName where-  fromString = ModuleName---- | Helpful for writing variable names.-instance IsString JsName where-  fromString = UnQual . Ident---- | For the pretty printer convenience.-instance IsString (Printer a) where-  fromString = write+-- | Concatenate two printables.+(+>) :: (Printable a, Printable b) => a -> b -> Printer ()+pa +> pb = printJS pa >> printJS pb

@@ -1,11 +1,18 @@+{-# LANGUAGE NoImplicitPrelude #-} module Language.Fay.Stdlib   (($)   ,(++)   ,(.)+  ,(=<<)+  ,Defined(..)   ,Ordering(..)+  ,show+  ,fromInteger+  ,fromRational   ,any   ,compare   ,concat+  ,concatMap   ,const   ,elem   ,enumFrom@@ -33,6 +40,7 @@   ,otherwise   ,prependToAll   ,reverse+  ,sequence   ,snd   ,sort   ,sortBy@@ -44,11 +52,23 @@   where  import           Language.Fay.FFI-import           Prelude          (Bool(..), Double, Eq(..), Int, Maybe(..), Monad(..), Num(..),- Ord((>), (<)), (||))+import           Prelude          (Bool (..), Double, Eq (..), Fractional, Int,+                                   Integer, Maybe (..), Monad (..), Num ((+)),+                                   Ord ((>), (<)), Rational, Show, String, (||)) --- START+show :: (Foreign a,Show a) => a -> String+show = ffi "JSON.stringify(%1)" +data Defined a = Undefined | Defined a+instance Foreign a => Foreign (Defined a)++-- There is only Double in JS.+fromInteger :: a -> a+fromInteger x = x++fromRational :: a -> a+fromRational x = x+ snd :: (t, t1) -> t1 snd (_,x) = x @@ -165,6 +185,9 @@ concat :: [[a]] -> [a] concat = foldr conc [] +concatMap :: (a -> [b]) -> [a] -> [b]+concatMap f = foldr ((++) . f) []+ foldr :: (t -> t1 -> t1) -> t1 -> [t] -> t1 foldr _ z []     = z foldr f z (x:xs) = f x (foldr f z xs)@@ -203,9 +226,11 @@ const a _ = a  length :: [a] -> Int-length (_:xs) = 1 + length xs-length [] = 0+length xs = length' 0 xs +length' acc (_:xs) = length' (acc+1) xs+length' acc _ = acc+ mod :: Double -> Double -> Double mod = ffi "%1 %% %2" @@ -224,3 +249,15 @@ reverse :: [a] -> [a] reverse (x:xs) = reverse xs ++ [x] reverse [] = []++(=<<) :: Monad m => (a -> m b) -> m a -> m b+f =<< x = x >>= f+infixl 1 =<<++-- | Evaluate each action in the sequence from left to right,+-- and collect the results.+-- sequence :: [Fay a] -> Fay [a]+sequence :: (Monad m) => [m a] -> m [a]+sequence ms = foldr k (return []) ms+            where+              k m m' = do { x <- m; xs <- m'; return (x:xs) }

@@ -1,7 +1,9 @@+{-# OPTIONS -fno-warn-orphans #-} {-# LANGUAGE DeriveDataTypeable         #-} {-# LANGUAGE FunctionalDependencies     #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE OverloadedStrings          #-}  -- | All Fay types and instances. @@ -9,8 +11,7 @@   (JsStmt(..)   ,JsExp(..)   ,JsLit(..)-  ,JsParam-  ,JsName+  ,JsName(..)   ,CompileError(..)   ,Compile(..)   ,CompilesTo(..)@@ -21,25 +22,28 @@   ,defaultCompileState   ,FundamentalType(..)   ,PrintState(..)-  ,Printer(..))+  ,Printer(..)+  ,NameScope(..)+  ,Mapping(..))   where  import           Control.Applicative- import           Control.Monad.Error    (Error, ErrorT, MonadError) import           Control.Monad.Identity (Identity) import           Control.Monad.State- import           Data.Default+import           Data.Map               as M+import           Data.String import           Language.Haskell.Exts +import           Paths_fay+ -------------------------------------------------------------------------------- -- Compiler types  -- | Configuration of the compiler. data CompileConfig = CompileConfig-  { configTCO               :: Bool-  , configInlineForce       :: Bool+  { configOptimize          :: Bool   , configFlattenApps       :: Bool   , configExportBuiltins    :: Bool   , configDirectoryIncludes :: [FilePath]@@ -51,36 +55,85 @@   , configFilePath          :: Maybe FilePath   , configTypecheck         :: Bool   , configWall              :: Bool-  }+  } deriving (Show)  -- | Default configuration. instance Default CompileConfig where-  def = CompileConfig False False False True [] False False [] False True Nothing True False+  def = CompileConfig False False True [] False False [] False True Nothing True False  -- | State of the compiler. data CompileState = CompileState   { stateConfig      :: CompileConfig-  , stateExports     :: [Name]+  , stateExports     :: [QName]   , stateExportAll   :: Bool   , stateModuleName  :: ModuleName-  , stateRecords     :: [(Name,[Name])] -- records with field names+  , stateFilePath    :: FilePath+  , stateRecords     :: [(QName,[QName])]   , stateFayToJs     :: [JsStmt]   , stateJsToFay     :: [JsStmt]-  , stateImported    :: [String] -- ^ Names of imported modules so far.-}+  , stateImported    :: [(ModuleName,FilePath)]+  , stateNameDepth   :: Integer+  , stateScope       :: Map Name [NameScope]+} deriving (Show) -defaultCompileState :: CompileConfig -> CompileState-defaultCompileState config = CompileState {+-- | A name's scope, either imported or bound locally.+data NameScope = ScopeImported ModuleName (Maybe Name)+               | ScopeImportedAs Bool ModuleName Name+               | ScopeBinding++  deriving (Show,Eq)++-- | The default compiler state.+defaultCompileState :: CompileConfig -> IO CompileState+defaultCompileState config = do+  ffi <- getDataFileName "src/Language/Fay/Stdlib.hs"+  types <- getDataFileName "src/Language/Fay/Types.hs"+  prelude <- getDataFileName "src/Language/Fay/Prelude.hs"+  return $ CompileState {     stateConfig = config   , stateExports = []   , stateExportAll = True   , stateModuleName = ModuleName "Main"-  , stateRecords = [(Ident "Nothing",[]),(Ident "Just",[Ident "slot1"])]+  , stateRecords = [("Nothing",[]),("Just",["slot1"])]   , stateFayToJs = []   , stateJsToFay = []-  , stateImported = ["Language.Fay.Prelude","Language.Fay.FFI","Language.Fay.Types","Prelude"]+  , stateImported = [("Language.Fay.FFI",ffi),("Language.Fay.Types",types),("Prelude",prelude)]+  , stateNameDepth = 1+  , stateFilePath = "<unknown>"+  , stateScope = M.fromList primOps   } +-- | The built-in operations that aren't actually compiled from+-- anywhere, they come from runtime.js.+--+-- They're in the names list so that they can be overriden by the user+-- in e.g. let a * b = a - b in 1 * 2.+--+-- So we resolve them to Fay$, i.e. the prefix used for the runtime+-- support. $ is not allowed in Haskell module names, so there will be+-- no conflicts if a user decicdes to use a module named Fay.+--+-- So e.g. will compile to (*) Fay$$mult, which is in runtime.js.+primOps :: [(Name, [NameScope])]+primOps =+  [(Symbol ">>",[ScopeImported "Fay$" (Just "then")])+  ,(Symbol ">>=",[ScopeImported "Fay$" (Just "bind")])+  ,(Ident "return",[ScopeImported "Fay$" (Just "return")])+  ,(Ident "force",[ScopeImported "Fay$" (Just "force")])+  ,(Symbol "*",[ScopeImported "Fay$" (Just "mult")])+  ,(Symbol "*",[ScopeImported "Fay$" (Just "mult")])+  ,(Symbol "+",[ScopeImported "Fay$" (Just "add")])+  ,(Symbol "-",[ScopeImported "Fay$" (Just "sub")])+  ,(Symbol "/",[ScopeImported "Fay$" (Just "div")])+  ,(Symbol "==",[ScopeImported "Fay$" (Just "eq")])+  ,(Symbol "/=",[ScopeImported "Fay$" (Just "neq")])+  ,(Symbol ">",[ScopeImported "Fay$" (Just "gt")])+  ,(Symbol "<",[ScopeImported "Fay$" (Just "lt")])+  ,(Symbol ">=",[ScopeImported "Fay$" (Just "gte")])+  ,(Symbol "<=",[ScopeImported "Fay$" (Just "lte")])+  ,(Symbol "&&",[ScopeImported "Fay$" (Just "and")])+  ,(Symbol "||",[ScopeImported "Fay$" (Just "or")])]+ -- | Compile monad. newtype Compile a = Compile { unCompile :: StateT CompileState (ErrorT CompileError IO) a }   deriving (MonadState CompileState@@ -90,27 +143,29 @@            ,Functor            ,Applicative) --- | Convenience type for function parameters.-type JsParam = JsName---- | To be used to force name sanitization eventually.-type JsName = QName -- FIXME: Force sanitization at this point.- -- | Just a convenience class to generalize the parsing/printing of -- various types of syntax. class (Parseable from,Printable to) => CompilesTo from to | from -> to where   compileTo :: from -> Compile to +data Mapping = Mapping+  { mappingName :: String+  , mappingFrom :: SrcLoc+  , mappingTo   :: SrcLoc+  } deriving (Show)+ data PrintState = PrintState-  { psLine         :: Int+  { psPretty       :: Bool+  , psLine         :: Int   , psColumn       :: Int-  , psMapping      :: [(SrcLoc,SrcLoc)]+  , psMapping      :: [Mapping]   , psIndentLevel  :: Int   , psOutput       :: [String]+  , psNewline      :: Bool   }  instance Default PrintState where-  def = PrintState 0 0 [] 0 []+  def = PrintState False 0 0 [] 0 [] False  newtype Printer a = Printer { runPrinter :: State PrintState a }   deriving (Monad,Functor,MonadState PrintState)@@ -131,18 +186,24 @@   | UnsupportedLetBinding Decl   | UnsupportedOperator QOp   | UnsupportedPattern Pat+  | UnsupportedFieldPattern PatField   | UnsupportedRhs Rhs   | UnsupportedGuardedAlts GuardedAlts+  | UnsupportedImport ImportDecl+  | UnsupportedQualStmt QualStmt   | EmptyDoBlock   | UnsupportedModuleSyntax Module   | LetUnsupported   | InvalidDoBlock   | RecursiveDoUnsupported+  | Couldn'tFindImport ModuleName [FilePath]   | FfiNeedsTypeSig Decl   | FfiFormatBadChars String   | FfiFormatNoSuchArg Int   | FfiFormatIncompleteArg   | FfiFormatInvalidJavaScript String String+  | UnableResolveUnqualified Name+  | UnableResolveQualified QName   deriving (Show) instance Error CompileError @@ -171,9 +232,10 @@ data JsExp   = JsName JsName   | JsRawExp String-  | JsFun [JsParam] [JsStmt] (Maybe JsExp)+  | JsFun [JsName] [JsStmt] (Maybe JsExp)   | JsLit JsLit   | JsApp JsExp [JsExp]+  | JsNegApp JsExp   | JsTernaryIf JsExp JsExp JsExp   | JsNull   | JsParen JsExp@@ -188,10 +250,25 @@   | JsInstanceOf JsExp JsName   | JsIndex Int JsExp   | JsEq JsExp JsExp+  | JsNeq JsExp JsExp   | JsInfix String JsExp JsExp -- Used to optimize *, /, +, etc   | JsObj [(String,JsExp)]+  | JsUndefined   deriving (Show,Eq) +-- | A name of some kind.+data JsName+  = JsNameVar QName+  | JsThis+  | JsThunk+  | JsForce+  | JsApply+  | JsParam Integer+  | JsTmp Integer+  | JsConstructor QName+  | JsBuiltIn Name+  deriving (Eq,Show)+ -- | Literal value type. data JsLit   = JsChar Char@@ -203,7 +280,7 @@  -- | These are the data types that are serializable directly to native -- JS data types. Strings, floating points and arrays. The others are:--- actiosn in the JS monad, which are thunks that shouldn't be forced+-- actions in the JS monad, which are thunks that shouldn't be forced -- when serialized but wrapped up as JS zero-arg functions, and -- unknown types can't be converted but should at least be forced. data FundamentalType@@ -211,7 +288,9 @@  = FunctionType [FundamentalType]  | JsType FundamentalType  | ListType FundamentalType+ | TupleType [FundamentalType]  | UserDefined Name [FundamentalType]+ | Defined FundamentalType  -- Simple types.  | DateType  | StringType@@ -221,3 +300,15 @@  -- | Unknown.  | UnknownType    deriving (Show)++-- | Helpful for some things.+instance IsString Name where+  fromString = Ident++-- | Helpful for some things.+instance IsString QName where+  fromString = UnQual . Ident++-- | Helpful for writing qualified symbols (Fay.*).+instance IsString ModuleName where+  fromString = ModuleName

@@ -1,3 +1,4 @@+{-# LANGUAGE RecordWildCards #-} {-# OPTIONS -fno-warn-orphans #-} {-# OPTIONS -fno-warn-orphans #-} {-# LANGUAGE FlexibleContexts #-}@@ -7,9 +8,8 @@  import           Language.Fay import           Language.Fay.Compiler-import           Language.Fay.Types-import           Paths_fay                (version) +import           Paths_fay                (version) import qualified Control.Exception        as E import           Control.Monad import           Control.Monad.Error@@ -24,7 +24,6 @@ -- | Options and help. data FayCompilerOptions = FayCompilerOptions     { optLibrary     :: Bool-    , optInlineForce :: Bool     , optFlattenApps :: Bool     , optHTMLWrapper :: Bool     , optHTMLJSLibs  :: [String]@@ -36,32 +35,73 @@     , optOutput      :: Maybe String     , optPretty      :: Bool     , optFiles       :: [String]+    , optOptimize    :: Bool     } +-- | Main entry point.+main :: IO ()+main = do+  opts <- execParser parser+  if optVersion opts+    then runCommandVersion+    else do let config = def+                  { configOptimize          = optOptimize opts+                  , configFlattenApps       = optFlattenApps opts+                  , configExportBuiltins    = True+                  , configDirectoryIncludes = "." : optInclude opts+                  , configPrettyPrint       = optPretty opts+                  , configLibrary           = optLibrary opts+                  , configHtmlWrapper       =  optHTMLWrapper opts+                  , configHtmlJSLibs        = optHTMLJSLibs opts+                  , configTypecheck         = not $ optNoGHC opts+                  , configWall              = optWall opts+                  }+            void $ incompatible htmlAndStdout opts "Html wrapping and stdout are incompatible"+            case optFiles opts of+                 ["-"] -> do+                         hGetContents stdin >>= printCompile config compileModule+                 [] -> runInteractive+                 files  -> forM_ files $ \file -> do+                         if optStdout opts+                           then compileFromTo config file Nothing+                           else compileFromTo config file (Just (outPutFile opts file))++  where+    parser = info (helper <*> options) (fullDesc & header helpTxt)++    outPutFile :: FayCompilerOptions -> String -> FilePath+    outPutFile opts file = fromMaybe (toJsName file) $ optOutput opts++-- | All Fay's command-line options. options :: Parser FayCompilerOptions options = FayCompilerOptions   <$> switch (long "library" & help "Don't automatically call main in generated JavaScript")-  <*> switch (long "inline-force" & help "inline forcing, adds some speed for numbers, blows up code a bit")   <*> switch (long "flatten-apps" & help "flatten function applicaton")-   <*> switch (long "html-wrapper" & help "Create an html file that loads the javascript")-  <*> strsOption (long "html-js-lib" & metavar "file1[, ..]" & help "javascript files to add to <head> if using option html-wrapper")--  <*> strsOption (long "include" & metavar "dir1[, ..]" & help "additional directories for include")-+  <*> strsOption (long "html-js-lib" & metavar "file1[, ..]"+      & help "javascript files to add to <head> if using option html-wrapper")+  <*> strsOption (long "include" & metavar "dir1[, ..]"+      & help "additional directories for include")   <*> switch (long "Wall" & help "Typecheck with -Wall")   <*> switch (long "no-ghc" & help "Don't typecheck, specify when not working with files")-   <*> switch (long "stdout" & short 's' & help "Output to stdout")   <*> switch (long "version" & help "Output version number")-  <*> nullOption (long "output" & short 'o' & reader (Just . Just) & value Nothing & help "Output to specified file")+  <*> nullOption (long "output" & short 'o' & reader (Just . Just) & value Nothing+      & help "Output to specified file")   <*> switch (long "pretty" & short 'p' & help "Pretty print the output")-   <*> arguments Just (metavar "- | <hs-file>...")+  <*> switch (long "optimize" & short 'O' & help "Apply optimizations to generated code") -  where-    strsOption m = nullOption (m & reader (Just . wordsBy (== ',')) & value [])+  where strsOption m =+          nullOption (m & reader (Just . wordsBy (== ',')) & value []) +-- | Make incompatible options.+incompatible :: Monad m => (FayCompilerOptions -> Bool)+                        -> FayCompilerOptions -> String -> m Bool+incompatible test opts message = case test opts of+             True -> E.throw $ userError message+             False -> return True+ -- | The basic help text. helpTxt :: String helpTxt = concat@@ -72,77 +112,34 @@   ,"  fay <hs-file>... processes each .hs file"   ] --- | Main entry point.-main :: IO ()-main = do-  opts <- execParser parser-  if optVersion opts-    then runCommandVersion-    else (do-  let config = def { configTCO = False -- optTCO opts-                   , configInlineForce = optInlineForce opts-                   , configFlattenApps = optFlattenApps opts-                   , configExportBuiltins = True -- optExportBuiltins opts--                   , configDirectoryIncludes = "." : optInclude opts-                   , configPrettyPrint = optPretty opts-                   , configLibrary = optLibrary opts-                   , configHtmlWrapper =  optHTMLWrapper opts-                   , configHtmlJSLibs = optHTMLJSLibs opts-                   , configTypecheck = not $ optNoGHC opts-                   , configWall = optWall opts-                   }-  void $ incompatible htmlAndStdout opts "Html wrapping and stdout are incompatible"--  case optFiles opts of-       ["-"] -> do-               hGetContents stdin >>= printCompile config compileModule-       [] -> runInteractive-       files  -> forM_ files $ \file -> do-               if optStdout opts-                 then compileReadWrite config file stdout-                 else-                    compileFromTo config file $ outPutFile opts file)---  where-    parser = info (helper <*> options) (fullDesc & header helpTxt)--    outPutFile :: FayCompilerOptions -> String -> FilePath-    outPutFile opts file = fromMaybe (toJsName file) $ optOutput opts--runInteractive :: IO ()-runInteractive =-    runInputT defaultSettings loop-  where-    loop = do-        minput <- getInputLine "> "-        case minput of-            Nothing -> return ()-            Just "" -> loop-            Just input -> do-                result <- liftIO $ compileViaStr def compileExp input-                case result of-                    Left err -> outputStrLn . show $ err-                    Right (ok,_) -> liftIO (prettyPrintString ok) >>= outputStr-                loop-+-- | Print the command version. runCommandVersion :: IO () runCommandVersion = putStrLn $ "fay " ++ showVersion version --+-- | Incompatible options. htmlAndStdout :: FayCompilerOptions -> Bool htmlAndStdout opts = optHTMLWrapper opts && optStdout opts -incompatible :: Monad m => (FayCompilerOptions -> Bool)-                        -> FayCompilerOptions -> String -> m Bool-incompatible test opts message = case test opts of-             True -> E.throw $ userError message-             False -> return True--instance Writer Handle where-  writeout = hPutStr--instance Reader Handle where-  readin = hGetContents+-- | Run interactively.+runInteractive :: IO ()+runInteractive = runInputT defaultSettings loop where+  loop = do+      minput <- getInputLine "> "+      case minput of+          Nothing -> return ()+          Just "" -> loop+          Just input -> do+              result <- liftIO $ compileViaStr "<interactive>" config compileExp input+              case result of+                  Left err -> do+                    -- an error occured, maybe input was not an expression,+                    -- but a declaration, try compiling the input as a declaration+                    outputStrLn ("can't parse input as expression: " ++ show err)+                    result' <- liftIO $ compileViaStr "<interactive>" config (compileDecl True) input+                    case result' of+                      Right (PrintState{..},_) -> outputStr (concat (reverse psOutput))+                      Left err' ->+                        outputStrLn ("can't parse input as declaration: " ++ show err')+                  Right (PrintState{..},_) -> outputStr (concat (reverse psOutput))+              loop+  config = def { configPrettyPrint = True }

@@ -1,10 +1,16 @@+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-}  module Test.Api (tests) where -import           Data.Default+import           Language.Fay                   hiding (compileFile) import           Language.Fay.Compiler-import           Language.Fay.Types+import           Paths_fay++import           Data.Default+import           Data.Maybe+import           Language.Haskell.Exts.Syntax+import           System.FilePath import           Test.Framework import           Test.Framework.Providers.HUnit import           Test.Framework.TH@@ -16,5 +22,28 @@  case_imports :: Assertion case_imports = do-  res <- compileFile def { configTypecheck = False, configDirectoryIncludes = ["tests"] } "tests/RecordImport_Import.hs"+  res <- compileFile defConf fp   assertBool "Could not compile file with imports" (isRight res)++case_importedList :: Assertion+case_importedList = do+  res <- compileFile defConf fp+  case res of+    Left err -> error (show err)+    Right r -> assertBool "RecordImport_Export was not added to stateImported" $+                 isJust $ lookup (ModuleName "RecordImport_Export") (stateImported r)++fp :: FilePath+fp = "tests/RecordImport_Import.hs"++defConf :: CompileConfig+defConf = def { configTypecheck = False, configDirectoryIncludes = ["tests"] }++compileFile :: CompileConfig -> FilePath -> IO (Either CompileError CompileState)+compileFile config filein = do+  srcdir <- fmap (takeDirectory . takeDirectory . takeDirectory) (getDataFileName "src/Language/Fay/Stdlib.hs")+  hscode <- readFile filein+  result <- compileViaStr filein+    (config { configDirectoryIncludes = configDirectoryIncludes config ++ [srcdir] })+    compileToplevelModule hscode+  return $ either Left (Right . snd) result

@@ -51,6 +51,12 @@   ,ReadTest $ LabelledRecord2 { bar = 123, bob = 66.6 }   ,ReadTest $ FooBar "Tinkie Winkie" "Humanzee" Zot   ,ReadTest $ Bar $ Foo "one" "two"+  ,ReadTest $ StepcutFoo 123+  ,ReadTest $ StepcutBar (StepcutFoo 456)+  ,ReadTest $ StepcutFoo' 789+  ,ReadTest $ Baz (StepcutFoo' 10112)+  ,ReadTest $ (Just 1 :: Maybe Double)+  ,ReadTest $ (Nothing :: Maybe Double)   ]  -- | Test cases.@@ -65,6 +71,9 @@   ,((1,2) :: (Int,Int)) → "[1,2]"   ,"abc" → "\"abc\""   ,'a' → "\"a\""+  -- Special cases+  , Just (1 :: Double) → "1.0"+  , (Nothing :: Maybe Double) → "null"   -- Data records   ,NullaryConstructor → "{\"instance\":\"NullaryConstructor\"}"   ,NAryConstructor 123 4.5 → "{\"slot1\":123,\"slot2\":4.5,\"instance\":\"NAryConstructor\"}"@@ -120,3 +129,15 @@ -- | This triggers order difference. Go figure. data Zot = Zot   deriving (Read,Data,Typeable,Show,Eq)++data StepcutFoo = StepcutFoo { _unStepcutFoo :: Int }+    deriving (Eq, Show, Read, Typeable, Data)++data StepcutBar = StepcutBar StepcutFoo+    deriving (Eq, Show, Read, Typeable, Data)++data StepcutFoo' = StepcutFoo' Int+    deriving (Eq, Show, Read, Typeable, Data)++data Baz = Baz StepcutFoo'+    deriving (Eq, Show, Read, Typeable, Data)

@@ -7,8 +7,7 @@  import           Data.Default import           Data.List-import           Language.Fay.Compiler-import           Language.Fay.Types+import           Language.Fay import           System.Directory import           System.FilePath import           System.Process.Extra@@ -34,7 +33,7 @@       let root = (reverse . drop 1 . dropWhile (/='.') . reverse) file           out = toJsName file       outExists <- doesFileExist root-      compileFromTo def { configTypecheck = False, configDirectoryIncludes = ["tests/"] } file out+      compileFromTo def { configTypecheck = False, configDirectoryIncludes = ["tests/"] } file (Just out)       result <- runJavaScriptFile out       if outExists          then do output <- readFile root

@@ -1,4 +1,4 @@-{-# LANGUAGE NoImplicitPrelude #-}+  module Bool where 

@@ -1,532 +0,0 @@-/** @constructor-*/-var Bool = 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.value = this.value(), this.forced = true, this.value));-};--/*******************************************************************************- * Monad.- */--function Fay$$Monad(value){-    this.value = value;-}--// >>-// encode_fay_to_js(">>=") → $62$$62$-// This is used directly from Fay, but can be rebound or shadowed.-function $62$$62$(a){-    return function(b){-        return new $(function(){-            _(a,true);-            return b;-        });-    };-}--// >>=-// encode_fay_to_js(">>=") → $62$$62$$61$-// This is used directly from Fay, but can be rebound or shadowed.-function $62$$62$$61$(m){-    return function(f){-        return new $(function(){-            var monad = _(m,true);-            return f(monad.value);-        });-    };-}--// This is used directly from Fay, but can be rebound or shadowed.-function $_return(a){-    return new Fay$$Monad(a);-}--var Fay$$unit = null;--/*******************************************************************************- * Serialization.- * Fay <-> JS. Should be bijective.- */--// Serialize a Fay object to JS.-function Fay$$fayToJs(type,fayObj){-    var base = type[0];-    var args = type[1];-    var jsObj;-    switch(base){-    case "action": {-        // A nullary monadic action. Should become a nullary JS function.-        // Fay () -> function(){ return ... }-        jsObj = function(){-            return Fay$$fayToJs(args[0],_(fayObj,true).value);-        };-        break;-    }-    case "function": {-        // A proper function.-        jsObj = function(){-            var fayFunc = fayObj;-            var return_type = args[args.length-1];-            var len = args.length;-            // If some arguments.-            if (len > 1) {-                // Apply to all the arguments.-                fayFunc = _(fayFunc,true);-                // TODO: Perhaps we should throw an error when JS-                // passes more arguments than Haskell accepts.-                for (var i = 0, len = len; i < len - 1 && fayFunc instanceof Function; i++) {-                    // Unserialize the JS values to Fay for the Fay callback.-                    fayFunc = _(fayFunc(Fay$$jsToFay(args[i],arguments[i])),true);-                }-                // Finally, serialize the Fay return value back to JS.-                var return_base = return_type[0];-                var return_args = return_type[1];-                // If it's a monadic return value, get the value instead.-                if(return_base == "action") {-                    return Fay$$fayToJs(return_args[0],fayFunc.value);-                }-                // Otherwise just serialize the value direct.-                else {-                    return Fay$$fayToJs(return_type,fayFunc);-                }-            } else {-                throw new Error("Nullary function?");-            }-        };-        break;-    }-    case "string": {-        // Serialize Fay string to JavaScript string.-        var str = "";-        fayObj = _(fayObj);-        while(fayObj instanceof Fay$$Cons) {-            str += fayObj.car;-            fayObj = _(fayObj.cdr);-        }-        jsObj = str;-        break;-    }-    case "list": {-        // Serialize Fay list to JavaScript array.-        var arr = [];-        fayObj = _(fayObj);-        while(fayObj instanceof Fay$$Cons) {-            arr.push(Fay$$fayToJs(args[0],fayObj.car));-            fayObj = _(fayObj.cdr);-        }-        jsObj = arr;-        break;-    }-    case "double": {-        // Serialize double, just force the argument. Doubles are unboxed.-        jsObj = _(fayObj);-        break;-    }-    case "int": {-        // Serialize int, just force the argument. Ints are unboxed.-        jsObj = _(fayObj);-        break;-    }-    case "bool": {-        // Bools are unboxed.-        jsObj = _(fayObj);-        break;-    }-    case "unknown":-    case "user": {-        if(fayObj instanceof $)-            fayObj = _(fayObj);-        jsObj = Fay$$fayToJsUserDefined(type,fayObj);-        break;-    }-    default: throw new Error("Unhandled Fay->JS translation type: " + base);-    }-    return jsObj;-}--// Unserialize an object from JS to Fay.-function Fay$$jsToFay(type,jsObj){-    var base = type[0];-    var args = type[1];-    var fayObj;-    switch(base){-    case "action": {-        // Unserialize a "monadic" JavaScript return value into a monadic value.-        fayObj = new Fay$$Monad(Fay$$jsToFay(args[0],jsObj));-        break;-    }-    case "string": {-        // Unserialize a JS string into Fay list (String).-        fayObj = Fay$$list(jsObj);-        break;-    }-    case "list": {-        // Unserialize a JS array into a Fay list ([a]).-        var serializedList = [];-        for (var i = 0, len = jsObj.length; i < len; i++) {-            // Unserialize each JS value into a Fay value, too.-            serializedList.push(Fay$$jsToFay(args[0],jsObj[i]));-        }-        // Pop it all in a Fay list.-        fayObj = Fay$$list(serializedList);-        break;-    }-    case "double": {-        // Doubles are unboxed, so there's nothing to do.-        fayObj = jsObj;-        break;-    }-    case "int": {-        // Int are unboxed, so there's no forcing to do.-        // But we can do validation that the int has no decimal places.-        // E.g. Math.round(x)!=x? throw "NOT AN INTEGER, GET OUT!"-        fayObj = Math.round(jsObj);-        if(fayObj!==jsObj) throw "Argument " + jsObj + " is not an integer!";-        break;-    }-    case "bool": {-        // Bools are unboxed.-        fayObj = jsObj;-        break;-    }-    case "unknown":-    case "user": {-        if (jsObj && jsObj['instance']) {-            fayObj = Fay$$jsToFayUserDefined(type,jsObj);-        }-        else-            fayObj = jsObj;-        break;-    }-    default: throw new Error("Unhandled JS->Fay translation type: " + base);-    }-    return fayObj;-}--/*******************************************************************************- * 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 new $(function(){-            return _(x) * _(y);-        });-    };-}-var $42$ = Fay$$mult;--// Built-in +.-function Fay$$add(x){-    return function(y){-        return new $(function(){-            return _(x) + _(y);-        });-    };-}-var $43$ = Fay$$add;--// Built-in -.-function Fay$$sub(x){-    return function(y){-        return new $(function(){-            return _(x) - _(y);-        });-    };-}-var $45$ = Fay$$sub;--// Built-in /.-function Fay$$div(x){-    return function(y){-        return new $(function(){-            return _(x) / _(y);-        });-    };-}-var $47$ = Fay$$div;--/*******************************************************************************- * 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 && lit2 instanceof Fay$$Cons) {-        do {-            if (!Fay$$equal(lit1.car,lit2.car))-                return false;-            lit1 = _(lit1.cdr), lit2 = _(lit2.cdr);-            if (lit1 === null || lit2 === null)-                return lit1 === lit2;-        } while (true);-    } else if (typeof lit1 == 'object' && typeof lit2 == 'object' && lit1 && lit2 &&-              lit1.constructor === lit2.constructor) {-      for(var x in lit1) {-        if(!(lit1.hasOwnProperty(x) && lit2.hasOwnProperty(x) &&-            Fay$$equal(lit1[x],lit2[x])))-          return false;-      }-      return true;-    } else {-      return false;-    }-}--// Built-in ==.-function Fay$$eq(x){-    return function(y){-        return new $(function(){-            return Fay$$equal(x,y);-        });-    };-}-var $61$$61$ = Fay$$eq;--// Built-in /=.-function Fay$$neq(x){-    return function(y){-        return new $(function(){-            return !(Fay$$equal(x,y));-        });-    };-}-var $47$$61$ = Fay$$neq;--// Built-in >.-function Fay$$gt(x){-    return function(y){-        return new $(function(){-            return _(x) > _(y);-        });-    };-}-var $62$ = Fay$$gt;--// Built-in <.-function Fay$$lt(x){-    return function(y){-        return new $(function(){-            return _(x) < _(y);-        });-    };-}-var $60$ = Fay$$lt;--// Built-in >=.-function Fay$$gte(x){-    return function(y){-        return new $(function(){-            return _(x) >= _(y);-        });-    };-}-var $62$$61$ = Fay$$gte;--// Built-in <=.-function Fay$$lte(x){-    return function(y){-        return new $(function(){-            return _(x) <= _(y);-        });-    };-}-var $60$$61$ = Fay$$lte;--// Built-in &&.-function Fay$$and(x){-    return function(y){-        return new $(function(){-            return _(x) && _(y);-        });-    };-}-var $38$$38$ = Fay$$and;--// Built-in ||.-function Fay$$or(x){-    return function(y){-        return new $(function(){-            return _(x) || _(y);-        });-    };-}-var $124$$124$ = Fay$$or;--/*******************************************************************************- * 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 _(print)(true);});var print = function($36$_a){return new $(function(){return Fay$$jsToFay(["action",[["unknown"]]],console.log(Fay$$fayToJs(["bool"],$36$_a)));});};var $36$_Just = function(slot1){this.slot1 = slot1;};var Just = function(slot1){return new $(function(){return new $36$_Just(slot1);});};var $36$_Nothing = function(){};var Nothing = new $(function(){return new $36$_Nothing();});var show = function($36$_a){return new $(function(){return Fay$$jsToFay(["string"],JSON.stringify(Fay$$fayToJs(["unknown"],$36$_a)));});};var fromInteger = function($36$_a){return new $(function(){var x = $36$_a;return x;});};var fromRational = function($36$_a){return new $(function(){var x = $36$_a;return x;});};var snd = function($36$_a){return new $(function(){var x = Fay$$index(1)(_($36$_a));return x;throw ["unhandled case in Ident \"snd\"",[$36$_a]];});};var fst = function($36$_a){return new $(function(){var x = Fay$$index(0)(_($36$_a));return x;throw ["unhandled case in Ident \"fst\"",[$36$_a]];});};var find = function($36$_a){return function($36$_b){return new $(function(){var $36$_$36$_b = _($36$_b);if ($36$_$36$_b instanceof Fay$$Cons) {var x = $36$_$36$_b.car;var xs = $36$_$36$_b.cdr;var p = $36$_a;return _(_(p)(x)) ? _(Just)(x) : _(_(find)(p))(xs);}if (_($36$_b) === null) {return Nothing;}throw ["unhandled case in Ident \"find\"",[$36$_a,$36$_b]];});};};var any = function($36$_a){return function($36$_b){return new $(function(){var $36$_$36$_b = _($36$_b);if ($36$_$36$_b instanceof Fay$$Cons) {var x = $36$_$36$_b.car;var xs = $36$_$36$_b.cdr;var p = $36$_a;return _(_(p)(x)) ? true : _(_(any)(p))(xs);}if (_($36$_b) === null) {return false;}throw ["unhandled case in Ident \"any\"",[$36$_a,$36$_b]];});};};var filter = function($36$_a){return function($36$_b){return new $(function(){var $36$_$36$_b = _($36$_b);if ($36$_$36$_b instanceof Fay$$Cons) {var x = $36$_$36$_b.car;var xs = $36$_$36$_b.cdr;var p = $36$_a;return _(_(p)(x)) ? _(_(Fay$$cons)(x))(_(_(filter)(p))(xs)) : _(_(filter)(p))(xs);}if (_($36$_b) === null) {return null;}throw ["unhandled case in Ident \"filter\"",[$36$_a,$36$_b]];});};};var not = function($36$_a){return new $(function(){var p = $36$_a;return _(p) ? false : true;});};var $_null = function($36$_a){return new $(function(){if (_($36$_a) === null) {return true;}return false;});};var map = function($36$_a){return function($36$_b){return new $(function(){if (_($36$_b) === null) {return null;}var $36$_$36$_b = _($36$_b);if ($36$_$36$_b instanceof Fay$$Cons) {var x = $36$_$36$_b.car;var xs = $36$_$36$_b.cdr;var f = $36$_a;return _(_(Fay$$cons)(_(f)(x)))(_(_(map)(f))(xs));}throw ["unhandled case in Ident \"map\"",[$36$_a,$36$_b]];});};};var nub = function($36$_a){return new $(function(){var ls = $36$_a;return _(_(nub$39$)(ls))(null);});};var nub$39$ = function($36$_a){return function($36$_b){return new $(function(){if (_($36$_a) === null) {return null;}var ls = $36$_b;var $36$_$36$_a = _($36$_a);if ($36$_$36$_a instanceof Fay$$Cons) {var x = $36$_$36$_a.car;var xs = $36$_$36$_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'\"",[$36$_a,$36$_b]];});};};var elem = function($36$_a){return function($36$_b){return new $(function(){var $36$_$36$_b = _($36$_b);if ($36$_$36$_b instanceof Fay$$Cons) {var y = $36$_$36$_b.car;var ys = $36$_$36$_b.cdr;var x = $36$_a;return _(Fay$$or)(_(_(_(Fay$$eq)(x))(y)))(_(_(_(elem)(x))(ys)));}if (_($36$_b) === null) {return false;}throw ["unhandled case in Ident \"elem\"",[$36$_a,$36$_b]];});};};var $36$_GT = function(){};var GT = new $(function(){return new $36$_GT();});var $36$_LT = function(){};var LT = new $(function(){return new $36$_LT();});var $36$_EQ = function(){};var EQ = new $(function(){return new $36$_EQ();});var sort = new $(function(){return _(sortBy)(compare);});var compare = function($36$_a){return function($36$_b){return new $(function(){var y = $36$_b;var x = $36$_a;return _(_(Fay$$gt)(_(x))(_(y))) ? GT : _(_(Fay$$lt)(_(x))(_(y))) ? LT : EQ;});};};var sortBy = function($36$_a){return new $(function(){var cmp = $36$_a;return _(_(foldr)(_(insertBy)(cmp)))(null);});};var insertBy = function($36$_a){return function($36$_b){return function($36$_c){return new $(function(){if (_($36$_c) === null) {var x = $36$_b;return Fay$$list([x]);}var ys = $36$_c;var x = $36$_b;var cmp = $36$_a;return (function($36$_ys){if (_($36$_ys) === null) {return Fay$$list([x]);}var $36$_$36$_ys = _($36$_ys);if ($36$_$36$_ys instanceof Fay$$Cons) {var y = $36$_$36$_ys.car;var ys$39$ = $36$_$36$_ys.cdr;return (function($tmp){if (_($tmp) instanceof $36$_GT) {return _(_(Fay$$cons)(y))(_(_(_(insertBy)(cmp))(x))(ys$39$));}return _(_(Fay$$cons)(x))(ys);})(_(_(cmp)(x))(y));}return (function(){ throw (["unhandled case",$36$_ys]); })();})(ys);});};};};var when = function($36$_a){return function($36$_b){return new $(function(){var m = $36$_b;var p = $36$_a;return _(p) ? _(_($62$$62$)(m))(_($_return)(Fay$$unit)) : _($_return)(Fay$$unit);});};};var enumFrom = function($36$_a){return new $(function(){var i = $36$_a;return _(_(Fay$$cons)(i))(_(enumFrom)(_(Fay$$add)(_(i))(1)));});};var enumFromTo = function($36$_a){return function($36$_b){return new $(function(){var n = $36$_b;var i = $36$_a;return _(_(_(Fay$$eq)(i))(n)) ? Fay$$list([i]) : _(_(Fay$$cons)(i))(_(_(enumFromTo)(_(Fay$$add)(_(i))(1)))(n));});};};var zipWith = function($36$_a){return function($36$_b){return function($36$_c){return new $(function(){var $36$_$36$_c = _($36$_c);if ($36$_$36$_c instanceof Fay$$Cons) {var b = $36$_$36$_c.car;var bs = $36$_$36$_c.cdr;var $36$_$36$_b = _($36$_b);if ($36$_$36$_b instanceof Fay$$Cons) {var a = $36$_$36$_b.car;var as = $36$_$36$_b.cdr;var f = $36$_a;return _(_(Fay$$cons)(_(_(f)(a))(b)))(_(_(_(zipWith)(f))(as))(bs));}}return null;});};};};var zip = function($36$_a){return function($36$_b){return new $(function(){var $36$_$36$_b = _($36$_b);if ($36$_$36$_b instanceof Fay$$Cons) {var b = $36$_$36$_b.car;var bs = $36$_$36$_b.cdr;var $36$_$36$_a = _($36$_a);if ($36$_$36$_a instanceof Fay$$Cons) {var a = $36$_$36$_a.car;var as = $36$_$36$_a.cdr;return _(_(Fay$$cons)(Fay$$list([a,b])))(_(_(zip)(as))(bs));}}return null;});};};var flip = function($36$_a){return function($36$_b){return function($36$_c){return new $(function(){var y = $36$_c;var x = $36$_b;var f = $36$_a;return _(_(f)(y))(x);});};};};var maybe = function($36$_a){return function($36$_b){return function($36$_c){return new $(function(){if (_($36$_c) instanceof $36$_Nothing) {var m = $36$_a;return m;}if (_($36$_c) instanceof $36$_Just) {var x = _($36$_c).slot1;var f = $36$_b;return _(f)(x);}throw ["unhandled case in Ident \"maybe\"",[$36$_a,$36$_b,$36$_c]];});};};};var $46$ = function($36$_a){return function($36$_b){return function($36$_c){return new $(function(){var x = $36$_c;var g = $36$_b;var f = $36$_a;return _(f)(_(g)(x));});};};};var $43$$43$ = function($36$_a){return function($36$_b){return new $(function(){var y = $36$_b;var x = $36$_a;return _(_(conc)(x))(y);});};};var $36$ = function($36$_a){return function($36$_b){return new $(function(){var x = $36$_b;var f = $36$_a;return _(f)(x);});};};var conc = function($36$_a){return function($36$_b){return new $(function(){var ys = $36$_b;var $36$_$36$_a = _($36$_a);if ($36$_$36$_a instanceof Fay$$Cons) {var x = $36$_$36$_a.car;var xs = $36$_$36$_a.cdr;return _(_(Fay$$cons)(x))(_(_(conc)(xs))(ys));}var ys = $36$_b;if (_($36$_a) === null) {return ys;}throw ["unhandled case in Ident \"conc\"",[$36$_a,$36$_b]];});};};var concat = new $(function(){return _(_(foldr)(conc))(null);});var foldr = function($36$_a){return function($36$_b){return function($36$_c){return new $(function(){if (_($36$_c) === null) {var z = $36$_b;return z;}var $36$_$36$_c = _($36$_c);if ($36$_$36$_c instanceof Fay$$Cons) {var x = $36$_$36$_c.car;var xs = $36$_$36$_c.cdr;var z = $36$_b;var f = $36$_a;return _(_(f)(x))(_(_(_(foldr)(f))(z))(xs));}throw ["unhandled case in Ident \"foldr\"",[$36$_a,$36$_b,$36$_c]];});};};};var foldl = function($36$_a){return function($36$_b){return function($36$_c){return new $(function(){if (_($36$_c) === null) {var z = $36$_b;return z;}var $36$_$36$_c = _($36$_c);if ($36$_$36$_c instanceof Fay$$Cons) {var x = $36$_$36$_c.car;var xs = $36$_$36$_c.cdr;var z = $36$_b;var f = $36$_a;return _(_(_(foldl)(f))(_(_(f)(z))(x)))(xs);}throw ["unhandled case in Ident \"foldl\"",[$36$_a,$36$_b,$36$_c]];});};};};var lookup = function($36$_a){return function($36$_b){return new $(function(){if (_($36$_b) === null) {var _key = $36$_a;return Nothing;}var $36$_$36$_b = _($36$_b);if ($36$_$36$_b instanceof Fay$$Cons) {var x = Fay$$index(0)(_($36$_$36$_b.car));var y = Fay$$index(1)(_($36$_$36$_b.car));var xys = $36$_$36$_b.cdr;var key = $36$_a;return _(_(_(Fay$$eq)(key))(x)) ? _(Just)(y) : _(_(lookup)(key))(xys);}throw ["unhandled case in Ident \"lookup\"",[$36$_a,$36$_b]];});};};var intersperse = function($36$_a){return function($36$_b){return new $(function(){if (_($36$_b) === null) {return null;}var $36$_$36$_b = _($36$_b);if ($36$_$36$_b instanceof Fay$$Cons) {var x = $36$_$36$_b.car;var xs = $36$_$36$_b.cdr;var sep = $36$_a;return _(_(Fay$$cons)(x))(_(_(prependToAll)(sep))(xs));}throw ["unhandled case in Ident \"intersperse\"",[$36$_a,$36$_b]];});};};var prependToAll = function($36$_a){return function($36$_b){return new $(function(){if (_($36$_b) === null) {return null;}var $36$_$36$_b = _($36$_b);if ($36$_$36$_b instanceof Fay$$Cons) {var x = $36$_$36$_b.car;var xs = $36$_$36$_b.cdr;var sep = $36$_a;return _(_(Fay$$cons)(sep))(_(_(Fay$$cons)(x))(_(_(prependToAll)(sep))(xs)));}throw ["unhandled case in Ident \"prependToAll\"",[$36$_a,$36$_b]];});};};var intercalate = function($36$_a){return function($36$_b){return new $(function(){var xss = $36$_b;var xs = $36$_a;return _(concat)(_(_(intersperse)(xs))(xss));});};};var forM_ = function($36$_a){return function($36$_b){return new $(function(){var m = $36$_b;var $36$_$36$_a = _($36$_a);if ($36$_$36$_a instanceof Fay$$Cons) {var x = $36$_$36$_a.car;var xs = $36$_$36$_a.cdr;return _(_($62$$62$)(_(m)(x)))(_(_(forM_)(xs))(m));}if (_($36$_a) === null) {return _($_return)(Fay$$unit);}throw ["unhandled case in Ident \"forM_\"",[$36$_a,$36$_b]];});};};var mapM_ = function($36$_a){return function($36$_b){return new $(function(){var $36$_$36$_b = _($36$_b);if ($36$_$36$_b instanceof Fay$$Cons) {var x = $36$_$36$_b.car;var xs = $36$_$36$_b.cdr;var m = $36$_a;return _(_($62$$62$)(_(m)(x)))(_(_(mapM_)(m))(xs));}if (_($36$_b) === null) {return _($_return)(Fay$$unit);}throw ["unhandled case in Ident \"mapM_\"",[$36$_a,$36$_b]];});};};var $_const = function($36$_a){return function($36$_b){return new $(function(){var a = $36$_a;return a;});};};var length = function($36$_a){return new $(function(){var $36$_$36$_a = _($36$_a);if ($36$_$36$_a instanceof Fay$$Cons) {var xs = $36$_$36$_a.cdr;return _(Fay$$add)(1)(_(_(length)(xs)));}if (_($36$_a) === null) {return 0;}throw ["unhandled case in Ident \"length\"",[$36$_a]];});};var mod = function($36$_a){return function($36$_b){return new $(function(){return Fay$$jsToFay(["double"],Fay$$fayToJs(["double"],$36$_a) % Fay$$fayToJs(["double"],$36$_b));});};};var min = function($36$_a){return function($36$_b){return new $(function(){return Fay$$jsToFay(["double"],Math.min(Fay$$fayToJs(["double"],$36$_a),Fay$$fayToJs(["double"],$36$_b)));});};};var max = function($36$_a){return function($36$_b){return new $(function(){return Fay$$jsToFay(["double"],Math.max(Fay$$fayToJs(["double"],$36$_a),Fay$$fayToJs(["double"],$36$_b)));});};};var fromIntegral = function($36$_a){return new $(function(){return Fay$$jsToFay(["double"],Fay$$fayToJs(["int"],$36$_a));});};var otherwise = true;var reverse = function($36$_a){return new $(function(){var $36$_$36$_a = _($36$_a);if ($36$_$36$_a instanceof Fay$$Cons) {var x = $36$_$36$_a.car;var xs = $36$_$36$_a.cdr;return _(_($43$$43$)(_(reverse)(xs)))(Fay$$list([x]));}if (_($36$_a) === null) {return null;}throw ["unhandled case in Ident \"reverse\"",[$36$_a]];});};var Fay$$fayToJsUserDefined = function(type,obj){var _obj = _(obj);var argTypes = type[2];if (_obj instanceof $36$_EQ) {return {"instance": "EQ"};}if (_obj instanceof $36$_LT) {return {"instance": "LT"};}if (_obj instanceof $36$_GT) {return {"instance": "GT"};}if (_obj instanceof $36$_Nothing) {return {"instance": "Nothing"};}if (_obj instanceof $36$_Just) {return {"instance": "Just","slot1": Fay$$fayToJs(["unknown"],_(_obj.slot1))};}return obj;};var Fay$$jsToFayUserDefined = function(type,obj){if (obj["instance"] === "EQ") {return new $36$_EQ();}if (obj["instance"] === "LT") {return new $36$_LT();}if (obj["instance"] === "GT") {return new $36$_GT();}if (obj["instance"] === "Nothing") {return new $36$_Nothing();}if (obj["instance"] === "Just") {return new $36$_Just(Fay$$jsToFay(["unknown"],obj["slot1"]));}return obj;};-// Exports-this.reverse = reverse;-this.otherwise = otherwise;-this.fromIntegral = fromIntegral;-this.max = max;-this.min = min;-this.mod = mod;-this.length = length;-this.$_const = $_const;-this.mapM_ = mapM_;-this.forM_ = forM_;-this.intercalate = intercalate;-this.prependToAll = prependToAll;-this.intersperse = intersperse;-this.lookup = lookup;-this.foldl = foldl;-this.foldr = foldr;-this.concat = concat;-this.conc = conc;-this.$36$ = $36$;-this.$43$$43$ = $43$$43$;-this.$46$ = $46$;-this.maybe = maybe;-this.flip = flip;-this.zip = zip;-this.zipWith = zipWith;-this.enumFromTo = enumFromTo;-this.enumFrom = enumFrom;-this.when = when;-this.insertBy = insertBy;-this.sortBy = sortBy;-this.compare = compare;-this.sort = sort;-this.elem = elem;-this.nub$39$ = nub$39$;-this.nub = nub;-this.map = map;-this.$_null = $_null;-this.not = not;-this.filter = filter;-this.any = any;-this.find = find;-this.fst = fst;-this.snd = snd;-this.fromRational = fromRational;-this.fromInteger = fromInteger;-this.show = show;-this.print = print;-this.main = main;--// Built-ins-this._ = _;-this.$           = $;-this.$fayToJs    = Fay$$fayToJs;-this.$jsToFay    = Fay$$jsToFay;--};-;-var main = new Bool();-main._(main.main);-

@@ -1,4 +1,4 @@-{-# LANGUAGE NoImplicitPrelude #-}+  module Double where 

@@ -1,532 +0,0 @@-/** @constructor-*/-var Double = 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.value = this.value(), this.forced = true, this.value));-};--/*******************************************************************************- * Monad.- */--function Fay$$Monad(value){-    this.value = value;-}--// >>-// encode_fay_to_js(">>=") → $62$$62$-// This is used directly from Fay, but can be rebound or shadowed.-function $62$$62$(a){-    return function(b){-        return new $(function(){-            _(a,true);-            return b;-        });-    };-}--// >>=-// encode_fay_to_js(">>=") → $62$$62$$61$-// This is used directly from Fay, but can be rebound or shadowed.-function $62$$62$$61$(m){-    return function(f){-        return new $(function(){-            var monad = _(m,true);-            return f(monad.value);-        });-    };-}--// This is used directly from Fay, but can be rebound or shadowed.-function $_return(a){-    return new Fay$$Monad(a);-}--var Fay$$unit = null;--/*******************************************************************************- * Serialization.- * Fay <-> JS. Should be bijective.- */--// Serialize a Fay object to JS.-function Fay$$fayToJs(type,fayObj){-    var base = type[0];-    var args = type[1];-    var jsObj;-    switch(base){-    case "action": {-        // A nullary monadic action. Should become a nullary JS function.-        // Fay () -> function(){ return ... }-        jsObj = function(){-            return Fay$$fayToJs(args[0],_(fayObj,true).value);-        };-        break;-    }-    case "function": {-        // A proper function.-        jsObj = function(){-            var fayFunc = fayObj;-            var return_type = args[args.length-1];-            var len = args.length;-            // If some arguments.-            if (len > 1) {-                // Apply to all the arguments.-                fayFunc = _(fayFunc,true);-                // TODO: Perhaps we should throw an error when JS-                // passes more arguments than Haskell accepts.-                for (var i = 0, len = len; i < len - 1 && fayFunc instanceof Function; i++) {-                    // Unserialize the JS values to Fay for the Fay callback.-                    fayFunc = _(fayFunc(Fay$$jsToFay(args[i],arguments[i])),true);-                }-                // Finally, serialize the Fay return value back to JS.-                var return_base = return_type[0];-                var return_args = return_type[1];-                // If it's a monadic return value, get the value instead.-                if(return_base == "action") {-                    return Fay$$fayToJs(return_args[0],fayFunc.value);-                }-                // Otherwise just serialize the value direct.-                else {-                    return Fay$$fayToJs(return_type,fayFunc);-                }-            } else {-                throw new Error("Nullary function?");-            }-        };-        break;-    }-    case "string": {-        // Serialize Fay string to JavaScript string.-        var str = "";-        fayObj = _(fayObj);-        while(fayObj instanceof Fay$$Cons) {-            str += fayObj.car;-            fayObj = _(fayObj.cdr);-        }-        jsObj = str;-        break;-    }-    case "list": {-        // Serialize Fay list to JavaScript array.-        var arr = [];-        fayObj = _(fayObj);-        while(fayObj instanceof Fay$$Cons) {-            arr.push(Fay$$fayToJs(args[0],fayObj.car));-            fayObj = _(fayObj.cdr);-        }-        jsObj = arr;-        break;-    }-    case "double": {-        // Serialize double, just force the argument. Doubles are unboxed.-        jsObj = _(fayObj);-        break;-    }-    case "int": {-        // Serialize int, just force the argument. Ints are unboxed.-        jsObj = _(fayObj);-        break;-    }-    case "bool": {-        // Bools are unboxed.-        jsObj = _(fayObj);-        break;-    }-    case "unknown":-    case "user": {-        if(fayObj instanceof $)-            fayObj = _(fayObj);-        jsObj = Fay$$fayToJsUserDefined(type,fayObj);-        break;-    }-    default: throw new Error("Unhandled Fay->JS translation type: " + base);-    }-    return jsObj;-}--// Unserialize an object from JS to Fay.-function Fay$$jsToFay(type,jsObj){-    var base = type[0];-    var args = type[1];-    var fayObj;-    switch(base){-    case "action": {-        // Unserialize a "monadic" JavaScript return value into a monadic value.-        fayObj = new Fay$$Monad(Fay$$jsToFay(args[0],jsObj));-        break;-    }-    case "string": {-        // Unserialize a JS string into Fay list (String).-        fayObj = Fay$$list(jsObj);-        break;-    }-    case "list": {-        // Unserialize a JS array into a Fay list ([a]).-        var serializedList = [];-        for (var i = 0, len = jsObj.length; i < len; i++) {-            // Unserialize each JS value into a Fay value, too.-            serializedList.push(Fay$$jsToFay(args[0],jsObj[i]));-        }-        // Pop it all in a Fay list.-        fayObj = Fay$$list(serializedList);-        break;-    }-    case "double": {-        // Doubles are unboxed, so there's nothing to do.-        fayObj = jsObj;-        break;-    }-    case "int": {-        // Int are unboxed, so there's no forcing to do.-        // But we can do validation that the int has no decimal places.-        // E.g. Math.round(x)!=x? throw "NOT AN INTEGER, GET OUT!"-        fayObj = Math.round(jsObj);-        if(fayObj!==jsObj) throw "Argument " + jsObj + " is not an integer!";-        break;-    }-    case "bool": {-        // Bools are unboxed.-        fayObj = jsObj;-        break;-    }-    case "unknown":-    case "user": {-        if (jsObj && jsObj['instance']) {-            fayObj = Fay$$jsToFayUserDefined(type,jsObj);-        }-        else-            fayObj = jsObj;-        break;-    }-    default: throw new Error("Unhandled JS->Fay translation type: " + base);-    }-    return fayObj;-}--/*******************************************************************************- * 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 new $(function(){-            return _(x) * _(y);-        });-    };-}-var $42$ = Fay$$mult;--// Built-in +.-function Fay$$add(x){-    return function(y){-        return new $(function(){-            return _(x) + _(y);-        });-    };-}-var $43$ = Fay$$add;--// Built-in -.-function Fay$$sub(x){-    return function(y){-        return new $(function(){-            return _(x) - _(y);-        });-    };-}-var $45$ = Fay$$sub;--// Built-in /.-function Fay$$div(x){-    return function(y){-        return new $(function(){-            return _(x) / _(y);-        });-    };-}-var $47$ = Fay$$div;--/*******************************************************************************- * 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 && lit2 instanceof Fay$$Cons) {-        do {-            if (!Fay$$equal(lit1.car,lit2.car))-                return false;-            lit1 = _(lit1.cdr), lit2 = _(lit2.cdr);-            if (lit1 === null || lit2 === null)-                return lit1 === lit2;-        } while (true);-    } else if (typeof lit1 == 'object' && typeof lit2 == 'object' && lit1 && lit2 &&-              lit1.constructor === lit2.constructor) {-      for(var x in lit1) {-        if(!(lit1.hasOwnProperty(x) && lit2.hasOwnProperty(x) &&-            Fay$$equal(lit1[x],lit2[x])))-          return false;-      }-      return true;-    } else {-      return false;-    }-}--// Built-in ==.-function Fay$$eq(x){-    return function(y){-        return new $(function(){-            return Fay$$equal(x,y);-        });-    };-}-var $61$$61$ = Fay$$eq;--// Built-in /=.-function Fay$$neq(x){-    return function(y){-        return new $(function(){-            return !(Fay$$equal(x,y));-        });-    };-}-var $47$$61$ = Fay$$neq;--// Built-in >.-function Fay$$gt(x){-    return function(y){-        return new $(function(){-            return _(x) > _(y);-        });-    };-}-var $62$ = Fay$$gt;--// Built-in <.-function Fay$$lt(x){-    return function(y){-        return new $(function(){-            return _(x) < _(y);-        });-    };-}-var $60$ = Fay$$lt;--// Built-in >=.-function Fay$$gte(x){-    return function(y){-        return new $(function(){-            return _(x) >= _(y);-        });-    };-}-var $62$$61$ = Fay$$gte;--// Built-in <=.-function Fay$$lte(x){-    return function(y){-        return new $(function(){-            return _(x) <= _(y);-        });-    };-}-var $60$$61$ = Fay$$lte;--// Built-in &&.-function Fay$$and(x){-    return function(y){-        return new $(function(){-            return _(x) && _(y);-        });-    };-}-var $38$$38$ = Fay$$and;--// Built-in ||.-function Fay$$or(x){-    return function(y){-        return new $(function(){-            return _(x) || _(y);-        });-    };-}-var $124$$124$ = Fay$$or;--/*******************************************************************************- * 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 _(print)(_(Fay$$div)(_(_(Fay$$mult)(2)(4)))(2));});var print = function($36$_a){return new $(function(){return Fay$$jsToFay(["action",[["unknown"]]],console.log(Fay$$fayToJs(["double"],$36$_a)));});};var $36$_Just = function(slot1){this.slot1 = slot1;};var Just = function(slot1){return new $(function(){return new $36$_Just(slot1);});};var $36$_Nothing = function(){};var Nothing = new $(function(){return new $36$_Nothing();});var show = function($36$_a){return new $(function(){return Fay$$jsToFay(["string"],JSON.stringify(Fay$$fayToJs(["unknown"],$36$_a)));});};var fromInteger = function($36$_a){return new $(function(){var x = $36$_a;return x;});};var fromRational = function($36$_a){return new $(function(){var x = $36$_a;return x;});};var snd = function($36$_a){return new $(function(){var x = Fay$$index(1)(_($36$_a));return x;throw ["unhandled case in Ident \"snd\"",[$36$_a]];});};var fst = function($36$_a){return new $(function(){var x = Fay$$index(0)(_($36$_a));return x;throw ["unhandled case in Ident \"fst\"",[$36$_a]];});};var find = function($36$_a){return function($36$_b){return new $(function(){var $36$_$36$_b = _($36$_b);if ($36$_$36$_b instanceof Fay$$Cons) {var x = $36$_$36$_b.car;var xs = $36$_$36$_b.cdr;var p = $36$_a;return _(_(p)(x)) ? _(Just)(x) : _(_(find)(p))(xs);}if (_($36$_b) === null) {return Nothing;}throw ["unhandled case in Ident \"find\"",[$36$_a,$36$_b]];});};};var any = function($36$_a){return function($36$_b){return new $(function(){var $36$_$36$_b = _($36$_b);if ($36$_$36$_b instanceof Fay$$Cons) {var x = $36$_$36$_b.car;var xs = $36$_$36$_b.cdr;var p = $36$_a;return _(_(p)(x)) ? true : _(_(any)(p))(xs);}if (_($36$_b) === null) {return false;}throw ["unhandled case in Ident \"any\"",[$36$_a,$36$_b]];});};};var filter = function($36$_a){return function($36$_b){return new $(function(){var $36$_$36$_b = _($36$_b);if ($36$_$36$_b instanceof Fay$$Cons) {var x = $36$_$36$_b.car;var xs = $36$_$36$_b.cdr;var p = $36$_a;return _(_(p)(x)) ? _(_(Fay$$cons)(x))(_(_(filter)(p))(xs)) : _(_(filter)(p))(xs);}if (_($36$_b) === null) {return null;}throw ["unhandled case in Ident \"filter\"",[$36$_a,$36$_b]];});};};var not = function($36$_a){return new $(function(){var p = $36$_a;return _(p) ? false : true;});};var $_null = function($36$_a){return new $(function(){if (_($36$_a) === null) {return true;}return false;});};var map = function($36$_a){return function($36$_b){return new $(function(){if (_($36$_b) === null) {return null;}var $36$_$36$_b = _($36$_b);if ($36$_$36$_b instanceof Fay$$Cons) {var x = $36$_$36$_b.car;var xs = $36$_$36$_b.cdr;var f = $36$_a;return _(_(Fay$$cons)(_(f)(x)))(_(_(map)(f))(xs));}throw ["unhandled case in Ident \"map\"",[$36$_a,$36$_b]];});};};var nub = function($36$_a){return new $(function(){var ls = $36$_a;return _(_(nub$39$)(ls))(null);});};var nub$39$ = function($36$_a){return function($36$_b){return new $(function(){if (_($36$_a) === null) {return null;}var ls = $36$_b;var $36$_$36$_a = _($36$_a);if ($36$_$36$_a instanceof Fay$$Cons) {var x = $36$_$36$_a.car;var xs = $36$_$36$_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'\"",[$36$_a,$36$_b]];});};};var elem = function($36$_a){return function($36$_b){return new $(function(){var $36$_$36$_b = _($36$_b);if ($36$_$36$_b instanceof Fay$$Cons) {var y = $36$_$36$_b.car;var ys = $36$_$36$_b.cdr;var x = $36$_a;return _(Fay$$or)(_(_(_(Fay$$eq)(x))(y)))(_(_(_(elem)(x))(ys)));}if (_($36$_b) === null) {return false;}throw ["unhandled case in Ident \"elem\"",[$36$_a,$36$_b]];});};};var $36$_GT = function(){};var GT = new $(function(){return new $36$_GT();});var $36$_LT = function(){};var LT = new $(function(){return new $36$_LT();});var $36$_EQ = function(){};var EQ = new $(function(){return new $36$_EQ();});var sort = new $(function(){return _(sortBy)(compare);});var compare = function($36$_a){return function($36$_b){return new $(function(){var y = $36$_b;var x = $36$_a;return _(_(Fay$$gt)(_(x))(_(y))) ? GT : _(_(Fay$$lt)(_(x))(_(y))) ? LT : EQ;});};};var sortBy = function($36$_a){return new $(function(){var cmp = $36$_a;return _(_(foldr)(_(insertBy)(cmp)))(null);});};var insertBy = function($36$_a){return function($36$_b){return function($36$_c){return new $(function(){if (_($36$_c) === null) {var x = $36$_b;return Fay$$list([x]);}var ys = $36$_c;var x = $36$_b;var cmp = $36$_a;return (function($36$_ys){if (_($36$_ys) === null) {return Fay$$list([x]);}var $36$_$36$_ys = _($36$_ys);if ($36$_$36$_ys instanceof Fay$$Cons) {var y = $36$_$36$_ys.car;var ys$39$ = $36$_$36$_ys.cdr;return (function($tmp){if (_($tmp) instanceof $36$_GT) {return _(_(Fay$$cons)(y))(_(_(_(insertBy)(cmp))(x))(ys$39$));}return _(_(Fay$$cons)(x))(ys);})(_(_(cmp)(x))(y));}return (function(){ throw (["unhandled case",$36$_ys]); })();})(ys);});};};};var when = function($36$_a){return function($36$_b){return new $(function(){var m = $36$_b;var p = $36$_a;return _(p) ? _(_($62$$62$)(m))(_($_return)(Fay$$unit)) : _($_return)(Fay$$unit);});};};var enumFrom = function($36$_a){return new $(function(){var i = $36$_a;return _(_(Fay$$cons)(i))(_(enumFrom)(_(Fay$$add)(_(i))(1)));});};var enumFromTo = function($36$_a){return function($36$_b){return new $(function(){var n = $36$_b;var i = $36$_a;return _(_(_(Fay$$eq)(i))(n)) ? Fay$$list([i]) : _(_(Fay$$cons)(i))(_(_(enumFromTo)(_(Fay$$add)(_(i))(1)))(n));});};};var zipWith = function($36$_a){return function($36$_b){return function($36$_c){return new $(function(){var $36$_$36$_c = _($36$_c);if ($36$_$36$_c instanceof Fay$$Cons) {var b = $36$_$36$_c.car;var bs = $36$_$36$_c.cdr;var $36$_$36$_b = _($36$_b);if ($36$_$36$_b instanceof Fay$$Cons) {var a = $36$_$36$_b.car;var as = $36$_$36$_b.cdr;var f = $36$_a;return _(_(Fay$$cons)(_(_(f)(a))(b)))(_(_(_(zipWith)(f))(as))(bs));}}return null;});};};};var zip = function($36$_a){return function($36$_b){return new $(function(){var $36$_$36$_b = _($36$_b);if ($36$_$36$_b instanceof Fay$$Cons) {var b = $36$_$36$_b.car;var bs = $36$_$36$_b.cdr;var $36$_$36$_a = _($36$_a);if ($36$_$36$_a instanceof Fay$$Cons) {var a = $36$_$36$_a.car;var as = $36$_$36$_a.cdr;return _(_(Fay$$cons)(Fay$$list([a,b])))(_(_(zip)(as))(bs));}}return null;});};};var flip = function($36$_a){return function($36$_b){return function($36$_c){return new $(function(){var y = $36$_c;var x = $36$_b;var f = $36$_a;return _(_(f)(y))(x);});};};};var maybe = function($36$_a){return function($36$_b){return function($36$_c){return new $(function(){if (_($36$_c) instanceof $36$_Nothing) {var m = $36$_a;return m;}if (_($36$_c) instanceof $36$_Just) {var x = _($36$_c).slot1;var f = $36$_b;return _(f)(x);}throw ["unhandled case in Ident \"maybe\"",[$36$_a,$36$_b,$36$_c]];});};};};var $46$ = function($36$_a){return function($36$_b){return function($36$_c){return new $(function(){var x = $36$_c;var g = $36$_b;var f = $36$_a;return _(f)(_(g)(x));});};};};var $43$$43$ = function($36$_a){return function($36$_b){return new $(function(){var y = $36$_b;var x = $36$_a;return _(_(conc)(x))(y);});};};var $36$ = function($36$_a){return function($36$_b){return new $(function(){var x = $36$_b;var f = $36$_a;return _(f)(x);});};};var conc = function($36$_a){return function($36$_b){return new $(function(){var ys = $36$_b;var $36$_$36$_a = _($36$_a);if ($36$_$36$_a instanceof Fay$$Cons) {var x = $36$_$36$_a.car;var xs = $36$_$36$_a.cdr;return _(_(Fay$$cons)(x))(_(_(conc)(xs))(ys));}var ys = $36$_b;if (_($36$_a) === null) {return ys;}throw ["unhandled case in Ident \"conc\"",[$36$_a,$36$_b]];});};};var concat = new $(function(){return _(_(foldr)(conc))(null);});var foldr = function($36$_a){return function($36$_b){return function($36$_c){return new $(function(){if (_($36$_c) === null) {var z = $36$_b;return z;}var $36$_$36$_c = _($36$_c);if ($36$_$36$_c instanceof Fay$$Cons) {var x = $36$_$36$_c.car;var xs = $36$_$36$_c.cdr;var z = $36$_b;var f = $36$_a;return _(_(f)(x))(_(_(_(foldr)(f))(z))(xs));}throw ["unhandled case in Ident \"foldr\"",[$36$_a,$36$_b,$36$_c]];});};};};var foldl = function($36$_a){return function($36$_b){return function($36$_c){return new $(function(){if (_($36$_c) === null) {var z = $36$_b;return z;}var $36$_$36$_c = _($36$_c);if ($36$_$36$_c instanceof Fay$$Cons) {var x = $36$_$36$_c.car;var xs = $36$_$36$_c.cdr;var z = $36$_b;var f = $36$_a;return _(_(_(foldl)(f))(_(_(f)(z))(x)))(xs);}throw ["unhandled case in Ident \"foldl\"",[$36$_a,$36$_b,$36$_c]];});};};};var lookup = function($36$_a){return function($36$_b){return new $(function(){if (_($36$_b) === null) {var _key = $36$_a;return Nothing;}var $36$_$36$_b = _($36$_b);if ($36$_$36$_b instanceof Fay$$Cons) {var x = Fay$$index(0)(_($36$_$36$_b.car));var y = Fay$$index(1)(_($36$_$36$_b.car));var xys = $36$_$36$_b.cdr;var key = $36$_a;return _(_(_(Fay$$eq)(key))(x)) ? _(Just)(y) : _(_(lookup)(key))(xys);}throw ["unhandled case in Ident \"lookup\"",[$36$_a,$36$_b]];});};};var intersperse = function($36$_a){return function($36$_b){return new $(function(){if (_($36$_b) === null) {return null;}var $36$_$36$_b = _($36$_b);if ($36$_$36$_b instanceof Fay$$Cons) {var x = $36$_$36$_b.car;var xs = $36$_$36$_b.cdr;var sep = $36$_a;return _(_(Fay$$cons)(x))(_(_(prependToAll)(sep))(xs));}throw ["unhandled case in Ident \"intersperse\"",[$36$_a,$36$_b]];});};};var prependToAll = function($36$_a){return function($36$_b){return new $(function(){if (_($36$_b) === null) {return null;}var $36$_$36$_b = _($36$_b);if ($36$_$36$_b instanceof Fay$$Cons) {var x = $36$_$36$_b.car;var xs = $36$_$36$_b.cdr;var sep = $36$_a;return _(_(Fay$$cons)(sep))(_(_(Fay$$cons)(x))(_(_(prependToAll)(sep))(xs)));}throw ["unhandled case in Ident \"prependToAll\"",[$36$_a,$36$_b]];});};};var intercalate = function($36$_a){return function($36$_b){return new $(function(){var xss = $36$_b;var xs = $36$_a;return _(concat)(_(_(intersperse)(xs))(xss));});};};var forM_ = function($36$_a){return function($36$_b){return new $(function(){var m = $36$_b;var $36$_$36$_a = _($36$_a);if ($36$_$36$_a instanceof Fay$$Cons) {var x = $36$_$36$_a.car;var xs = $36$_$36$_a.cdr;return _(_($62$$62$)(_(m)(x)))(_(_(forM_)(xs))(m));}if (_($36$_a) === null) {return _($_return)(Fay$$unit);}throw ["unhandled case in Ident \"forM_\"",[$36$_a,$36$_b]];});};};var mapM_ = function($36$_a){return function($36$_b){return new $(function(){var $36$_$36$_b = _($36$_b);if ($36$_$36$_b instanceof Fay$$Cons) {var x = $36$_$36$_b.car;var xs = $36$_$36$_b.cdr;var m = $36$_a;return _(_($62$$62$)(_(m)(x)))(_(_(mapM_)(m))(xs));}if (_($36$_b) === null) {return _($_return)(Fay$$unit);}throw ["unhandled case in Ident \"mapM_\"",[$36$_a,$36$_b]];});};};var $_const = function($36$_a){return function($36$_b){return new $(function(){var a = $36$_a;return a;});};};var length = function($36$_a){return new $(function(){var $36$_$36$_a = _($36$_a);if ($36$_$36$_a instanceof Fay$$Cons) {var xs = $36$_$36$_a.cdr;return _(Fay$$add)(1)(_(_(length)(xs)));}if (_($36$_a) === null) {return 0;}throw ["unhandled case in Ident \"length\"",[$36$_a]];});};var mod = function($36$_a){return function($36$_b){return new $(function(){return Fay$$jsToFay(["double"],Fay$$fayToJs(["double"],$36$_a) % Fay$$fayToJs(["double"],$36$_b));});};};var min = function($36$_a){return function($36$_b){return new $(function(){return Fay$$jsToFay(["double"],Math.min(Fay$$fayToJs(["double"],$36$_a),Fay$$fayToJs(["double"],$36$_b)));});};};var max = function($36$_a){return function($36$_b){return new $(function(){return Fay$$jsToFay(["double"],Math.max(Fay$$fayToJs(["double"],$36$_a),Fay$$fayToJs(["double"],$36$_b)));});};};var fromIntegral = function($36$_a){return new $(function(){return Fay$$jsToFay(["double"],Fay$$fayToJs(["int"],$36$_a));});};var otherwise = true;var reverse = function($36$_a){return new $(function(){var $36$_$36$_a = _($36$_a);if ($36$_$36$_a instanceof Fay$$Cons) {var x = $36$_$36$_a.car;var xs = $36$_$36$_a.cdr;return _(_($43$$43$)(_(reverse)(xs)))(Fay$$list([x]));}if (_($36$_a) === null) {return null;}throw ["unhandled case in Ident \"reverse\"",[$36$_a]];});};var Fay$$fayToJsUserDefined = function(type,obj){var _obj = _(obj);var argTypes = type[2];if (_obj instanceof $36$_EQ) {return {"instance": "EQ"};}if (_obj instanceof $36$_LT) {return {"instance": "LT"};}if (_obj instanceof $36$_GT) {return {"instance": "GT"};}if (_obj instanceof $36$_Nothing) {return {"instance": "Nothing"};}if (_obj instanceof $36$_Just) {return {"instance": "Just","slot1": Fay$$fayToJs(["unknown"],_(_obj.slot1))};}return obj;};var Fay$$jsToFayUserDefined = function(type,obj){if (obj["instance"] === "EQ") {return new $36$_EQ();}if (obj["instance"] === "LT") {return new $36$_LT();}if (obj["instance"] === "GT") {return new $36$_GT();}if (obj["instance"] === "Nothing") {return new $36$_Nothing();}if (obj["instance"] === "Just") {return new $36$_Just(Fay$$jsToFay(["unknown"],obj["slot1"]));}return obj;};-// Exports-this.reverse = reverse;-this.otherwise = otherwise;-this.fromIntegral = fromIntegral;-this.max = max;-this.min = min;-this.mod = mod;-this.length = length;-this.$_const = $_const;-this.mapM_ = mapM_;-this.forM_ = forM_;-this.intercalate = intercalate;-this.prependToAll = prependToAll;-this.intersperse = intersperse;-this.lookup = lookup;-this.foldl = foldl;-this.foldr = foldr;-this.concat = concat;-this.conc = conc;-this.$36$ = $36$;-this.$43$$43$ = $43$$43$;-this.$46$ = $46$;-this.maybe = maybe;-this.flip = flip;-this.zip = zip;-this.zipWith = zipWith;-this.enumFromTo = enumFromTo;-this.enumFrom = enumFrom;-this.when = when;-this.insertBy = insertBy;-this.sortBy = sortBy;-this.compare = compare;-this.sort = sort;-this.elem = elem;-this.nub$39$ = nub$39$;-this.nub = nub;-this.map = map;-this.$_null = $_null;-this.not = not;-this.filter = filter;-this.any = any;-this.find = find;-this.fst = fst;-this.snd = snd;-this.fromRational = fromRational;-this.fromInteger = fromInteger;-this.show = show;-this.print = print;-this.main = main;--// Built-ins-this._ = _;-this.$           = $;-this.$fayToJs    = Fay$$fayToJs;-this.$jsToFay    = Fay$$jsToFay;--};-;-var main = new Double();-main._(main.main);-

@@ -1,4 +1,4 @@-{-# LANGUAGE NoImplicitPrelude #-}+  module Double2 where 

@@ -1,532 +0,0 @@-/** @constructor-*/-var Double2 = 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.value = this.value(), this.forced = true, this.value));-};--/*******************************************************************************- * Monad.- */--function Fay$$Monad(value){-    this.value = value;-}--// >>-// encode_fay_to_js(">>=") → $62$$62$-// This is used directly from Fay, but can be rebound or shadowed.-function $62$$62$(a){-    return function(b){-        return new $(function(){-            _(a,true);-            return b;-        });-    };-}--// >>=-// encode_fay_to_js(">>=") → $62$$62$$61$-// This is used directly from Fay, but can be rebound or shadowed.-function $62$$62$$61$(m){-    return function(f){-        return new $(function(){-            var monad = _(m,true);-            return f(monad.value);-        });-    };-}--// This is used directly from Fay, but can be rebound or shadowed.-function $_return(a){-    return new Fay$$Monad(a);-}--var Fay$$unit = null;--/*******************************************************************************- * Serialization.- * Fay <-> JS. Should be bijective.- */--// Serialize a Fay object to JS.-function Fay$$fayToJs(type,fayObj){-    var base = type[0];-    var args = type[1];-    var jsObj;-    switch(base){-    case "action": {-        // A nullary monadic action. Should become a nullary JS function.-        // Fay () -> function(){ return ... }-        jsObj = function(){-            return Fay$$fayToJs(args[0],_(fayObj,true).value);-        };-        break;-    }-    case "function": {-        // A proper function.-        jsObj = function(){-            var fayFunc = fayObj;-            var return_type = args[args.length-1];-            var len = args.length;-            // If some arguments.-            if (len > 1) {-                // Apply to all the arguments.-                fayFunc = _(fayFunc,true);-                // TODO: Perhaps we should throw an error when JS-                // passes more arguments than Haskell accepts.-                for (var i = 0, len = len; i < len - 1 && fayFunc instanceof Function; i++) {-                    // Unserialize the JS values to Fay for the Fay callback.-                    fayFunc = _(fayFunc(Fay$$jsToFay(args[i],arguments[i])),true);-                }-                // Finally, serialize the Fay return value back to JS.-                var return_base = return_type[0];-                var return_args = return_type[1];-                // If it's a monadic return value, get the value instead.-                if(return_base == "action") {-                    return Fay$$fayToJs(return_args[0],fayFunc.value);-                }-                // Otherwise just serialize the value direct.-                else {-                    return Fay$$fayToJs(return_type,fayFunc);-                }-            } else {-                throw new Error("Nullary function?");-            }-        };-        break;-    }-    case "string": {-        // Serialize Fay string to JavaScript string.-        var str = "";-        fayObj = _(fayObj);-        while(fayObj instanceof Fay$$Cons) {-            str += fayObj.car;-            fayObj = _(fayObj.cdr);-        }-        jsObj = str;-        break;-    }-    case "list": {-        // Serialize Fay list to JavaScript array.-        var arr = [];-        fayObj = _(fayObj);-        while(fayObj instanceof Fay$$Cons) {-            arr.push(Fay$$fayToJs(args[0],fayObj.car));-            fayObj = _(fayObj.cdr);-        }-        jsObj = arr;-        break;-    }-    case "double": {-        // Serialize double, just force the argument. Doubles are unboxed.-        jsObj = _(fayObj);-        break;-    }-    case "int": {-        // Serialize int, just force the argument. Ints are unboxed.-        jsObj = _(fayObj);-        break;-    }-    case "bool": {-        // Bools are unboxed.-        jsObj = _(fayObj);-        break;-    }-    case "unknown":-    case "user": {-        if(fayObj instanceof $)-            fayObj = _(fayObj);-        jsObj = Fay$$fayToJsUserDefined(type,fayObj);-        break;-    }-    default: throw new Error("Unhandled Fay->JS translation type: " + base);-    }-    return jsObj;-}--// Unserialize an object from JS to Fay.-function Fay$$jsToFay(type,jsObj){-    var base = type[0];-    var args = type[1];-    var fayObj;-    switch(base){-    case "action": {-        // Unserialize a "monadic" JavaScript return value into a monadic value.-        fayObj = new Fay$$Monad(Fay$$jsToFay(args[0],jsObj));-        break;-    }-    case "string": {-        // Unserialize a JS string into Fay list (String).-        fayObj = Fay$$list(jsObj);-        break;-    }-    case "list": {-        // Unserialize a JS array into a Fay list ([a]).-        var serializedList = [];-        for (var i = 0, len = jsObj.length; i < len; i++) {-            // Unserialize each JS value into a Fay value, too.-            serializedList.push(Fay$$jsToFay(args[0],jsObj[i]));-        }-        // Pop it all in a Fay list.-        fayObj = Fay$$list(serializedList);-        break;-    }-    case "double": {-        // Doubles are unboxed, so there's nothing to do.-        fayObj = jsObj;-        break;-    }-    case "int": {-        // Int are unboxed, so there's no forcing to do.-        // But we can do validation that the int has no decimal places.-        // E.g. Math.round(x)!=x? throw "NOT AN INTEGER, GET OUT!"-        fayObj = Math.round(jsObj);-        if(fayObj!==jsObj) throw "Argument " + jsObj + " is not an integer!";-        break;-    }-    case "bool": {-        // Bools are unboxed.-        fayObj = jsObj;-        break;-    }-    case "unknown":-    case "user": {-        if (jsObj && jsObj['instance']) {-            fayObj = Fay$$jsToFayUserDefined(type,jsObj);-        }-        else-            fayObj = jsObj;-        break;-    }-    default: throw new Error("Unhandled JS->Fay translation type: " + base);-    }-    return fayObj;-}--/*******************************************************************************- * 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 new $(function(){-            return _(x) * _(y);-        });-    };-}-var $42$ = Fay$$mult;--// Built-in +.-function Fay$$add(x){-    return function(y){-        return new $(function(){-            return _(x) + _(y);-        });-    };-}-var $43$ = Fay$$add;--// Built-in -.-function Fay$$sub(x){-    return function(y){-        return new $(function(){-            return _(x) - _(y);-        });-    };-}-var $45$ = Fay$$sub;--// Built-in /.-function Fay$$div(x){-    return function(y){-        return new $(function(){-            return _(x) / _(y);-        });-    };-}-var $47$ = Fay$$div;--/*******************************************************************************- * 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 && lit2 instanceof Fay$$Cons) {-        do {-            if (!Fay$$equal(lit1.car,lit2.car))-                return false;-            lit1 = _(lit1.cdr), lit2 = _(lit2.cdr);-            if (lit1 === null || lit2 === null)-                return lit1 === lit2;-        } while (true);-    } else if (typeof lit1 == 'object' && typeof lit2 == 'object' && lit1 && lit2 &&-              lit1.constructor === lit2.constructor) {-      for(var x in lit1) {-        if(!(lit1.hasOwnProperty(x) && lit2.hasOwnProperty(x) &&-            Fay$$equal(lit1[x],lit2[x])))-          return false;-      }-      return true;-    } else {-      return false;-    }-}--// Built-in ==.-function Fay$$eq(x){-    return function(y){-        return new $(function(){-            return Fay$$equal(x,y);-        });-    };-}-var $61$$61$ = Fay$$eq;--// Built-in /=.-function Fay$$neq(x){-    return function(y){-        return new $(function(){-            return !(Fay$$equal(x,y));-        });-    };-}-var $47$$61$ = Fay$$neq;--// Built-in >.-function Fay$$gt(x){-    return function(y){-        return new $(function(){-            return _(x) > _(y);-        });-    };-}-var $62$ = Fay$$gt;--// Built-in <.-function Fay$$lt(x){-    return function(y){-        return new $(function(){-            return _(x) < _(y);-        });-    };-}-var $60$ = Fay$$lt;--// Built-in >=.-function Fay$$gte(x){-    return function(y){-        return new $(function(){-            return _(x) >= _(y);-        });-    };-}-var $62$$61$ = Fay$$gte;--// Built-in <=.-function Fay$$lte(x){-    return function(y){-        return new $(function(){-            return _(x) <= _(y);-        });-    };-}-var $60$$61$ = Fay$$lte;--// Built-in &&.-function Fay$$and(x){-    return function(y){-        return new $(function(){-            return _(x) && _(y);-        });-    };-}-var $38$$38$ = Fay$$and;--// Built-in ||.-function Fay$$or(x){-    return function(y){-        return new $(function(){-            return _(x) || _(y);-        });-    };-}-var $124$$124$ = Fay$$or;--/*******************************************************************************- * 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 _(print)(_(Fay$$add)(10)(_(_(Fay$$mult)(2)(_(_(Fay$$div)(4)(2))))));});var print = function($36$_a){return new $(function(){return Fay$$jsToFay(["action",[["unknown"]]],console.log(Fay$$fayToJs(["double"],$36$_a)));});};var $36$_Just = function(slot1){this.slot1 = slot1;};var Just = function(slot1){return new $(function(){return new $36$_Just(slot1);});};var $36$_Nothing = function(){};var Nothing = new $(function(){return new $36$_Nothing();});var show = function($36$_a){return new $(function(){return Fay$$jsToFay(["string"],JSON.stringify(Fay$$fayToJs(["unknown"],$36$_a)));});};var fromInteger = function($36$_a){return new $(function(){var x = $36$_a;return x;});};var fromRational = function($36$_a){return new $(function(){var x = $36$_a;return x;});};var snd = function($36$_a){return new $(function(){var x = Fay$$index(1)(_($36$_a));return x;throw ["unhandled case in Ident \"snd\"",[$36$_a]];});};var fst = function($36$_a){return new $(function(){var x = Fay$$index(0)(_($36$_a));return x;throw ["unhandled case in Ident \"fst\"",[$36$_a]];});};var find = function($36$_a){return function($36$_b){return new $(function(){var $36$_$36$_b = _($36$_b);if ($36$_$36$_b instanceof Fay$$Cons) {var x = $36$_$36$_b.car;var xs = $36$_$36$_b.cdr;var p = $36$_a;return _(_(p)(x)) ? _(Just)(x) : _(_(find)(p))(xs);}if (_($36$_b) === null) {return Nothing;}throw ["unhandled case in Ident \"find\"",[$36$_a,$36$_b]];});};};var any = function($36$_a){return function($36$_b){return new $(function(){var $36$_$36$_b = _($36$_b);if ($36$_$36$_b instanceof Fay$$Cons) {var x = $36$_$36$_b.car;var xs = $36$_$36$_b.cdr;var p = $36$_a;return _(_(p)(x)) ? true : _(_(any)(p))(xs);}if (_($36$_b) === null) {return false;}throw ["unhandled case in Ident \"any\"",[$36$_a,$36$_b]];});};};var filter = function($36$_a){return function($36$_b){return new $(function(){var $36$_$36$_b = _($36$_b);if ($36$_$36$_b instanceof Fay$$Cons) {var x = $36$_$36$_b.car;var xs = $36$_$36$_b.cdr;var p = $36$_a;return _(_(p)(x)) ? _(_(Fay$$cons)(x))(_(_(filter)(p))(xs)) : _(_(filter)(p))(xs);}if (_($36$_b) === null) {return null;}throw ["unhandled case in Ident \"filter\"",[$36$_a,$36$_b]];});};};var not = function($36$_a){return new $(function(){var p = $36$_a;return _(p) ? false : true;});};var $_null = function($36$_a){return new $(function(){if (_($36$_a) === null) {return true;}return false;});};var map = function($36$_a){return function($36$_b){return new $(function(){if (_($36$_b) === null) {return null;}var $36$_$36$_b = _($36$_b);if ($36$_$36$_b instanceof Fay$$Cons) {var x = $36$_$36$_b.car;var xs = $36$_$36$_b.cdr;var f = $36$_a;return _(_(Fay$$cons)(_(f)(x)))(_(_(map)(f))(xs));}throw ["unhandled case in Ident \"map\"",[$36$_a,$36$_b]];});};};var nub = function($36$_a){return new $(function(){var ls = $36$_a;return _(_(nub$39$)(ls))(null);});};var nub$39$ = function($36$_a){return function($36$_b){return new $(function(){if (_($36$_a) === null) {return null;}var ls = $36$_b;var $36$_$36$_a = _($36$_a);if ($36$_$36$_a instanceof Fay$$Cons) {var x = $36$_$36$_a.car;var xs = $36$_$36$_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'\"",[$36$_a,$36$_b]];});};};var elem = function($36$_a){return function($36$_b){return new $(function(){var $36$_$36$_b = _($36$_b);if ($36$_$36$_b instanceof Fay$$Cons) {var y = $36$_$36$_b.car;var ys = $36$_$36$_b.cdr;var x = $36$_a;return _(Fay$$or)(_(_(_(Fay$$eq)(x))(y)))(_(_(_(elem)(x))(ys)));}if (_($36$_b) === null) {return false;}throw ["unhandled case in Ident \"elem\"",[$36$_a,$36$_b]];});};};var $36$_GT = function(){};var GT = new $(function(){return new $36$_GT();});var $36$_LT = function(){};var LT = new $(function(){return new $36$_LT();});var $36$_EQ = function(){};var EQ = new $(function(){return new $36$_EQ();});var sort = new $(function(){return _(sortBy)(compare);});var compare = function($36$_a){return function($36$_b){return new $(function(){var y = $36$_b;var x = $36$_a;return _(_(Fay$$gt)(_(x))(_(y))) ? GT : _(_(Fay$$lt)(_(x))(_(y))) ? LT : EQ;});};};var sortBy = function($36$_a){return new $(function(){var cmp = $36$_a;return _(_(foldr)(_(insertBy)(cmp)))(null);});};var insertBy = function($36$_a){return function($36$_b){return function($36$_c){return new $(function(){if (_($36$_c) === null) {var x = $36$_b;return Fay$$list([x]);}var ys = $36$_c;var x = $36$_b;var cmp = $36$_a;return (function($36$_ys){if (_($36$_ys) === null) {return Fay$$list([x]);}var $36$_$36$_ys = _($36$_ys);if ($36$_$36$_ys instanceof Fay$$Cons) {var y = $36$_$36$_ys.car;var ys$39$ = $36$_$36$_ys.cdr;return (function($tmp){if (_($tmp) instanceof $36$_GT) {return _(_(Fay$$cons)(y))(_(_(_(insertBy)(cmp))(x))(ys$39$));}return _(_(Fay$$cons)(x))(ys);})(_(_(cmp)(x))(y));}return (function(){ throw (["unhandled case",$36$_ys]); })();})(ys);});};};};var when = function($36$_a){return function($36$_b){return new $(function(){var m = $36$_b;var p = $36$_a;return _(p) ? _(_($62$$62$)(m))(_($_return)(Fay$$unit)) : _($_return)(Fay$$unit);});};};var enumFrom = function($36$_a){return new $(function(){var i = $36$_a;return _(_(Fay$$cons)(i))(_(enumFrom)(_(Fay$$add)(_(i))(1)));});};var enumFromTo = function($36$_a){return function($36$_b){return new $(function(){var n = $36$_b;var i = $36$_a;return _(_(_(Fay$$eq)(i))(n)) ? Fay$$list([i]) : _(_(Fay$$cons)(i))(_(_(enumFromTo)(_(Fay$$add)(_(i))(1)))(n));});};};var zipWith = function($36$_a){return function($36$_b){return function($36$_c){return new $(function(){var $36$_$36$_c = _($36$_c);if ($36$_$36$_c instanceof Fay$$Cons) {var b = $36$_$36$_c.car;var bs = $36$_$36$_c.cdr;var $36$_$36$_b = _($36$_b);if ($36$_$36$_b instanceof Fay$$Cons) {var a = $36$_$36$_b.car;var as = $36$_$36$_b.cdr;var f = $36$_a;return _(_(Fay$$cons)(_(_(f)(a))(b)))(_(_(_(zipWith)(f))(as))(bs));}}return null;});};};};var zip = function($36$_a){return function($36$_b){return new $(function(){var $36$_$36$_b = _($36$_b);if ($36$_$36$_b instanceof Fay$$Cons) {var b = $36$_$36$_b.car;var bs = $36$_$36$_b.cdr;var $36$_$36$_a = _($36$_a);if ($36$_$36$_a instanceof Fay$$Cons) {var a = $36$_$36$_a.car;var as = $36$_$36$_a.cdr;return _(_(Fay$$cons)(Fay$$list([a,b])))(_(_(zip)(as))(bs));}}return null;});};};var flip = function($36$_a){return function($36$_b){return function($36$_c){return new $(function(){var y = $36$_c;var x = $36$_b;var f = $36$_a;return _(_(f)(y))(x);});};};};var maybe = function($36$_a){return function($36$_b){return function($36$_c){return new $(function(){if (_($36$_c) instanceof $36$_Nothing) {var m = $36$_a;return m;}if (_($36$_c) instanceof $36$_Just) {var x = _($36$_c).slot1;var f = $36$_b;return _(f)(x);}throw ["unhandled case in Ident \"maybe\"",[$36$_a,$36$_b,$36$_c]];});};};};var $46$ = function($36$_a){return function($36$_b){return function($36$_c){return new $(function(){var x = $36$_c;var g = $36$_b;var f = $36$_a;return _(f)(_(g)(x));});};};};var $43$$43$ = function($36$_a){return function($36$_b){return new $(function(){var y = $36$_b;var x = $36$_a;return _(_(conc)(x))(y);});};};var $36$ = function($36$_a){return function($36$_b){return new $(function(){var x = $36$_b;var f = $36$_a;return _(f)(x);});};};var conc = function($36$_a){return function($36$_b){return new $(function(){var ys = $36$_b;var $36$_$36$_a = _($36$_a);if ($36$_$36$_a instanceof Fay$$Cons) {var x = $36$_$36$_a.car;var xs = $36$_$36$_a.cdr;return _(_(Fay$$cons)(x))(_(_(conc)(xs))(ys));}var ys = $36$_b;if (_($36$_a) === null) {return ys;}throw ["unhandled case in Ident \"conc\"",[$36$_a,$36$_b]];});};};var concat = new $(function(){return _(_(foldr)(conc))(null);});var foldr = function($36$_a){return function($36$_b){return function($36$_c){return new $(function(){if (_($36$_c) === null) {var z = $36$_b;return z;}var $36$_$36$_c = _($36$_c);if ($36$_$36$_c instanceof Fay$$Cons) {var x = $36$_$36$_c.car;var xs = $36$_$36$_c.cdr;var z = $36$_b;var f = $36$_a;return _(_(f)(x))(_(_(_(foldr)(f))(z))(xs));}throw ["unhandled case in Ident \"foldr\"",[$36$_a,$36$_b,$36$_c]];});};};};var foldl = function($36$_a){return function($36$_b){return function($36$_c){return new $(function(){if (_($36$_c) === null) {var z = $36$_b;return z;}var $36$_$36$_c = _($36$_c);if ($36$_$36$_c instanceof Fay$$Cons) {var x = $36$_$36$_c.car;var xs = $36$_$36$_c.cdr;var z = $36$_b;var f = $36$_a;return _(_(_(foldl)(f))(_(_(f)(z))(x)))(xs);}throw ["unhandled case in Ident \"foldl\"",[$36$_a,$36$_b,$36$_c]];});};};};var lookup = function($36$_a){return function($36$_b){return new $(function(){if (_($36$_b) === null) {var _key = $36$_a;return Nothing;}var $36$_$36$_b = _($36$_b);if ($36$_$36$_b instanceof Fay$$Cons) {var x = Fay$$index(0)(_($36$_$36$_b.car));var y = Fay$$index(1)(_($36$_$36$_b.car));var xys = $36$_$36$_b.cdr;var key = $36$_a;return _(_(_(Fay$$eq)(key))(x)) ? _(Just)(y) : _(_(lookup)(key))(xys);}throw ["unhandled case in Ident \"lookup\"",[$36$_a,$36$_b]];});};};var intersperse = function($36$_a){return function($36$_b){return new $(function(){if (_($36$_b) === null) {return null;}var $36$_$36$_b = _($36$_b);if ($36$_$36$_b instanceof Fay$$Cons) {var x = $36$_$36$_b.car;var xs = $36$_$36$_b.cdr;var sep = $36$_a;return _(_(Fay$$cons)(x))(_(_(prependToAll)(sep))(xs));}throw ["unhandled case in Ident \"intersperse\"",[$36$_a,$36$_b]];});};};var prependToAll = function($36$_a){return function($36$_b){return new $(function(){if (_($36$_b) === null) {return null;}var $36$_$36$_b = _($36$_b);if ($36$_$36$_b instanceof Fay$$Cons) {var x = $36$_$36$_b.car;var xs = $36$_$36$_b.cdr;var sep = $36$_a;return _(_(Fay$$cons)(sep))(_(_(Fay$$cons)(x))(_(_(prependToAll)(sep))(xs)));}throw ["unhandled case in Ident \"prependToAll\"",[$36$_a,$36$_b]];});};};var intercalate = function($36$_a){return function($36$_b){return new $(function(){var xss = $36$_b;var xs = $36$_a;return _(concat)(_(_(intersperse)(xs))(xss));});};};var forM_ = function($36$_a){return function($36$_b){return new $(function(){var m = $36$_b;var $36$_$36$_a = _($36$_a);if ($36$_$36$_a instanceof Fay$$Cons) {var x = $36$_$36$_a.car;var xs = $36$_$36$_a.cdr;return _(_($62$$62$)(_(m)(x)))(_(_(forM_)(xs))(m));}if (_($36$_a) === null) {return _($_return)(Fay$$unit);}throw ["unhandled case in Ident \"forM_\"",[$36$_a,$36$_b]];});};};var mapM_ = function($36$_a){return function($36$_b){return new $(function(){var $36$_$36$_b = _($36$_b);if ($36$_$36$_b instanceof Fay$$Cons) {var x = $36$_$36$_b.car;var xs = $36$_$36$_b.cdr;var m = $36$_a;return _(_($62$$62$)(_(m)(x)))(_(_(mapM_)(m))(xs));}if (_($36$_b) === null) {return _($_return)(Fay$$unit);}throw ["unhandled case in Ident \"mapM_\"",[$36$_a,$36$_b]];});};};var $_const = function($36$_a){return function($36$_b){return new $(function(){var a = $36$_a;return a;});};};var length = function($36$_a){return new $(function(){var $36$_$36$_a = _($36$_a);if ($36$_$36$_a instanceof Fay$$Cons) {var xs = $36$_$36$_a.cdr;return _(Fay$$add)(1)(_(_(length)(xs)));}if (_($36$_a) === null) {return 0;}throw ["unhandled case in Ident \"length\"",[$36$_a]];});};var mod = function($36$_a){return function($36$_b){return new $(function(){return Fay$$jsToFay(["double"],Fay$$fayToJs(["double"],$36$_a) % Fay$$fayToJs(["double"],$36$_b));});};};var min = function($36$_a){return function($36$_b){return new $(function(){return Fay$$jsToFay(["double"],Math.min(Fay$$fayToJs(["double"],$36$_a),Fay$$fayToJs(["double"],$36$_b)));});};};var max = function($36$_a){return function($36$_b){return new $(function(){return Fay$$jsToFay(["double"],Math.max(Fay$$fayToJs(["double"],$36$_a),Fay$$fayToJs(["double"],$36$_b)));});};};var fromIntegral = function($36$_a){return new $(function(){return Fay$$jsToFay(["double"],Fay$$fayToJs(["int"],$36$_a));});};var otherwise = true;var reverse = function($36$_a){return new $(function(){var $36$_$36$_a = _($36$_a);if ($36$_$36$_a instanceof Fay$$Cons) {var x = $36$_$36$_a.car;var xs = $36$_$36$_a.cdr;return _(_($43$$43$)(_(reverse)(xs)))(Fay$$list([x]));}if (_($36$_a) === null) {return null;}throw ["unhandled case in Ident \"reverse\"",[$36$_a]];});};var Fay$$fayToJsUserDefined = function(type,obj){var _obj = _(obj);var argTypes = type[2];if (_obj instanceof $36$_EQ) {return {"instance": "EQ"};}if (_obj instanceof $36$_LT) {return {"instance": "LT"};}if (_obj instanceof $36$_GT) {return {"instance": "GT"};}if (_obj instanceof $36$_Nothing) {return {"instance": "Nothing"};}if (_obj instanceof $36$_Just) {return {"instance": "Just","slot1": Fay$$fayToJs(["unknown"],_(_obj.slot1))};}return obj;};var Fay$$jsToFayUserDefined = function(type,obj){if (obj["instance"] === "EQ") {return new $36$_EQ();}if (obj["instance"] === "LT") {return new $36$_LT();}if (obj["instance"] === "GT") {return new $36$_GT();}if (obj["instance"] === "Nothing") {return new $36$_Nothing();}if (obj["instance"] === "Just") {return new $36$_Just(Fay$$jsToFay(["unknown"],obj["slot1"]));}return obj;};-// Exports-this.reverse = reverse;-this.otherwise = otherwise;-this.fromIntegral = fromIntegral;-this.max = max;-this.min = min;-this.mod = mod;-this.length = length;-this.$_const = $_const;-this.mapM_ = mapM_;-this.forM_ = forM_;-this.intercalate = intercalate;-this.prependToAll = prependToAll;-this.intersperse = intersperse;-this.lookup = lookup;-this.foldl = foldl;-this.foldr = foldr;-this.concat = concat;-this.conc = conc;-this.$36$ = $36$;-this.$43$$43$ = $43$$43$;-this.$46$ = $46$;-this.maybe = maybe;-this.flip = flip;-this.zip = zip;-this.zipWith = zipWith;-this.enumFromTo = enumFromTo;-this.enumFrom = enumFrom;-this.when = when;-this.insertBy = insertBy;-this.sortBy = sortBy;-this.compare = compare;-this.sort = sort;-this.elem = elem;-this.nub$39$ = nub$39$;-this.nub = nub;-this.map = map;-this.$_null = $_null;-this.not = not;-this.filter = filter;-this.any = any;-this.find = find;-this.fst = fst;-this.snd = snd;-this.fromRational = fromRational;-this.fromInteger = fromInteger;-this.show = show;-this.print = print;-this.main = main;--// Built-ins-this._ = _;-this.$           = $;-this.$fayToJs    = Fay$$fayToJs;-this.$jsToFay    = Fay$$jsToFay;--};-;-var main = new Double2();-main._(main.main);-