fay 0.23.2.0 → 0.24.2.0
raw patch · 49 files changed
Files
- CHANGELOG.md +39/−0
- Setup.hs +2/−16
- examples/calc.hs +3/−3
- fay.cabal +28/−15
- js/runtime.js +0/−821
- src/Fay.hs +18/−15
- src/Fay/Compiler.hs +9/−6
- src/Fay/Compiler/Decl.hs +8/−1
- src/Fay/Compiler/Desugar.hs +1/−0
- src/Fay/Compiler/Exp.hs +16/−5
- src/Fay/Compiler/FFI.hs +3/−2
- src/Fay/Compiler/GADT.hs +2/−4
- src/Fay/Compiler/Import.hs +3/−3
- src/Fay/Compiler/InitialPass.hs +3/−2
- src/Fay/Compiler/Misc.hs +1/−1
- src/Fay/Compiler/ModuleT.hs +3/−3
- src/Fay/Compiler/Packages.hs +15/−3
- src/Fay/Compiler/Parse.hs +1/−1
- src/Fay/Compiler/Pattern.hs +1/−1
- src/Fay/Compiler/Prelude.hs +2/−2
- src/Fay/Compiler/PrimOp.hs +1/−1
- src/Fay/Compiler/Print.hs +12/−10
- src/Fay/Compiler/Typecheck.hs +14/−3
- src/Fay/Config.hs +3/−0
- src/Fay/Convert.hs +14/−15
- src/Fay/Runtime.hs +842/−0
- src/Fay/Types.hs +11/−3
- src/Fay/Types/CompileError.hs +1/−0
- src/Fay/Types/Js.hs +1/−0
- src/Fay/Types/Printer.hs +14/−7
- src/haskell-names/Language/Haskell/Names/GetBound.hs +1/−1
- src/haskell-names/Language/Haskell/Names/GlobalSymbolTable.hs +7/−3
- src/haskell-names/Language/Haskell/Names/Imports.hs +0/−2
- src/haskell-names/Language/Haskell/Names/LocalSymbolTable.hs +2/−1
- src/haskell-names/Language/Haskell/Names/ModuleSymbols.hs +4/−6
- src/haskell-names/Language/Haskell/Names/Open/Derived.hs +2/−1
- src/haskell-names/Language/Haskell/Names/Recursive.hs +3/−3
- src/haskell-names/Language/Haskell/Names/SyntaxUtils.hs +1/−0
- src/haskell-names/Language/Haskell/Names/Types.hs +7/−2
- src/main/Main.hs +8/−6
- src/tests/Test/Compile.hs +25/−11
- src/tests/Test/Desugar.hs +3/−3
- src/tests/Tests.hs +33/−26
- tests/Nullable.hs +1/−1
- tests/String.hs +0/−3
- tests/String.res +0/−1
- tests/Strings.hs +3/−0
- tests/Strings.res +1/−0
- tests/WhenUnlessRecursion.hs +1/−1
CHANGELOG.md view
@@ -2,6 +2,45 @@ See full history at: <https://github.com/faylang/fay/commits> +### 0.24.2.0 (2021-01-10)++* Drop GHC 8.0 support.+* Cabal upgraded to 2.0 spec-version.+* Travis CI refactored to allow cabal-install 3.2.0.0 builds.++### 0.24.1.1 (2021-01-08)++* Relax boundaries for aeson, tasty, base-compat. Allow builds for Gentoo (#469).++### 0.24.1.0 (2020-03-26)++* GHC 8.10.1 support.++#### 0.24.0.5 (2020-03-10)++* GHC 8.8 support.++#### 0.24.0.4 (2019-12-03)++* Fixes stack nix integration broken.++#### 0.24.0.3 (2019-04-29)++* Dependency updates including GHC-8.6 support.+* Added stack compatibility.++#### 0.24.0.2++* Fix dependent compilation fail when building project with stack (#457).++#### 0.24.0.1++* Dependency updates incl GHC 8.4 support++## 0.24.0.0++* Add the option to generate typescript output, thanks to Junji Hashimoto.+ ### 0.23.2.0 * GHC 8.2 support
Setup.hs view
@@ -7,24 +7,10 @@ import Distribution.PackageDescription import Distribution.Simple -main = do+main = defaultMainWithHooks simpleUserHooks- { preConf = \_args _flags -> do putStrLn reminder- return emptyHookedBuildInfo- , postInst = (\_ _ _ _ -> putStrLn fayBaseReminder)+ { postInst = \_ _ _ _ -> putStrLn fayBaseReminder }--reminder =- " \n\- \- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -\n\- \ \n\- \ REMEMBER: This compiler is in flux, supercalifragelistic style. You should \n\- \ read the CHANGELOG for this release as the changes probably \n\- \ affect you. \n\- \ \n\- \ \n\- \ \n\- \- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -\n" fayBaseReminder = " \n\
examples/calc.hs view
@@ -32,7 +32,7 @@ return () else do setVal (show n) display writeRef appendMore True)- getInput = getVal display >>= (return . parseDouble 10)+ getInput = getVal display >>= (return . parseDouble) operator op = do calculate num <- getInput@@ -104,8 +104,8 @@ -------------------------------------------------------------------------------- -- Utilities -parseDouble :: Int -> String -> Double-parseDouble = ffi "parseFloat(%2,%1) || 0"+parseDouble :: String -> Double+parseDouble = ffi "parseFloat(%1) || 0" -------------------------------------------------------------------------------- -- Refs
fay.cabal view
@@ -1,5 +1,6 @@+cabal-version: 2.0 name: fay-version: 0.23.2.0+version: 0.24.2.0 synopsis: A compiler for Fay, a Haskell subset that compiles to JavaScript. description: Fay is a proper subset of Haskell which is type-checked with GHC, and compiled to JavaScript. It is lazy, pure, has a Fay monad,@@ -22,9 +23,8 @@ copyright: 2012 Chris Done, Adam Bergmark category: Development, Web, Fay build-type: Custom-cabal-version: >=1.8+Tested-with: GHC ==8.4.4 || ==8.6.5 || ==8.8.3 data-files:- js/runtime.js src/Fay/FFI.hs extra-source-files: CHANGELOG.md@@ -72,11 +72,19 @@ manual: True default: False +custom-setup+ setup-depends:+ base+ , Cabal+ library+ default-language: Haskell2010 ghc-options: -O2 -Wall hs-source-dirs: src src/haskell-names+ autogen-modules:+ Paths_fay exposed-modules: Fay Fay.Compiler@@ -112,6 +120,7 @@ Fay.Exts Fay.Exts.NoAnnotation Fay.Exts.Scoped+ Fay.Runtime Fay.Types.FFI Fay.Types.Js Fay.Types.ModulePath@@ -134,18 +143,18 @@ Language.Haskell.Names.Types Paths_fay build-depends:- base >= 4.9 && < 4.11- , base-compat >= 0.8 && < 0.10- , aeson > 0.6 && < 1.3+ base >= 4.9 && < 4.15+ , base-compat >= 0.10 && < 0.12+ , aeson > 0.6 && < 1.6 , bytestring >= 0.9 && < 0.11- , containers >= 0.4 && < 0.6+ , containers >= 0.4 && < 0.7 , data-default >= 0.2 && < 0.8 , data-lens-light == 0.1.* , directory >= 1.1 && < 1.4 , filepath >= 1.3 && < 1.5 , ghc-paths == 0.1.*- , haskell-src-exts >= 1.18.1 && < 1.20- , language-ecmascript >= 0.15 && < 0.18+ , haskell-src-exts >= 1.20+ , language-ecmascript >= 0.15 && < 0.20 , mtl >= 2.1 && < 2.3 , mtl-compat >= 0.1 && < 0.3 , process >= 1.1 && < 1.7@@ -155,19 +164,21 @@ , spoon >= 0.1 && < 0.4 , syb >= 0.3 && < 0.8 , text >= 0.11 && < 1.3- , time >= 1.4 && < 1.9- , transformers >= 0.3 && < 0.4 || > 0.4.1 && < 0.7- , transformers-compat >= 0.3 && < 0.6+ , time >= 1.4 && < 1.10+ , transformers >= 0.3 && < 0.6+ , transformers-compat >= 0.3 && < 0.7 , traverse-with-class >= 1.0 && < 1.1 , uniplate >= 1.6.11 && < 1.7 , unordered-containers == 0.2.* , utf8-string >= 0.1 && < 1.1 , vector < 0.13+ , shakespeare < 2.1 if impl(ghc < 7.8) build-depends: tagged executable fay+ default-language: Haskell2010 hs-source-dirs: src/main ghc-options: -O2 -Wall main-is: Main.hs@@ -175,11 +186,13 @@ base , fay , mtl- , optparse-applicative >= 0.11 && < 0.15+ , optparse-applicative >= 0.11 && < 0.16 , split other-modules: Paths_fay+ executable fay-tests+ default-language: Haskell2010 ghc-options: -O2 -Wall -threaded -with-rtsopts=-N hs-source-dirs: src/tests main-is: Tests.hs@@ -201,8 +214,8 @@ , fay , filepath , haskell-src-exts- , random >= 1.0 && < 1.2- , tasty >= 0.9 && < 0.12+ , random >= 1.0 && < 1.3+ , tasty >= 0.9 && < 1.5 , tasty-hunit >= 0.8 && < 0.11 , tasty-th == 0.1.* , text
− js/runtime.js
@@ -1,821 +0,0 @@-/*******************************************************************************- * Misc.- */--// Workaround for missing functionality in IE 8 and earlier.-if( Object.create === undefined ) {- Object.create = function( o ) {- function F(){}- F.prototype = o;- return new F();- };-}--// Insert properties of b in place into a.-function Fay$$objConcat(a,b){- for (var p in b) if (b.hasOwnProperty(p)){- a[p] = b[p];- }- return a;-}--/*******************************************************************************- * Thunks.- */--// Force a thunk (if it is a thunk) until WHNF.-function Fay$$_(thunkish,nocache){- while (thunkish instanceof Fay$$$) {- thunkish = thunkish.force(nocache);- }- return thunkish;-}--// Apply a function to arguments (see method2 in Fay.hs).-function Fay$$__(){- var f = arguments[0];- for (var i = 1, len = arguments.length; i < len; i++) {- f = (f instanceof Fay$$$? Fay$$_(f) : f)(arguments[i]);- }- return f;-}--// Thunk object.-function Fay$$$(value){- this.forced = false;- this.value = value;-}--// Force the thunk.-Fay$$$.prototype.force = function(nocache) {- return nocache ?- this.value() :- (this.forced ?- this.value :- (this.value = this.value(), this.forced = true, this.value));-};---function Fay$$seq(x) {- return function(y) {- Fay$$_(x,false);- return y;- }-}--function Fay$$seq$36$uncurried(x,y) {- Fay$$_(x,false);- return y;-}--/*******************************************************************************- * Monad.- */--function Fay$$Monad(value){- this.value = value;-}--// This is used directly from Fay, but can be rebound or shadowed. See primOps in Types.hs.-// >>-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; });-}--// >>=-// 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 Fay$$$(function(){- var monad = Fay$$_(m,true);- return Fay$$_(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 Fay$$$(function(){- var monad = Fay$$_(m,true);- return Fay$$_(f)(monad.value);- });-}--// This is used directly from Fay, but can be rebound or shadowed.-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 Fay$$$(function(){- Fay$$_(thunk,type);- return new Fay$$Monad(Fay$$unit);- })- }-}--// This is used directly from Fay, but can be rebound or shadowed.-function Fay$$return$36$uncurried(a){- return new Fay$$Monad(a);-}--// Unit: ().-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;- if(base == "action") {- // A nullary monadic action. Should become a nullary JS function.- // Fay () -> function(){ return ... }- return function(){- return Fay$$fayToJs(args[0],Fay$$_(fayObj,true).value);- };-- }- else if(base == "function") {- // A proper function.- return 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 = Fay$$_(fayFunc,true);- // TODO: Perhaps we should throw an error when JS- // passes more arguments than Haskell accepts.-- // Unserialize the JS values to Fay for the Fay callback.- if (args == "automatic_function")- {- for (var i = 0; i < arguments.length; i++) {- fayFunc = Fay$$_(fayFunc(Fay$$jsToFay(["automatic"],arguments[i])),true);- }- return Fay$$fayToJs(["automatic"], fayFunc);- }-- for (var i = 0, len = len; i < len - 1 && fayFunc instanceof Function; i++) {- fayFunc = Fay$$_(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?");- }- };-- }- else if(base == "string") {- return Fay$$fayToJs_string(fayObj);- }- else if(base == "list") {- // Serialize Fay list to JavaScript array.- var arr = [];- fayObj = Fay$$_(fayObj);- while(fayObj instanceof Fay$$Cons) {- arr.push(Fay$$fayToJs(args[0],fayObj.car));- fayObj = Fay$$_(fayObj.cdr);- }- return arr;- }- else if(base == "tuple") {- // Serialize Fay tuple to JavaScript array.- var arr = [];- fayObj = Fay$$_(fayObj);- var i = 0;- while(fayObj instanceof Fay$$Cons) {- arr.push(Fay$$fayToJs(args[i++],fayObj.car));- fayObj = Fay$$_(fayObj.cdr);- }- return arr;- }- else if(base == "defined") {- fayObj = Fay$$_(fayObj);- return fayObj instanceof Fay.FFI._Undefined- ? undefined- : Fay$$fayToJs(args[0],fayObj.slot1);- }- else if(base == "nullable") {- fayObj = Fay$$_(fayObj);- return fayObj instanceof Fay.FFI._Null- ? null- : Fay$$fayToJs(args[0],fayObj.slot1);- }- else if(base == "double" || base == "int" || base == "bool") {- // Bools are unboxed.- return Fay$$_(fayObj);- }- else if(base == "ptr")- return fayObj;- else if(base == "unknown")- return Fay$$fayToJs(["automatic"], fayObj);- else if(base == "automatic" && fayObj instanceof Function) {- return Fay$$fayToJs(["function", "automatic_function"], fayObj);- }- else if(base == "automatic" || base == "user") {- fayObj = Fay$$_(fayObj);-- if(fayObj instanceof Fay$$Cons || fayObj === null){- // Serialize Fay list to JavaScript array.- var arr = [];- while(fayObj instanceof Fay$$Cons) {- arr.push(Fay$$fayToJs(["automatic"],fayObj.car));- fayObj = Fay$$_(fayObj.cdr);- }- return arr;- } else {- var fayToJsFun = fayObj && fayObj.instance && Fay$$fayToJsHash[fayObj.instance];- return fayToJsFun ? fayToJsFun(type,type[2],fayObj) : fayObj;- }- }-- throw new Error("Unhandled Fay->JS translation type: " + base);-}--// Stores the mappings from fay types to js objects.-// This will be populated by compiled modules.-var Fay$$fayToJsHash = {};--// Specialized serializer for string.-function Fay$$fayToJs_string(fayObj){- // Serialize Fay string to JavaScript string.- var str = "";- fayObj = Fay$$_(fayObj);- while(fayObj instanceof Fay$$Cons) {- str += Fay$$_(fayObj.car);- fayObj = Fay$$_(fayObj.cdr);- }- return str;-};-function Fay$$jsToFay_string(x){- return Fay$$list(x)-};--// Special num/bool serializers.-function Fay$$jsToFay_int(x){return x;}-function Fay$$jsToFay_double(x){return x;}-function Fay$$jsToFay_bool(x){return x;}--function Fay$$fayToJs_int(x){return Fay$$_(x);}-function Fay$$fayToJs_double(x){return Fay$$_(x);}-function Fay$$fayToJs_bool(x){return Fay$$_(x);}--// Unserialize an object from JS to Fay.-function Fay$$jsToFay(type,jsObj){- var base = type[0];- var args = type[1];- var fayObj;- if(base == "action") {- // Unserialize a "monadic" JavaScript return value into a monadic value.- return new Fay$$Monad(Fay$$jsToFay(args[0],jsObj));- }- else if(base == "function") {- // Unserialize a function from JavaScript to a function that Fay can call.- // So- //- // var f = function(x,y,z){ … }- //- // becomes something like:- //- // function(x){- // return function(y){- // return function(z){- // return new Fay$$$(function(){- // return Fay$$jsToFay(f(Fay$$fayTojs(x),- // Fay$$fayTojs(y),- // Fay$$fayTojs(z))- // }}}}};- var returnType = args[args.length-1];- var funArgs = args.slice(0,-1);-- if (jsObj.length > 0) {- var makePartial = function(args){- return function(arg){- var i = args.length;- var fayArg = Fay$$fayToJs(funArgs[i],arg);- var newArgs = args.concat([fayArg]);- if(newArgs.length == funArgs.length) {- return new Fay$$$(function(){- return Fay$$jsToFay(returnType,jsObj.apply(this,newArgs));- });- } else {- return makePartial(newArgs);- }- };- };- return makePartial([]);- }- else- return function (arg) {- return Fay$$jsToFay(["automatic"], jsObj(Fay$$fayToJs(["automatic"], arg)));- };- }- else if(base == "string") {- // Unserialize a JS string into Fay list (String).- // This is a special case, when String is explicit in the type signature,- // with `Automatic' a string would not be decoded.- return Fay$$list(jsObj);- }- else if(base == "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.- return Fay$$list(serializedList);- }- else if(base == "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.- return Fay$$list(serializedTuple);- }- else if(base == "defined") {- return jsObj === undefined- ? new Fay.FFI._Undefined()- : new Fay.FFI._Defined(Fay$$jsToFay(args[0],jsObj));- }- else if(base == "nullable") {- return jsObj === null- ? new Fay.FFI._Null()- : new Fay.FFI.Nullable(Fay$$jsToFay(args[0],jsObj));- }- else if(base == "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!";- return fayObj;- }- else if (base == "double" ||- base == "bool" ||- base == "ptr") {- return jsObj;- }- else if(base == "unknown")- return Fay$$jsToFay(["automatic"], jsObj);- else if(base == "automatic" && jsObj instanceof Function) {- var type = [["automatic"]];- for (var i = 0; i < jsObj.length; i++)- type.push(["automatic"]);- return Fay$$jsToFay(["function", type], jsObj);- }- else if(base == "automatic" && jsObj instanceof Array) {- var list = null;- for (var i = jsObj.length - 1; i >= 0; i--) {- list = new Fay$$Cons(Fay$$jsToFay([base], jsObj[i]), list);- }- return list;- }- else if(base == "automatic" || base == "user") {- if (jsObj && jsObj['instance']) {- var jsToFayFun = Fay$$jsToFayHash[jsObj["instance"]];- return jsToFayFun ? jsToFayFun(type,type[2],jsObj) : jsObj;- }- else- return jsObj;- }-- throw new Error("Unhandled JS->Fay translation type: " + base);-}--// Stores the mappings from js objects to fay types.-// This will be populated by compiled modules.-var Fay$$jsToFayHash = {};--/*******************************************************************************- * 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.-// `list' is already forced by the time it's passed to this function.-// `list' cannot be null and `index' cannot be out of bounds.-function Fay$$index(index,list){- for(var i = 0; i < index; i++) {- list = Fay$$_(list.cdr);- }- return list.car;-}--// List length.-// `list' is already forced by the time it's passed to this function.-function Fay$$listLen(list,max){- for(var i = 0; list !== null && i < max + 1; i++) {- list = Fay$$_(list.cdr);- }- return i == max;-}--/*******************************************************************************- * Numbers.- */--// Built-in *.-function Fay$$mult(x){- return function(y){- return new Fay$$$(function(){- return Fay$$_(x) * Fay$$_(y);- });- };-}--function Fay$$mult$36$uncurried(x,y){-- return new Fay$$$(function(){- return Fay$$_(x) * Fay$$_(y);- });--}--// Built-in +.-function Fay$$add(x){- return function(y){- return new Fay$$$(function(){- return Fay$$_(x) + Fay$$_(y);- });- };-}--// Built-in +.-function Fay$$add$36$uncurried(x,y){-- return new Fay$$$(function(){- return Fay$$_(x) + Fay$$_(y);- });--}--// Built-in -.-function Fay$$sub(x){- return function(y){- return new Fay$$$(function(){- return Fay$$_(x) - Fay$$_(y);- });- };-}-// Built-in -.-function Fay$$sub$36$uncurried(x,y){-- return new Fay$$$(function(){- return Fay$$_(x) - Fay$$_(y);- });--}--// Built-in /.-function Fay$$divi(x){- return function(y){- return new Fay$$$(function(){- return Fay$$_(x) / Fay$$_(y);- });- };-}--// Built-in /.-function Fay$$divi$36$uncurried(x,y){-- return new Fay$$$(function(){- return Fay$$_(x) / Fay$$_(y);- });--}--/*******************************************************************************- * Booleans.- */--// Are two values equal?-function Fay$$equal(lit1, lit2) {- // Simple case- lit1 = Fay$$_(lit1);- lit2 = Fay$$_(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 = Fay$$_(lit1.cdr), lit2 = Fay$$_(lit2.cdr);- if (lit1 === null || lit2 === null)- return lit1 === lit2;- } while (true);- } else if (typeof lit1 == 'object' && typeof lit2 == 'object' && lit1 && lit2 &&- lit1.instance === lit2.instance) {- for(var x in lit1) {- if(!Fay$$equal(lit1[x],lit2[x]))- return false;- }- return true;- } else {- return false;- }-}--// Built-in ==.-function Fay$$eq(x){- return function(y){- return new Fay$$$(function(){- return Fay$$equal(x,y);- });- };-}--function Fay$$eq$36$uncurried(x,y){-- return new Fay$$$(function(){- return Fay$$equal(x,y);- });--}--// Built-in /=.-function Fay$$neq(x){- return function(y){- return new Fay$$$(function(){- return !(Fay$$equal(x,y));- });- };-}--// Built-in /=.-function Fay$$neq$36$uncurried(x,y){-- return new Fay$$$(function(){- return !(Fay$$equal(x,y));- });--}--// Built-in >.-function Fay$$gt(x){- return function(y){- return new Fay$$$(function(){- return Fay$$_(x) > Fay$$_(y);- });- };-}--// Built-in >.-function Fay$$gt$36$uncurried(x,y){-- return new Fay$$$(function(){- return Fay$$_(x) > Fay$$_(y);- });--}--// Built-in <.-function Fay$$lt(x){- return function(y){- return new Fay$$$(function(){- return Fay$$_(x) < Fay$$_(y);- });- };-}---// Built-in <.-function Fay$$lt$36$uncurried(x,y){-- return new Fay$$$(function(){- return Fay$$_(x) < Fay$$_(y);- });--}---// Built-in >=.-function Fay$$gte(x){- return function(y){- return new Fay$$$(function(){- return Fay$$_(x) >= Fay$$_(y);- });- };-}--// Built-in >=.-function Fay$$gte$36$uncurried(x,y){-- return new Fay$$$(function(){- return Fay$$_(x) >= Fay$$_(y);- });--}--// Built-in <=.-function Fay$$lte(x){- return function(y){- return new Fay$$$(function(){- return Fay$$_(x) <= Fay$$_(y);- });- };-}--// Built-in <=.-function Fay$$lte$36$uncurried(x,y){-- return new Fay$$$(function(){- return Fay$$_(x) <= Fay$$_(y);- });--}--// Built-in &&.-function Fay$$and(x){- return function(y){- return new Fay$$$(function(){- return Fay$$_(x) && Fay$$_(y);- });- };-}--// Built-in &&.-function Fay$$and$36$uncurried(x,y){-- return new Fay$$$(function(){- return Fay$$_(x) && Fay$$_(y);- });- ;-}--// Built-in ||.-function Fay$$or(x){- return function(y){- return new Fay$$$(function(){- return Fay$$_(x) || Fay$$_(y);- });- };-}--// Built-in ||.-function Fay$$or$36$uncurried(x,y){-- return new Fay$$$(function(){- return Fay$$_(x) || Fay$$_(y);- });--}--/*******************************************************************************- * Mutable references.- */--// Make a new mutable reference.-function Fay$$Ref(x){- this.value = x;-}--// Write to the ref.-function Fay$$writeRef(ref,x){- ref.value = x;-}--// Get the value from the ref.-function Fay$$readRef(ref,x){- return ref.value;-}--/*******************************************************************************- * Dates.- */-function Fay$$date(str){- return window.Date.parse(str);-}--/*******************************************************************************- * Data.Var- */--function Fay$$Ref2(val){- this.val = val;-}--function Fay$$Sig(){- this.handlers = [];-}--function Fay$$Var(val){- this.val = val;- this.handlers = [];-}--// Helper used by Fay$$setValue and for merging-function Fay$$broadcastInternal(self, val, force){- var handlers = self.handlers;- var exceptions = [];- for(var len = handlers.length, i = 0; i < len; i++) {- try {- force(handlers[i][1](val), true);- } catch (e) {- exceptions.push(e);- }- }- // Rethrow the encountered exceptions.- if (exceptions.length > 0) {- console.error("Encountered " + exceptions.length + " exception(s) while broadcasing a change to ", self);- for(var len = exceptions.length, i = 0; i < len; i++) {- (function(exception) {- window.setTimeout(function() { throw exception; }, 0);- })(exceptions[i]);- }- }-}--function Fay$$setValue(self, val, force){- if (self instanceof Fay$$Ref2) {- self.val = val;- } else if (self instanceof Fay$$Var) {- self.val = val;- Fay$$broadcastInternal(self, val, force);- } else if (self instanceof Fay$$Sig) {- Fay$$broadcastInternal(self, val, force);- } else {- throw "Fay$$setValue given something that's not a Ref2, Var, or Sig"- }-}--function Fay$$subscribe(self, f){- var key = {};- self.handlers.push([key,f]);- var searchStart = self.handlers.length - 1;- return function(_){- for(var i = Math.min(searchStart, self.handlers.length - 1); i >= 0; i--) {- if(self.handlers[i][0] == key) {- self.handlers = self.handlers.slice(0,i).concat(self.handlers.slice(i+1));- return;- }- }- return _; // This variable has to be used, otherwise Closure- // strips it out and Fay serialization breaks.- };-}--/*******************************************************************************- * Application code.- */
src/Fay.hs view
@@ -2,7 +2,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE ViewPatterns #-} @@ -19,9 +18,9 @@ ,compileFromTo ,compileFromToAndGenerateHtml ,toJsName+ ,toTsName ,showCompileError- ,getConfigRuntime- ,getRuntime+ ,readConfigRuntime ) where import Fay.Compiler.Prelude@@ -31,6 +30,7 @@ import Fay.Compiler.Packages import Fay.Compiler.Typecheck import Fay.Config+import Fay.Runtime import qualified Fay.Exts as F import Fay.Types @@ -39,7 +39,6 @@ import Language.Haskell.Exts (prettyPrint) import Language.Haskell.Exts.Syntax import Language.Haskell.Exts.SrcLoc-import Paths_fay import SourceMap (generate) import SourceMap.Types import System.FilePath@@ -118,9 +117,8 @@ -- Don't use this directly, it's only exposed for the test suite. compileFileWithState :: Config -> FilePath -> IO (Either CompileError (String,Maybe [Mapping],CompileState)) compileFileWithState config filein = do- runtime <- getConfigRuntime config+ raw <- readConfigRuntime config hscode <- readFile filein- raw <- readFile runtime config' <- resolvePackages config compileToModule filein config' raw (compileToplevelModule filein) hscode @@ -139,14 +137,14 @@ ) where pw = execPrinter (runtime <> aliases <> printer <> main) pr- runtime = if (configExportRuntime config) then write raw else mempty- aliases = if (configPrettyThunks config)+ runtime = if configExportRuntime config then write raw else mempty+ aliases = if configPrettyThunks config then write . unlines $ [ "var $ = Fay$$$;" , "var _ = Fay$$_;" , "var __ = Fay$$__;" ] else mempty- main = if (not $ configLibrary config)+ main = if not (configLibrary config) then write $ "Fay$$_(" ++ modulename ++ ".main, true);\n" else mempty pr = defaultPrintReader@@ -161,6 +159,12 @@ ('s':'h':'.': (reverse -> file)) -> file ++ ".js" _ -> x +-- | Convert a Haskell filename to a TypeScript filename.+toTsName :: String -> String+toTsName x = case reverse x of+ ('s':'h':'.': (reverse -> file)) -> file ++ ".ts"+ _ -> x+ -- | Print a compile error for human consumption. showCompileError :: CompileError -> String showCompileError e = case e of@@ -203,9 +207,8 @@ -- | Get the JS runtime source. -- This will return the user supplied runtime if it exists.-getConfigRuntime :: Config -> IO String-getConfigRuntime cfg = maybe getRuntime return $ configRuntimePath cfg---- | Get the default JS runtime source.-getRuntime :: IO String-getRuntime = getDataFileName "js/runtime.js"+readConfigRuntime :: Config -> IO String+readConfigRuntime cfg =+ case configRuntimePath cfg of+ Just path -> readFile path+ Nothing -> return $ getRuntimeSource cfg
src/Fay/Compiler.hs view
@@ -121,7 +121,7 @@ -- | Compile a parse HSE module. compileModuleFromAST :: ([JsStmt], [JsStmt]) -> F.Module -> Compile ([JsStmt], [JsStmt]) compileModuleFromAST (hstmts0, fstmts0) mod'@Module{} = do- mod@(Module _ _ pragmas _ decls) <- annotateModule Haskell2010 defaultExtensions mod'+ ~mod@(Module _ _ pragmas _ decls) <- annotateModule Haskell2010 defaultExtensions mod' let modName = unAnn $ F.moduleName mod modify $ \s -> s { stateUseFromString = hasLanguagePragmas ["OverloadedStrings", "RebindableSyntax"] pragmas }@@ -153,16 +153,19 @@ createModulePath :: ModuleName a -> Compile [JsStmt] createModulePath (unAnn -> m) = do cfg <- config id- reg <- liftM concat . mapM modPath . mkModulePaths $ m+ let isTs = configTypeScript cfg+ reg <- fmap concat . mapM (modPath isTs) . mkModulePaths $ m strict <- if shouldExportStrictWrapper m cfg- then liftM concat . mapM modPath . mkModulePaths $ (\(ModuleName i n) -> ModuleName i ("Strict." ++ n)) m+ then fmap concat . mapM (modPath isTs) . mkModulePaths $ (\(ModuleName i n) -> ModuleName i ("Strict." ++ n)) m else return [] return $ reg ++ strict where- modPath :: ModulePath -> Compile [JsStmt]- modPath mp = whenImportNotGenerated mp $ \(unModulePath -> l) -> case l of- [n] -> [JsVar (JsNameVar . UnQual () $ Ident () n) (JsObj [])]+ modPath :: Bool -> ModulePath -> Compile [JsStmt]+ modPath isTs mp = whenImportNotGenerated mp $ \(unModulePath -> l) -> case l of+ [n] -> if isTs+ then [JsMapVar (JsNameVar . UnQual () $ Ident () n) (JsObj [])]+ else [JsVar (JsNameVar . UnQual () $ Ident () n) (JsObj [])] _ -> [JsSetModule mp (JsObj [])] whenImportNotGenerated :: ModulePath -> (ModulePath -> [JsStmt]) -> Compile [JsStmt]
src/Fay/Compiler/Decl.hs view
@@ -25,6 +25,8 @@ import Control.Monad.RWS (gets, modify) import Language.Haskell.Exts hiding (binds, loc, name) +{-# ANN module ("HLint: ignore Reduce duplication"::String) #-}+ -- | Compile Haskell declaration. compileDecls :: Bool -> [S.Decl] -> Compile [JsStmt] compileDecls toplevel = fmap concat . mapM (compileDecl toplevel)@@ -206,10 +208,15 @@ (Just (srcInfoSpan (S.srcSpanInfo srcloc))) name (foldr (\arg inner -> JsFun Nothing [arg] [] (Just inner))- (stmtsThunk (concat pats ++ basecase))+ (stmtsThunk $ deleteAfterReturn (concat pats ++ basecase)) args) return [bind] where+ deleteAfterReturn :: [JsStmt] -> [JsStmt]+ deleteAfterReturn [] = []+ deleteAfterReturn (x@(JsEarlyReturn _):_) = [x]+ deleteAfterReturn (x:xs) = x:deleteAfterReturn xs+ args = zipWith const uniqueNames argslen isWildCardMatch (Match _ _ pats _ _) = all isWildCardPat pats
src/Fay/Compiler/Desugar.hs view
@@ -49,6 +49,7 @@ >>= return . desugarInfixOp >>= return . desugarInfixPat >>= return . desugarExpParen+{-# ANN desugar' "HLint: ignore Use <$>" #-} -- | (a `f`) => \b -> a `f` b -- (`f` b) => \a -> a `f` b
src/Fay/Compiler/Exp.hs view
@@ -187,14 +187,21 @@ exp <- compileExp e withScopedTmpJsName $ \tmpName -> do pats <- optimizePatConditions <$> mapM (compilePatAlt (JsName tmpName)) alts+ let (xx,flag) = deleteAfterReturn (concat pats) return $ JsApp (JsFun Nothing [tmpName]- (concat pats)- (if any isWildCardAlt alts+ xx+ (if (flag || any isWildCardAlt alts) then Nothing else Just (throwExp "unhandled case" (JsName tmpName)))) [exp]+ where+ deleteAfterReturn :: [JsStmt] -> ([JsStmt],Bool)+ deleteAfterReturn [] = ([],False)+ deleteAfterReturn (x@(JsEarlyReturn _):_) = ([x],True)+ deleteAfterReturn (x:xs) = ((x:xx),flag)+ where (xx,flag) = deleteAfterReturn xs -- | Compile the given pattern against the given expression. compilePatAlt :: JsExp -> S.Alt -> Compile [JsStmt]@@ -220,7 +227,7 @@ <*> if null rest then return [] else do gs' <- compileGuards rest return [gs']- where makeIf gs e gss = JsIf gs [JsEarlyReturn e] gss+ where makeIf gs e = JsIf gs [JsEarlyReturn e] compileGuards rhss = throwError . UnsupportedRhs . GuardedRhss noI $ rhss @@ -237,9 +244,13 @@ generateStatements exp = foldM (\inner (param,pat) -> do stmts <- compilePat (JsName param) pat inner- return [JsEarlyReturn (JsFun Nothing [param] (stmts ++ [unhandledcase param | not allfree]) Nothing)])+ return [JsEarlyReturn (JsFun Nothing [param] (deleteAfterReturn $ stmts ++ [unhandledcase param | not allfree]) Nothing)]) [JsEarlyReturn exp] (reverse (zip uniqueNames pats))+ deleteAfterReturn :: [JsStmt] -> [JsStmt]+ deleteAfterReturn [] = []+ deleteAfterReturn (x@(JsEarlyReturn _):_) = [x]+ deleteAfterReturn (x:xs) = x:deleteAfterReturn xs -- | Compile [e1..] arithmetic sequences. compileEnumFrom :: S.Exp -> Compile JsExp@@ -283,7 +294,7 @@ let unQualName = withIdent lowerFirst . unQualify $ unAnn name qname <- unsafeResolveName name let record = JsVar (JsNameVar unQualName) (JsNew (JsConstructor qname) [])- setFields <- liftM concat (forM fieldUpdates (updateStmt name))+ setFields <- concat <$> forM fieldUpdates (updateStmt name) return $ JsApp (JsFun Nothing [] (record:setFields) (Just . JsName . JsNameVar . withIdent lowerFirst . unQualify $ unAnn name)) [] where -- updateStmt :: QName a -> S.FieldUpdate -> Compile [JsStmt]
src/Fay/Compiler/FFI.hs view
@@ -57,8 +57,9 @@ TyEquals _ t1 t2 -> TyEquals () <$> rmNewtys t1 <*> rmNewtys t2 TySplice {} -> return $ unAnn typ TyBang _ bt unp t -> TyBang () (unAnn bt) (unAnn unp) <$> rmNewtys t- TyWildCard _ _ -> error "TyWildCard not supported"- TyQuasiQuote _ _ _ -> error "TyQuasiQuote not supported"+ TyWildCard {} -> error "TyWildCard not supported"+ TyQuasiQuote {} -> error "TyQuasiQuote not supported"+ TyUnboxedSum {} -> error "TyUnboxedSum not supported" compileFFI' :: N.Type -> Compile JsExp compileFFI' sig = do
src/Fay/Compiler/GADT.hs view
@@ -9,13 +9,11 @@ -- | Convert a GADT to a normal data type. convertGADT :: GadtDecl a -> QualConDecl a convertGADT d = case d of- GadtDecl s name Nothing typ ->+ GadtDecl s name tyvars context Nothing typ -> QualConDecl s tyvars context (ConDecl s name (convertFunc typ))- GadtDecl s name (Just fs) _typ ->+ GadtDecl s name tyvars context (Just fs) _typ -> QualConDecl s tyvars context (RecDecl s name fs) where- tyvars = Nothing- context = Nothing convertFunc :: Type a -> [Type a] convertFunc (TyCon _ _) = [] convertFunc (TyFun _ x xs) = x : convertFunc xs
src/Fay/Compiler/Import.hs view
@@ -22,7 +22,7 @@ import Control.Monad.Except (throwError) import Control.Monad.RWS (ask, get, gets, lift, listen, modify)-import Language.Haskell.Exts hiding (name, var)+import Language.Haskell.Exts hiding (name) import System.Directory import System.FilePath @@ -34,7 +34,7 @@ -- | Compile a module compileWith- :: Monoid a+ :: (Monoid a, Semigroup a) => FilePath -> (a -> F.Module -> Compile a) -> (FilePath -> String -> Compile a)@@ -50,7 +50,7 @@ st (parseResult (throwError . uncurry ParseError) (\mod' -> do- mod@(Module _ _ _ imports _) <-+ ~mod@(Module _ _ _ imports _) <- either throwError return =<< io (before F.noI mod') res <- foldr (<>) mempty <$> mapM (compileImport compileModule) imports modify $ \s -> s { stateModuleName = unAnn $ F.moduleName mod }
src/Fay/Compiler/InitialPass.hs view
@@ -22,7 +22,7 @@ import Control.Monad.Except (throwError) import Control.Monad.RWS (modify) import qualified Data.Map as M-import Language.Haskell.Exts hiding (name, var)+import Language.Haskell.Exts hiding (name) import qualified Language.Haskell.Names as HN (getInterfaces) -- | Preprocess and collect all information needed during code generation.@@ -51,7 +51,7 @@ preprocessAST :: () -> F.Module -> Compile () preprocessAST () mod@(Module _ _ _ _ decls) = do -- This can only return one element since we only compile one module.- ([exports],_) <- HN.getInterfaces Haskell2010 defaultExtensions [mod]+ ~([exports],_) <- HN.getInterfaces Haskell2010 defaultExtensions [mod] modify $ \s -> s { stateInterfaces = M.insert (stateModuleName s) exports $ stateInterfaces s } forM_ decls scanTypeSigs forM_ decls scanRecordDecls@@ -85,6 +85,7 @@ cs{stateNewtypes=(qcname,qdname,unAnn ty):nts}) compileNewtypeDecl q = error $ "compileNewtypeDecl: Should be impossible (this is a bug). Got: " ++ show q +{-# ANN scanRecordDecls ("HLint: ignore Redundant flip" :: String) #-} -- | Add record declarations to the state scanRecordDecls :: F.Decl -> Compile () scanRecordDecls decl = do
src/Fay/Compiler/Misc.hs view
@@ -282,7 +282,7 @@ hasLanguagePragmas pragmas modulePragmas = (== length pragmas) . length . filter (`elem` pragmas) $ flattenPragmas modulePragmas where flattenPragmas :: [ModulePragma l] -> [String]- flattenPragmas ps = concatMap pragmaName ps+ flattenPragmas = concatMap pragmaName pragmaName (LanguagePragma _ q) = map unname q pragmaName _ = []
src/Fay/Compiler/ModuleT.hs view
@@ -47,7 +47,7 @@ components' = split string split cs = case break (=='.') cs of- (chunk,[]) -> chunk : []+ (chunk,[]) -> [chunk] (chunk,_:rest) -> chunk : split rest validModuleComponent :: String -> Bool@@ -105,9 +105,9 @@ -- -- @i@ is the type of module info, @m@ is the underlying monad. newtype ModuleT i m a =- ModuleT (+ ModuleT (StateT (Map.Map ModuleName i)- (ReaderT ([FilePath] -> ModuleName -> m i) m) a))+ (ReaderT ([FilePath] -> ModuleName -> m i) m) a) deriving (Functor, Applicative, Monad) instance MonadTrans (ModuleT i) where
src/Fay/Compiler/Packages.hs view
@@ -12,6 +12,7 @@ import GHC.Paths import System.Directory import System.FilePath+import System.Environment -- | Given a configuration, resolve any packages specified to their -- data file directories for importing the *.hs sources.@@ -55,12 +56,23 @@ describePackage :: Maybe FilePath -> String -> IO String describePackage db name = do exists <- doesFileExist ghc_pkg- result <- readAllFromProcess (if exists then ghc_pkg else "ghc-pkg") args ""+ stackInNixShell <- fmap isJust (lookupEnv "STACK_IN_NIX_SHELL")+ let command = if exists+ then if (isInfixOf ".stack" ghc_pkg || stackInNixShell)+ then "stack"+ else ghc_pkg+ else "ghc-pkg"+ extraArgs = case command of+ "stack" -> ["exec","--","ghc-pkg"]+ _ -> []+ args = extraArgs ++ ["describe",name] ++ ["--expand-env-vars", "-v2"]+ ++ ["--package-db=" ++ db' | Just db' <- [db]]+ when stackInNixShell (unsetEnv "STACK_IN_NIX_SHELL")+ result <- readAllFromProcess command args ""+ when stackInNixShell (setEnv "STACK_IN_NIX_SHELL" "1") case result of Left (err,out) -> error $ "ghc-pkg describe error:\n" ++ err ++ "\n" ++ out Right (_err,out) -> return out-- where args = ["describe",name] ++ ["-f" ++ db' | Just db' <- [db]] -- | Get the package version from the package description. packageVersion :: String -> Maybe String
src/Fay/Compiler/Parse.hs view
@@ -3,7 +3,7 @@ , defaultExtensions ) where -import Language.Haskell.Exts hiding (name)+import Language.Haskell.Exts -- | Parse some Fay code. parseFay :: Parseable ast => FilePath -> String -> ParseResult ast
src/Fay/Compiler/Pattern.hs view
@@ -47,7 +47,7 @@ -- | Compile a record field pattern. compilePatFields :: JsExp -> S.QName -> [S.PatField] -> [JsStmt] -> Compile [JsStmt] compilePatFields exp name pats body = do- c <- liftM (++ body) (compilePats' [] pats)+ c <- (++ body) <$> compilePats' [] pats qname <- unsafeResolveName name return [JsIf (force exp `JsInstanceOf` JsConstructor qname) c []] where
src/Fay/Compiler/Prelude.hs view
@@ -39,7 +39,7 @@ import Data.Function (on) import Data.List.Compat import Data.Maybe-import Data.Monoid (Monoid (..), (<>))+import Data.Monoid (Monoid (..)) import Data.Ord import Data.Traversable import Prelude.Compat hiding (exp, mod)@@ -55,7 +55,7 @@ -- | Do any of the (monadic) predicates match? anyM :: (Functor m, Applicative m, Monad m) => (a -> m Bool) -> [a] -> m Bool-anyM p l = return . not . null =<< filterM p l+anyM p l = not . null <$> filterM p l -- | Read from a process returning both std err and out. readAllFromProcess :: FilePath -> [String] -> String -> IO (Either (String,String) (String,String))
src/Fay/Compiler/PrimOp.hs view
@@ -29,7 +29,7 @@ import Data.Map (Map) import qualified Data.Map as M-import Language.Haskell.Exts hiding (binds, name)+import Language.Haskell.Exts -- | Make an identifier from the built-in HJ module. fayBuiltin :: a -> String -> QName a
src/Fay/Compiler/Print.hs view
@@ -89,7 +89,7 @@ UnitCon _ -> "unit" Cons _ -> "cons" _ -> error $ "Special constructor not supported: " ++- show (fmap (const ()) specialCon)+ show (void specialCon) -- | Print a list of statements.@@ -101,7 +101,9 @@ printJS (JsExpStmt e) = printJS e <> ";" <> newline printJS (JsBlock stmts) =- "{ " <> (printStmts stmts) <> "}"+ "{ " <> printStmts stmts <> "}"+ printJS (JsMapVar name expr) =+ "var " <> printJS name <> " : {[key: string]: any;} = " <> printJS expr <> ";" <> newline printJS (JsVar name expr) = "var " <> printJS name <> " = " <> printJS expr <> ";" <> newline printJS (JsUpdate name expr) =@@ -122,7 +124,7 @@ "if (" <> printJS expr <> ") {" <> newline <> indented (printStmts thens) <> "}" <>- (if (null elses)+ (if null elses then mempty else " else {" <> newline <> indented (printStmts elses) <>@@ -152,7 +154,7 @@ printJS (JsLit lit) = printJS lit printJS (JsParen expr) = "(" <> printJS expr <> ")" printJS (JsList exprs) = "[" <> mintercalate "," (map printJS exprs) <> "]"- printJS (JsNew name args) = "new " <> (printJS $ JsApp (JsName name) args)+ printJS (JsNew name args) = "new " <> printJS (JsApp (JsName name) args) printJS (JsIndex i expr) = "(" <> printJS expr <> ")[" <> write (show i) <> "]" printJS (JsEq expr1 expr2) = printJS expr1 <> " === " <> printJS expr2 printJS (JsNeq expr1 expr2) = printJS expr1 <> " !== " <> printJS expr2@@ -186,7 +188,7 @@ Nothing -> mempty) <> "}" printJS (JsApp op args) =- printJS (case op of JsFun _ _ _ _ -> JsParen op; _ -> op)+ printJS (case op of JsFun {} -> JsParen op; _ -> op) <> "(" <> mintercalate "," (map printJS args) <> ")"@@ -209,8 +211,8 @@ JsThunk -> askIf prPrettyThunks "$" "Fay$$$" JsForce -> askIf prPrettyThunks "_" "Fay$$_" JsApply -> askIf prPrettyThunks "__" "Fay$$__"- JsParam i -> "$p" <> (write $ show i)- JsTmp i -> "$tmp" <> (write $ show i)+ JsParam i -> "$p" <> write (show i)+ JsTmp i -> "$tmp" <> write (show i) JsConstructor qname -> printCons qname JsBuiltIn qname -> "Fay$$" <> printJS qname JsParametrizedType -> "type"@@ -220,13 +222,13 @@ printCons :: QName l -> Printer printCons (UnQual _ n) = printConsName n printCons (Qual _ (ModuleName _ m) n) = write m <> "." <> printConsName n-printCons (Special {}) = error "qname2String Special"+printCons Special {} = error "qname2String Special" -- | Print an unqualified name. printConsUnQual :: QName l -> Printer printConsUnQual (UnQual _ x) = printJS x printConsUnQual (Qual _ _ n) = printJS n-printConsUnQual (Special {}) = error "printConsUnqual Special"+printConsUnQual Special {} = error "printConsUnqual Special" -- | Print a constructor name given a Name. Helper for printCons. printConsName :: Name l -> Printer@@ -252,7 +254,7 @@ -- The problem only occurs if there is a module A.B and a constructor B in module A. ++ ["__defineGetter__", "__defineSetter__", "__lookupGetter__", "__lookupSetter__", "constructor", "force", "forced", "hasOwnProperty", "isPrototypeOf", "propertyIsEnumerable", "toLocaleString", "toString", "value", "valueOf"] -allowedNameChars :: [Char]+allowedNameChars :: String allowedNameChars = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_" -- | Encode a Haskell name to JavaScript.
src/Fay/Compiler/Typecheck.hs view
@@ -12,6 +12,7 @@ import qualified GHC.Paths as GHCPaths import System.Directory+import System.Environment -- | Call out to GHC to type-check the file. typecheck :: Config -> FilePath -> IO (Either CompileError String)@@ -40,10 +41,20 @@ , "-i" ++ intercalate ":" includeDirs , fp ] ++ ghcPackageDbArgs ++ wallF ++ map ("-package " ++) packages exists <- doesFileExist GHCPaths.ghc- let ghcPath = if exists then GHCPaths.ghc else "ghc"+ stackInNixShell <- fmap isJust (lookupEnv "STACK_IN_NIX_SHELL")+ let ghcPath = if exists+ then if (isInfixOf ".stack" GHCPaths.ghc || stackInNixShell)+ then "stack"+ else GHCPaths.ghc+ else "ghc"+ extraFlags = case ghcPath of+ "stack" -> ["exec","--","ghc"]+ _ -> [] when (configShowGhcCalls cfg) $- putStrLn . intercalate " " $ ghcPath : flags- res <- readAllFromProcess ghcPath flags ""+ putStrLn . unwords $ ghcPath : (extraFlags ++ flags)+ when stackInNixShell (unsetEnv "STACK_IN_NIX_SHELL")+ res <- readAllFromProcess ghcPath (extraFlags ++ flags) ""+ when stackInNixShell (setEnv "STACK_IN_NIX_SHELL" "1") either (return . Left . GHCError . fst) (return . Right . fst) res where wallF | configWall cfg = ["-Wall"]
src/Fay/Config.hs view
@@ -26,6 +26,7 @@ , configPrettyThunks , configPrettyOperators , configShowGhcCalls+ , configTypeScript ) , defaultConfig , defaultConfigWithSandbox@@ -78,6 +79,7 @@ , configPrettyThunks :: Bool -- ^ Use pretty thunk names? , configPrettyOperators :: Bool -- ^ Use pretty operators? , configShowGhcCalls :: Bool -- ^ Print commands sent to GHC?+ , configTypeScript :: Bool -- ^ Output a TypeScript file. } deriving (Show) defaultConfig :: Config@@ -109,6 +111,7 @@ , configPrettyThunks = False , configPrettyOperators = False , configShowGhcCalls = False+ , configTypeScript = False } defaultConfigWithSandbox :: IO Config
src/Fay/Convert.hs view
@@ -3,9 +3,7 @@ {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-}-{-# OPTIONS -fno-warn-type-defaults #-} -- | Convert a Haskell value to a (JSON representation of a) Fay value. @@ -40,7 +38,7 @@ -- values aren't handled by explicit cases. 'encodeFay' can be used to -- resolve this issue. showToFay :: Data a => a -> Maybe Value-showToFay = spoon . encodeFay (\x -> x)+showToFay = spoon . encodeFay id -- | Convert a Haskell value to a Fay json value. This can fail when primitive -- values aren't handled by explicit cases. When this happens, you can add@@ -92,12 +90,12 @@ -- | Convert a Fay json value to a Haskell value. readFromFay :: Data a => Value -> Maybe a-readFromFay = either (\_ -> Nothing) Just . decodeFay (\_ -> id)+readFromFay = either (const Nothing) Just . decodeFay (const id) -- | Convert a Fay json value to a Haskell value. This is like readFromFay, -- except it yields helpful error messages on failure. readFromFay' :: Data a => Value -> Either String a-readFromFay' = decodeFay (\_ -> id)+readFromFay' = decodeFay (const id) -- | Convert a Fay json value to a Haskell value. --@@ -141,7 +139,7 @@ parseTuple :: Data a => GenericParser -> DataType -> Vector Value -> Either String a parseTuple rec typ arr = case dataTypeConstrs typ of- [cons] -> evalStateT (fromConstrM (do i:next <- get+ [cons] -> evalStateT (fromConstrM (do ~(i:next) <- get put next value <- lift (Vector.indexM arr i) lift (rec value))@@ -166,22 +164,23 @@ -- | Make a simple ADT constructor from an object: { "slot1": 1, "slot2": 2} -> Foo 1 2 makeSimple :: Data a => GenericParser -> HashMap Text Value -> Constr -> Either String a makeSimple rec obj cons =- evalStateT (fromConstrM (do i:next <- get+ evalStateT (fromConstrM (do ~(i:next) <- get put next value <- lift (lookupField obj (Text.pack ("slot" ++ show i))) lift (rec value)) cons)- [1..]+ [(1::Integer)..] -- | Make a record from a key-value: { "x": 1 } -> Foo { x = 1 } makeRecord :: Data a => GenericParser -> HashMap Text Value -> Constr -> [String] -> Either String a-makeRecord rec obj cons fields =- evalStateT (fromConstrM (do key:next <- get- put next- value <- lift (lookupField obj (Text.pack key))- lift (rec value))- cons)- fields+makeRecord rec obj cons =+ evalStateT $+ fromConstrM+ (do ~(key:next) <- get+ put next+ value <- lift (lookupField obj (Text.pack key))+ lift $ rec value)+ cons lookupField :: HashMap Text Value -> Text -> Either String Value lookupField obj key =
+ src/Fay/Runtime.hs view
@@ -0,0 +1,842 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE QuasiQuotes #-}++module Fay.Runtime where++import Text.Shakespeare.Text+import Data.Text.Lazy as T+import Fay.Config++-- | Get the default runtime source.+getRuntimeSource :: Config -> String+getRuntimeSource cfg =+ let ifTs :: T.Text -> T.Text+ ifTs a = if configTypeScript cfg then a else ""+ ifTsJs :: T.Text -> T.Text -> T.Text+ ifTsJs a b = if configTypeScript cfg then a else b+ in T.unpack [lt|+/*******************************************************************************+ * Misc.+ */+#{ifTs "var Fay:{[key:string]: any;} = {};"}++// Workaround for missing functionality in IE 8 and earlier.+if( Object.create === undefined ) {+ Object.create = function( o ) {+ function F(){}+ F.prototype = o;+ return new F();+ };+}++// Insert properties of b in place into a.+function Fay$$objConcat(a,b){+ for (var p in b) if (b.hasOwnProperty(p)){+ a[p] = b[p];+ }+ return a;+}++/*******************************************************************************+ * Thunks.+ */++// Force a thunk (if it is a thunk) until WHNF.+function Fay$$_(thunkish,nocache#{ifTs "?: boolean"}){+ while (thunkish instanceof Fay$$$) {+ thunkish = thunkish.force(nocache);+ }+ return thunkish;+}++// Apply a function to arguments (see method2 in Fay.hs).+function Fay$$__(){+ var f = arguments[0];+ for (var i = 1, len = arguments.length; i < len; i++) {+ f = (f instanceof Fay$$$? Fay$$_(f) : f)(arguments[i]);+ }+ return f;+}++// Thunk object.+function Fay$$$(value){+ this.forced = false;+ this.value = value;+}++// Force the thunk.+Fay$$$.prototype.force = function(nocache) {+ return nocache ?+ this.value() :+ (this.forced ?+ this.value :+ (this.value = this.value(), this.forced = true, this.value));+};+++function Fay$$seq(x) {+ return function(y) {+ Fay$$_(x,false);+ return y;+ }+}++function Fay$$seq$36$uncurried(x,y) {+ Fay$$_(x,false);+ return y;+}++/*******************************************************************************+ * Monad.+ */++function Fay$$Monad(value){+ this.value = value;+}++// This is used directly from Fay, but can be rebound or shadowed. See primOps in Types.hs.+// >>+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; });+}++// >>=+// 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 Fay$$$(function(){+ var monad = Fay$$_(m,true);+ return Fay$$_(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 Fay$$$(function(){+ var monad = Fay$$_(m,true);+ return Fay$$_(f)(monad.value);+ });+}++// This is used directly from Fay, but can be rebound or shadowed.+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 Fay$$$(function(){+ Fay$$_(thunk,type);+ return new Fay$$Monad(Fay$$unit);+ })+ }+}++// This is used directly from Fay, but can be rebound or shadowed.+function Fay$$return$36$uncurried(a){+ return new Fay$$Monad(a);+}++// Unit: ().+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;+ if(base == "action") {+ // A nullary monadic action. Should become a nullary JS function.+ // Fay () -> function(){ return ... }+ return function(){+ return Fay$$fayToJs(args[0],Fay$$_(fayObj,true).value);+ };++ }+ else if(base == "function") {+ // A proper function.+ return 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 = Fay$$_(fayFunc,true);+ // TODO: Perhaps we should throw an error when JS+ // passes more arguments than Haskell accepts.++ // Unserialize the JS values to Fay for the Fay callback.+ if (args == "automatic_function")+ {+ for (var i = 0; i < arguments.length; i++) {+ fayFunc = Fay$$_(fayFunc(Fay$$jsToFay(["automatic"],arguments[i])),true);+ }+ return Fay$$fayToJs(["automatic"], fayFunc);+ }++ for (var i = 0, len = len; i < len - 1 && fayFunc instanceof Function; i++) {+ fayFunc = Fay$$_(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?");+ }+ };++ }+ else if(base == "string") {+ return Fay$$fayToJs_string(fayObj);+ }+ else if(base == "list") {+ // Serialize Fay list to JavaScript array.+ var arr = [];+ fayObj = Fay$$_(fayObj);+ while(fayObj instanceof Fay$$Cons) {+ arr.push(Fay$$fayToJs(args[0],fayObj.car));+ fayObj = Fay$$_(fayObj.cdr);+ }+ return arr;+ }+ else if(base == "tuple") {+ // Serialize Fay tuple to JavaScript array.+ var arr = [];+ fayObj = Fay$$_(fayObj);+ var i = 0;+ while(fayObj instanceof Fay$$Cons) {+ arr.push(Fay$$fayToJs(args[i++],fayObj.car));+ fayObj = Fay$$_(fayObj.cdr);+ }+ return arr;+ }+ else if(base == "defined") {+ fayObj = Fay$$_(fayObj);+ return fayObj instanceof Fay.FFI._Undefined+ ? undefined+ : Fay$$fayToJs(args[0],fayObj.slot1);+ }+ else if(base == "nullable") {+ fayObj = Fay$$_(fayObj);+ return fayObj instanceof Fay.FFI._Null+ ? null+ : Fay$$fayToJs(args[0],fayObj.slot1);+ }+ else if(base == "double" || base == "int" || base == "bool") {+ // Bools are unboxed.+ return Fay$$_(fayObj);+ }+ else if(base == "ptr")+ return fayObj;+ else if(base == "unknown")+ return Fay$$fayToJs(["automatic"], fayObj);+ else if(base == "automatic" && fayObj instanceof Function) {+ return Fay$$fayToJs(["function", "automatic_function"], fayObj);+ }+ else if(base == "automatic" || base == "user") {+ fayObj = Fay$$_(fayObj);++ if(fayObj instanceof Fay$$Cons || fayObj === null){+ // Serialize Fay list to JavaScript array.+ var arr = [];+ while(fayObj instanceof Fay$$Cons) {+ arr.push(Fay$$fayToJs(["automatic"],fayObj.car));+ fayObj = Fay$$_(fayObj.cdr);+ }+ return arr;+ } else {+ var fayToJsFun = fayObj && fayObj.instance && Fay$$fayToJsHash[fayObj.instance];+ return fayToJsFun ? fayToJsFun(type,type[2],fayObj) : fayObj;+ }+ }++ throw new Error("Unhandled Fay->JS translation type: " + base);+}++// Stores the mappings from fay types to js objects.+// This will be populated by compiled modules.+var Fay$$fayToJsHash = {};++// Specialized serializer for string.+function Fay$$fayToJs_string(fayObj){+ // Serialize Fay string to JavaScript string.+ var str = "";+ fayObj = Fay$$_(fayObj);+ while(fayObj instanceof Fay$$Cons) {+ str += Fay$$_(fayObj.car);+ fayObj = Fay$$_(fayObj.cdr);+ }+ return str;+};+function Fay$$jsToFay_string(x){+ return Fay$$list(x)+};++// Special num/bool serializers.+function Fay$$jsToFay_int(x){return x;}+function Fay$$jsToFay_double(x){return x;}+function Fay$$jsToFay_bool(x){return x;}++function Fay$$fayToJs_int(x){return Fay$$_(x);}+function Fay$$fayToJs_double(x){return Fay$$_(x);}+function Fay$$fayToJs_bool(x){return Fay$$_(x);}++// Unserialize an object from JS to Fay.+function Fay$$jsToFay(type,jsObj){+ var base = type[0];+ var args = type[1];+ var fayObj;+ if(base == "action") {+ // Unserialize a "monadic" JavaScript return value into a monadic value.+ return new Fay$$Monad(Fay$$jsToFay(args[0],jsObj));+ }+ else if(base == "function") {+ // Unserialize a function from JavaScript to a function that Fay can call.+ // So+ //+ // var f = function(x,y,z){ … }+ //+ // becomes something like:+ //+ // function(x){+ // return function(y){+ // return function(z){+ // return new Fay$$$(function(){+ // return Fay$$jsToFay(f(Fay$$fayTojs(x),+ // Fay$$fayTojs(y),+ // Fay$$fayTojs(z))+ // }}}}};+ var returnType = args[args.length-1];+ var funArgs = args.slice(0,-1);++ if (jsObj.length > 0) {+ var makePartial = function(args){+ return function(arg){+ var i = args.length;+ var fayArg = Fay$$fayToJs(funArgs[i],arg);+ var newArgs = args.concat([fayArg]);+ if(newArgs.length == funArgs.length) {+ return new Fay$$$(function(){+ return Fay$$jsToFay(returnType,jsObj.apply(this,newArgs));+ });+ } else {+ return makePartial(newArgs);+ }+ };+ };+ return makePartial([]);+ }+ else+ return function (arg) {+ return Fay$$jsToFay(["automatic"], jsObj(Fay$$fayToJs(["automatic"], arg)));+ };+ }+ else if(base == "string") {+ // Unserialize a JS string into Fay list (String).+ // This is a special case, when String is explicit in the type signature,+ // with `Automatic' a string would not be decoded.+ return Fay$$list(jsObj);+ }+ else if(base == "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.+ return Fay$$list(serializedList);+ }+ else if(base == "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.+ return Fay$$list(serializedTuple);+ }+ else if(base == "defined") {+ return jsObj === undefined+ ? new Fay.FFI._Undefined()+ : new Fay.FFI._Defined(Fay$$jsToFay(args[0],jsObj));+ }+ else if(base == "nullable") {+ return jsObj === null+ ? new Fay.FFI._Null()+ : new Fay.FFI.Nullable(Fay$$jsToFay(args[0],jsObj));+ }+ else if(base == "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!";+ return fayObj;+ }+ else if (base == "double" ||+ base == "bool" ||+ base == "ptr") {+ return jsObj;+ }+ else if(base == "unknown")+ return Fay$$jsToFay(["automatic"], jsObj);+ else if(base == "automatic" && jsObj instanceof Function) {+ #{ifTsJs "let type: string[][]" "var type"} = [["automatic"]];+ for (var i = 0; i < jsObj.length; i++)+ type.push(["automatic"]);+ return Fay$$jsToFay(["function", type], jsObj);+ }+ else if(base == "automatic" && jsObj instanceof Array) {+ var list = null;+ for (var i = jsObj.length - 1; i >= 0; i--) {+ list = new Fay$$Cons(Fay$$jsToFay([base], jsObj[i]), list);+ }+ return list;+ }+ else if(base == "automatic" || base == "user") {+ if (jsObj && jsObj['instance']) {+ var jsToFayFun = Fay$$jsToFayHash[jsObj["instance"]];+ return jsToFayFun ? jsToFayFun(type,type[2],jsObj) : jsObj;+ }+ else+ return jsObj;+ }++ throw new Error("Unhandled JS->Fay translation type: " + base);+}++// Stores the mappings from js objects to fay types.+// This will be populated by compiled modules.+var Fay$$jsToFayHash = {};++/*******************************************************************************+ * 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.+// `list' is already forced by the time it's passed to this function.+// `list' cannot be null and `index' cannot be out of bounds.+function Fay$$index(index,list){+ for(var i = 0; i < index; i++) {+ list = Fay$$_(list.cdr);+ }+ return list.car;+}++// List length.+// `list' is already forced by the time it's passed to this function.+function Fay$$listLen(list,max){+ for(var i = 0; list !== null && i < max + 1; i++) {+ list = Fay$$_(list.cdr);+ }+ return i == max;+}++/*******************************************************************************+ * Numbers.+ */++// Built-in *.+function Fay$$mult(x){+ return function(y){+ return new Fay$$$(function(){+ return Fay$$_(x) * Fay$$_(y);+ });+ };+}++function Fay$$mult$36$uncurried(x,y){++ return new Fay$$$(function(){+ return Fay$$_(x) * Fay$$_(y);+ });++}++// Built-in +.+function Fay$$add(x){+ return function(y){+ return new Fay$$$(function(){+ return Fay$$_(x) + Fay$$_(y);+ });+ };+}++// Built-in +.+function Fay$$add$36$uncurried(x,y){++ return new Fay$$$(function(){+ return Fay$$_(x) + Fay$$_(y);+ });++}++// Built-in -.+function Fay$$sub(x){+ return function(y){+ return new Fay$$$(function(){+ return Fay$$_(x) - Fay$$_(y);+ });+ };+}+// Built-in -.+function Fay$$sub$36$uncurried(x,y){++ return new Fay$$$(function(){+ return Fay$$_(x) - Fay$$_(y);+ });++}++// Built-in /.+function Fay$$divi(x){+ return function(y){+ return new Fay$$$(function(){+ return Fay$$_(x) / Fay$$_(y);+ });+ };+}++// Built-in /.+function Fay$$divi$36$uncurried(x,y){++ return new Fay$$$(function(){+ return Fay$$_(x) / Fay$$_(y);+ });++}++/*******************************************************************************+ * Booleans.+ */++// Are two values equal?+function Fay$$equal(lit1, lit2) {+ // Simple case+ lit1 = Fay$$_(lit1);+ lit2 = Fay$$_(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 = Fay$$_(lit1.cdr), lit2 = Fay$$_(lit2.cdr);+ if (lit1 === null || lit2 === null)+ return lit1 === lit2;+ } while (true);+ } else if (typeof lit1 == 'object' && typeof lit2 == 'object' && lit1 && lit2 &&+ lit1.instance === lit2.instance) {+ for(var x in lit1) {+ if(!Fay$$equal(lit1[x],lit2[x]))+ return false;+ }+ return true;+ } else {+ return false;+ }+}++// Built-in ==.+function Fay$$eq(x){+ return function(y){+ return new Fay$$$(function(){+ return Fay$$equal(x,y);+ });+ };+}++function Fay$$eq$36$uncurried(x,y){++ return new Fay$$$(function(){+ return Fay$$equal(x,y);+ });++}++// Built-in /=.+function Fay$$neq(x){+ return function(y){+ return new Fay$$$(function(){+ return !(Fay$$equal(x,y));+ });+ };+}++// Built-in /=.+function Fay$$neq$36$uncurried(x,y){++ return new Fay$$$(function(){+ return !(Fay$$equal(x,y));+ });++}++// Built-in >.+function Fay$$gt(x){+ return function(y){+ return new Fay$$$(function(){+ return Fay$$_(x) > Fay$$_(y);+ });+ };+}++// Built-in >.+function Fay$$gt$36$uncurried(x,y){++ return new Fay$$$(function(){+ return Fay$$_(x) > Fay$$_(y);+ });++}++// Built-in <.+function Fay$$lt(x){+ return function(y){+ return new Fay$$$(function(){+ return Fay$$_(x) < Fay$$_(y);+ });+ };+}+++// Built-in <.+function Fay$$lt$36$uncurried(x,y){++ return new Fay$$$(function(){+ return Fay$$_(x) < Fay$$_(y);+ });++}+++// Built-in >=.+function Fay$$gte(x){+ return function(y){+ return new Fay$$$(function(){+ return Fay$$_(x) >= Fay$$_(y);+ });+ };+}++// Built-in >=.+function Fay$$gte$36$uncurried(x,y){++ return new Fay$$$(function(){+ return Fay$$_(x) >= Fay$$_(y);+ });++}++// Built-in <=.+function Fay$$lte(x){+ return function(y){+ return new Fay$$$(function(){+ return Fay$$_(x) <= Fay$$_(y);+ });+ };+}++// Built-in <=.+function Fay$$lte$36$uncurried(x,y){++ return new Fay$$$(function(){+ return Fay$$_(x) <= Fay$$_(y);+ });++}++// Built-in &&.+function Fay$$and(x){+ return function(y){+ return new Fay$$$(function(){+ return Fay$$_(x) && Fay$$_(y);+ });+ };+}++// Built-in &&.+function Fay$$and$36$uncurried(x,y){++ return new Fay$$$(function(){+ return Fay$$_(x) && Fay$$_(y);+ });+ ;+}++// Built-in ||.+function Fay$$or(x){+ return function(y){+ return new Fay$$$(function(){+ return Fay$$_(x) || Fay$$_(y);+ });+ };+}++// Built-in ||.+function Fay$$or$36$uncurried(x,y){++ return new Fay$$$(function(){+ return Fay$$_(x) || Fay$$_(y);+ });++}++/*******************************************************************************+ * Mutable references.+ */++// Make a new mutable reference.+function Fay$$Ref(x){+ this.value = x;+}++// Write to the ref.+function Fay$$writeRef(ref,x){+ ref.value = x;+}++// Get the value from the ref.+function Fay$$readRef(ref){+ return ref.value;+}++/*******************************************************************************+ * Dates.+ */+function Fay$$date(str){+ return Date.parse(str);+}++/*******************************************************************************+ * Data.Var+ */++function Fay$$Ref2(val){+ this.val = val;+}++function Fay$$Sig(){+ this.handlers = [];+}++function Fay$$Var(val){+ this.val = val;+ this.handlers = [];+}++// Helper used by Fay$$setValue and for merging+function Fay$$broadcastInternal(self, val, force){+ var handlers = self.handlers;+ var exceptions = [];+ for(#{ifTsJs "let" "var"} len = handlers.length, i = 0; i < len; i++) {+ try {+ force(handlers[i][1](val), true);+ } catch (e) {+ exceptions.push(e);+ }+ }+ // Rethrow the encountered exceptions.+ if (exceptions.length > 0) {+ console.error("Encountered " + exceptions.length + " exception(s) while broadcasing a change to ", self);+ for(#{ifTsJs "let len: number" "var len"} = exceptions.length, i = 0; i < len; i++) {+ (function(exception) {+ setTimeout(function() { throw exception; }, 0);+ })(exceptions[i]);+ }+ }+}++function Fay$$setValue(self, val, force){+ if (self instanceof Fay$$Ref2) {+ self.val = val;+ } else if (self instanceof Fay$$Var) {+ self.val = val;+ Fay$$broadcastInternal(self, val, force);+ } else if (self instanceof Fay$$Sig) {+ Fay$$broadcastInternal(self, val, force);+ } else {+ throw "Fay$$setValue given something that's not a Ref2, Var, or Sig"+ }+}++function Fay$$subscribe(self, f){+ var key = {};+ self.handlers.push([key,f]);+ var searchStart = self.handlers.length - 1;+ return function(_){+ for(var i = Math.min(searchStart, self.handlers.length - 1); i >= 0; i--) {+ if(self.handlers[i][0] == key) {+ self.handlers = self.handlers.slice(0,i).concat(self.handlers.slice(i+1));+ return;+ }+ }+ return _; // This variable has to be used, otherwise Closure+ // strips it out and Fay serialization breaks.+ };+}++/*******************************************************************************+ * Application code.+ */++|]
src/Fay/Types.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TypeFamilies #-} -- | All Fay types and instances.@@ -40,6 +41,8 @@ , mkModulePathFromQName ) where +import Fay.Compiler.Prelude+ import Fay.Compiler.ModuleT import Fay.Config import qualified Fay.Exts.NoAnnotation as N@@ -56,10 +59,11 @@ #endif import Control.Monad.Except (ExceptT, MonadError) import Control.Monad.Identity (Identity)-import Control.Monad.RWS+import Control.Monad.RWS (MonadIO, MonadReader, MonadState, MonadWriter, RWST, lift) import Data.Map (Map) import Data.Set (Set) import Language.Haskell.Names (Symbols)+import Data.Semigroup (Semigroup) -------------------------------------------------------------------------------- -- Compiler types@@ -87,10 +91,14 @@ } deriving (Show) -- | Simple concatenating instance.+instance Semigroup CompileWriter where+ (CompileWriter a b c) <> (CompileWriter x y z) =+ CompileWriter (a++x) (b++y) (c++z)++-- | Simple concatenating instance. instance Monoid CompileWriter where mempty = CompileWriter [] [] []- mappend (CompileWriter a b c) (CompileWriter x y z) =- CompileWriter (a++x) (b++y) (c++z)+ mappend = (<>) -- | Configuration and globals for the compiler. data CompileReader = CompileReader
src/Fay/Types/CompileError.hs view
@@ -37,3 +37,4 @@ | UnsupportedWhereInAlt S.Alt | UnsupportedWhereInMatch S.Match deriving (Show)+{-# ANN module "HLint: ignore Use camelCase" #-}
src/Fay/Types/Js.hs view
@@ -16,6 +16,7 @@ -- | Statement type. data JsStmt = JsVar JsName JsExp+ | JsMapVar JsName JsExp | JsIf JsExp [JsStmt] [JsStmt] | JsEarlyReturn JsExp | JsThrow JsExp
src/Fay/Types/Printer.hs view
@@ -16,11 +16,15 @@ , mapping ) where -import Control.Monad.RWS+import Fay.Compiler.Prelude++import Control.Monad.RWS (RWS, asks, execRWS, get, modify, put, tell) import Data.List (elemIndex)+import Data.Maybe (fromMaybe) import Data.String import Language.Haskell.Exts import SourceMap.Types+import qualified Data.Semigroup as SG -- | Global options of the printer data PrintReader = PrintReader@@ -42,10 +46,13 @@ pwOutputString :: PrintWriter -> String pwOutputString (PrintWriter _ out) = out "" +instance SG.Semigroup PrintWriter where+ (PrintWriter a b) <> (PrintWriter x y) = PrintWriter (a ++ x) (b . y)+ -- | Output concatenation instance Monoid PrintWriter where mempty = PrintWriter [] id- mappend (PrintWriter a b) (PrintWriter x y) = PrintWriter (a ++ x) (b . y)+ mappend = (<>) -- | The state of the pretty printer. data PrintState = PrintState@@ -66,10 +73,12 @@ execPrinter :: Printer -> PrintReader -> PrintWriter execPrinter (Printer p) r = snd $ execRWS p r defaultPrintState +instance SG.Semigroup Printer where+ (Printer p) <> (Printer q) = Printer (p >> q) instance Monoid Printer where mempty = Printer $ return ()- mappend (Printer p) (Printer q) = Printer (p >> q)+ mappend = (<>) -- | Print some value. class Printable a where@@ -85,7 +94,7 @@ -- Does nothing when prPretty is False newline :: Printer newline = Printer $ asks prPretty >>= flip when writeNewline- where writeNewline = (writeRWS "\n" >> modify (\s -> s {psNewline = True}))+ where writeNewline = writeRWS "\n" >> modify (\s -> s { psNewline = True }) -- | Write out a raw string, respecting the indentation -- Note: if you pass a string with newline characters, it will print them@@ -106,9 +115,7 @@ let newLines = length (filter (== '\n') x) put ps { psLine = psLine ps + newLines- , psColumn = case elemIndex '\n' (reverse x) of- Just i -> i- Nothing -> psColumn ps + length x+ , psColumn = fromMaybe (psColumn ps + length x) . elemIndex '\n' $ reverse x , psNewline = False }
src/haskell-names/Language/Haskell/Names/GetBound.hs view
@@ -79,7 +79,7 @@ getBound ctx (QualConDecl _ _ _ d) = getBound ctx d instance (Data l) => GetBound (GadtDecl l) l where- getBound _ctx (GadtDecl _l conName mbFieldDecls _ty) =+ getBound _ctx (GadtDecl _l conName _tyvarBinds _context mbFieldDecls _ty) = -- GADT constructor name [conName] ++ -- GADT selector names
src/haskell-names/Language/Haskell/Names/GlobalSymbolTable.hs view
@@ -1,5 +1,6 @@ {-# OPTIONS -fno-warn-name-shadowing #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE NoImplicitPrelude #-} -- | This module is designed to be imported qualified. module Language.Haskell.Names.GlobalSymbolTable ( Table@@ -21,6 +22,7 @@ import qualified Data.Map as Map import qualified Data.Set as Set import Language.Haskell.Exts as HSE+import Data.Semigroup (Semigroup) -- | Global symbol table — contains global names data Table =@@ -35,9 +37,8 @@ tyLens :: Lens Table (Map.Map GName (Set.Set (SymTypeInfo OrigName))) tyLens = lens (\(Table _ ts) -> ts) (\ts (Table vs _) -> Table vs ts) -instance Monoid Table where- mempty = empty- mappend (Table vs1 ts1) (Table vs2 ts2) =+instance Semigroup Table where+ (Table vs1 ts1) <> (Table vs2 ts2) = Table (j vs1 vs2) (j ts1 ts2) where j :: (Ord i, Ord k)@@ -45,6 +46,9 @@ -> Map.Map k (Set.Set i) -> Map.Map k (Set.Set i) j = Map.unionWith Set.union+instance Monoid Table where+ mempty = empty+ mappend = (<>) toGName :: QName l -> GName toGName (UnQual _ n) = GName "" (nameToString n)
src/haskell-names/Language/Haskell/Names/Imports.hs view
@@ -189,8 +189,6 @@ (ENotExported Nothing n mod) matches spec- IAbs _ (TypeNamespace {}) _ -> error "'type' namespace is not supported yet" -- FIXME- -- FIXME -- What about things like: -- head(..)
src/haskell-names/Language/Haskell/Names/LocalSymbolTable.hs view
@@ -14,10 +14,11 @@ import qualified Data.Map as Map import Language.Haskell.Exts+import Data.Semigroup () -- | Local symbol table — contains locally bound names newtype Table = Table (Map.Map NameS SrcLoc)- deriving Monoid+ deriving Semigroup addValue :: SrcInfo l => Name l -> Table -> Table addValue n (Table vs) =
src/haskell-names/Language/Haskell/Names/ModuleSymbols.hs view
@@ -1,4 +1,5 @@ {-# OPTIONS -fno-warn-name-shadowing #-}+{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} module Language.Haskell.Names.ModuleSymbols@@ -7,6 +8,8 @@ ) where +import Fay.Compiler.Prelude+ import Language.Haskell.Exts import Language.Haskell.Names.GetBound import qualified Language.Haskell.Names.GlobalSymbolTable as Global@@ -14,13 +17,8 @@ import Language.Haskell.Names.SyntaxUtils import Language.Haskell.Names.Types -import Control.Monad-import Data.Data-import Data.Either import Data.Lens.Light import qualified Data.Map as Map-import Data.Maybe-import Data.Monoid import qualified Data.Set as Set -- | Compute module's global table. It contains both the imported entities@@ -103,7 +101,7 @@ cons :: Constructors cons = do -- list monad- GadtDecl _ cn (fromMaybe [] -> fields) _ty <- gadtDecls+ GadtDecl _ cn _tyvarBinds _context (fromMaybe [] -> fields) _ty <- gadtDecls return (void cn , [void f | FieldDecl _ fNames _ <- fields, f <- fNames]) infos = constructorsToInfos dq cons
src/haskell-names/Language/Haskell/Names/Open/Derived.hs view
@@ -47,7 +47,6 @@ deriveGTraversable ''GuardedRhs deriveGTraversable ''Type deriveGTraversable ''TyVarBind-deriveGTraversable ''Kind deriveGTraversable ''FunDep deriveGTraversable ''Context deriveGTraversable ''Asst@@ -85,3 +84,5 @@ deriveGTraversable ''Unpackedness deriveGTraversable ''ResultSig deriveGTraversable ''InjectivityInfo+deriveGTraversable ''DerivStrategy+deriveGTraversable ''MaybePromotedName
src/haskell-names/Language/Haskell/Names/Recursive.hs view
@@ -1,4 +1,5 @@ {-# OPTIONS -fno-warn-name-shadowing #-}+{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} module Language.Haskell.Names.Recursive@@ -7,6 +8,8 @@ , annotateModule ) where +import Fay.Compiler.Prelude+ import Fay.Compiler.ModuleT import Language.Haskell.Names.Annotated import Language.Haskell.Names.Exports@@ -17,12 +20,9 @@ import Language.Haskell.Names.SyntaxUtils import Language.Haskell.Names.Types -import Control.Monad hiding (forM_) import Data.Data (Data) import Data.Foldable import Data.Graph (flattenSCC, stronglyConnComp)-import Data.Maybe-import Data.Monoid import qualified Data.Set as Set import Language.Haskell.Exts
src/haskell-names/Language/Haskell/Names/SyntaxUtils.hs view
@@ -82,6 +82,7 @@ specialConToString (TupleCon _ Unboxed n) = '#':replicate (n-1) ',' specialConToString (Cons _) = ":" specialConToString (UnboxedSingleCon _) = "#"+specialConToString (ExprHole _) = "_" unCName :: CName l -> Name l unCName (VarName _ n) = n
src/haskell-names/Language/Haskell/Names/Types.hs view
@@ -4,6 +4,7 @@ {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE StandaloneDeriving #-} module Language.Haskell.Names.Types ( Error (..)@@ -36,6 +37,7 @@ import qualified Data.Set as Set import Language.Haskell.Exts import Text.Printf+import qualified Data.Semigroup as SG type ExtensionSet = Set.Set KnownExtension @@ -118,10 +120,13 @@ data Symbols = Symbols (Set.Set (SymValueInfo OrigName)) (Set.Set (SymTypeInfo OrigName)) deriving (Eq, Ord, Show, Data, Typeable) +instance SG.Semigroup Symbols where+ (Symbols s1 t1) <> (Symbols s2 t2) =+ Symbols (s1 <> s2) (t1 <> t2)+ instance Monoid Symbols where mempty = Symbols mempty mempty- mappend (Symbols s1 t1) (Symbols s2 t2) =- Symbols (s1 `mappend` s2) (t1 `mappend` t2)+ mappend = (<>) valSyms :: Lens Symbols (Set.Set (SymValueInfo OrigName)) valSyms = lens (\(Symbols vs _) -> vs) (\vs (Symbols _ ts) -> Symbols vs ts)
src/main/Main.hs view
@@ -49,6 +49,7 @@ , optVersion :: Bool , optWall :: Bool , optShowGhcCalls :: Bool+ , optTypeScript :: Bool , optFiles :: [String] } @@ -81,11 +82,12 @@ , configPrettyThunks = optPrettyThunks opts || optPrettyAll opts , configPrettyOperators = optPrettyOperators opts || optPrettyAll opts , configShowGhcCalls = optShowGhcCalls opts+ , configTypeScript = optTypeScript opts } if optVersion opts then runCommandVersion else if optPrintRuntime opts- then getConfigRuntime config >>= readFile >>= putStr+ then readConfigRuntime config >>= putStr else do void $ incompatible htmlAndStdout opts "Html wrapping and stdout are incompatible" case optFiles opts of@@ -97,7 +99,7 @@ parser = info (helper <*> options) (fullDesc <> header helpTxt) outPutFile :: FayCompilerOptions -> String -> FilePath- outPutFile opts file = fromMaybe (toJsName file) $ optOutput opts+ outPutFile opts file = fromMaybe (if optTypeScript opts then toTsName file else toJsName file) $ optOutput opts -- | All Fay's command-line options. options :: Parser FayCompilerOptions@@ -135,6 +137,7 @@ <*> switch (long "version" <> help "Output version number") <*> switch (long "Wall" <> help "Typecheck with -Wall") <*> switch (long "show-ghc-calls" <> help "Print commands sent to ghc")+ <*> switch (long "ts" <> help "Output TypeScript instead of JavaScript") <*> many (argument (ReadM ask) (metavar "<hs-file>...")) where strsOption :: Mod OptionFields [String] -> Parser [String]@@ -150,10 +153,9 @@ -- | The basic help text. helpTxt :: String-helpTxt = concat- ["fay -- The fay compiler from (a proper subset of) Haskell to Javascript\n\n"- ," fay <hs-file>... processes each .hs file"- ]+helpTxt+ = "fay -- The fay compiler from (a proper subset of) Haskell to Javascript\n\n"+ ++ " fay <hs-file>... processes each .hs file" -- | Print the command version. runCommandVersion :: IO ()
src/tests/Test/Compile.hs view
@@ -3,13 +3,10 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} -module Test.Compile (tests) where+module Test.Compile (tests,runScriptFile) where import Fay import Fay.Compiler.Prelude-#if !MIN_VERSION_base(4,7,0)-import Test.Util (isRight)-#endif import Language.Haskell.Exts import Test.Tasty@@ -87,24 +84,29 @@ case_strictWrapper = do cfg <- defConf res <- compileFile cfg { configTypecheck = True, configFilePath = Just "tests/Compile/StrictWrapper.hs", configStrict = ["StrictWrapper"] } "tests/Compile/StrictWrapper.hs"+ let isTs = configTypeScript cfg+ suffix = if isTs then ".ts" else ".js" (\a b -> either a b res) (assertFailure . show) $ \js -> do- writeFile "tests/Compile/StrictWrapper.js" js- (err, out) <- either id id <$> readAllFromProcess "node" ["tests/Compile/StrictWrapper.js"] ""+ writeFile ("tests/Compile/StrictWrapper" ++ suffix) js+ (err, out) <- either id id <$> runScriptFile isTs ("tests/Compile/StrictWrapper" ++ suffix) when (err /= "") $ assertFailure err expected <- readFile "tests/Compile/StrictWrapper.res" assertEqual "strictWrapper node stdout" expected out assertPretty :: Config -> String -> Assertion assertPretty cfg flagName = do+ let isTs = configTypeScript cfg+ suffix = if isTs then ".ts" else ".js" res <- compileFile cfg $ "tests/Compile/" ++ flagName ++ ".hs" case res of Left l -> assertFailure $ "Should compile, but failed with: " ++ show l Right js -> do- writeFile ("tests/Compile/" ++ flagName ++ ".js") js- (err, out) <- either id id <$> readAllFromProcess "node" ["tests/Compile/" ++ flagName ++ ".js"] ""- when (err /= "") $ assertFailure err- expected <- readFile $ "tests/Compile/" ++ flagName ++ ".res"- assertEqual (flagName ++ " node stdout") expected out+ writeFile ("tests/Compile/" ++ flagName ++ suffix) js+ (err, out) <- either id id <$> runScriptFile isTs+ ("tests/Compile/" ++ flagName ++ suffix)+ when (err /= "") $ assertFailure err+ expected <- readFile $ "tests/Compile/" ++ flagName ++ ".res"+ assertEqual (flagName ++ " node stdout") expected out case_pretty :: Assertion case_pretty = do@@ -134,3 +136,15 @@ defConf = do cfg <- defaultConfigWithSandbox return $ addConfigDirectoryIncludePaths ["tests/"] cfg { configTypecheck = False }++-- | Run a JS or TS file.+runScriptFile :: Bool -- ^ If a file-format is TypeScript, this is True.+ -> String -- ^ A name of script file+ -> IO (Either (String,String) (String,String))+runScriptFile True file = do+ tsc_ret <- readAllFromProcess "tsc" [file] ""+ case tsc_ret of+ Left _ -> return tsc_ret+ Right _ -> readAllFromProcess "node" [(reverse (drop 3 (reverse file))) ++ ".js" ] ""++runScriptFile False file = readAllFromProcess "node" [file] ""
src/tests/Test/Desugar.hs view
@@ -13,7 +13,7 @@ import Fay.Compiler.Parse (parseFay) import Fay.Types.CompileError (CompileError (..)) -import Language.Haskell.Exts hiding (alt, binds, loc, name)+import Language.Haskell.Exts hiding (name) import Test.Tasty import Test.Tasty.HUnit -- import Text.Groom@@ -95,7 +95,7 @@ case parseFay "test" s :: ParseResult (Module SrcSpanInfo) of ParseFailed a b -> error $ show (name, a, b) ParseOk (fmap srcSpanInfoToSrcLoc -> m) -> do- d <- desugar' "gen" noLoc $ m+ d <- desugar' "gen" noLoc m return (m, d) where srcSpanInfoToSrcLoc :: SrcSpanInfo -> SrcLoc@@ -147,7 +147,7 @@ when (unAnn desugaredExpected /= unAnn originalExpected ) $ putStrLn "desugaredExpected /= undesugared" g :: Show a => a -> IO ()-g = putStrLn . show -- groom+g = print -- putStrLn . groom unAnn :: Functor f => f a -> f () unAnn = void
src/tests/Tests.hs view
@@ -33,8 +33,11 @@ (packageConf,args) <- prefixed (== "-package-conf") <$> getArgs let (basePath,args') = prefixed (== "-base-path" ) args let (testCount, args'') = first (readMay =<<) $ prefixed (== "-random") args'- (runtime,codegen) <- makeCompilerTests (packageConf <|> sandbox) basePath testCount- withArgs args'' $ defaultMain $ testGroup "Fay"+ let (isTs, args''') = case args'' of+ ("-ts":xs) -> (True,xs)+ _ -> (False,args'')+ (runtime,codegen) <- makeCompilerTests (packageConf <|> sandbox) basePath testCount isTs+ withArgs args''' $ defaultMain $ testGroup "Fay" [ Desugar.tests , Convert.tests , codegen@@ -48,19 +51,19 @@ prefixed f (break f -> (x,y)) = (listToMaybe (drop 1 y),x ++ drop 2 y) -- | Make the case-by-case unit tests.-makeCompilerTests :: Maybe FilePath -> Maybe FilePath -> Maybe Int -> IO (TestTree,TestTree)-makeCompilerTests packageConf basePath rand = do+makeCompilerTests :: Maybe FilePath -> Maybe FilePath -> Maybe Int -> Bool -> IO (TestTree,TestTree)+makeCompilerTests packageConf basePath rand isTs = do runtimeFiles' <- runtimeTestFiles runtimeFiles <- maybe (return runtimeFiles') (randomize runtimeFiles') rand codegenFiles <- codegenTestFiles return- (makeTestGroup "Runtime tests"- runtimeFiles- (\file -> do testFile packageConf basePath False file- testFile packageConf basePath True file)- ,makeTestGroup "Codegen tests"- codegenFiles- (\file -> testCodegen packageConf basePath file))+ ( makeTestGroup "Runtime tests"+ runtimeFiles+ (\file -> do testFile packageConf basePath False isTs file+ testFile packageConf basePath True isTs file)+ , makeTestGroup "Codegen tests"+ codegenFiles+ (testCodegen packageConf basePath isTs)) where makeTestGroup title files inner = testGroup title $ flip map files $ \file ->@@ -86,11 +89,18 @@ then return s' else randomizeAux (S.insert i s) count b -testFile :: Maybe FilePath -> Maybe FilePath -> Bool -> String -> IO ()-testFile packageConf basePath opt file = do- let root = (reverse . drop 1 . dropWhile (/='.') . reverse) file- out = toJsName file- resf = root <.> "res"+fns :: Bool -> String -> (String, String, FilePath)+fns isTs file =+ ( root+ , if isTs then toTsName file else toJsName file+ , root <.> "res"+ )+ where+ root = reverse . drop 1 . dropWhile (/='.') . reverse $ file++testFile :: Maybe FilePath -> Maybe FilePath -> Bool -> Bool -> String -> IO ()+testFile packageConf basePath opt isTs file = do+ let (root, out, resf) = fns isTs file config = addConfigDirectoryIncludePaths ["tests/"] defaultConfig@@ -98,12 +108,13 @@ , configTypecheck = False , configPackageConf = packageConf , configBasePath = basePath+ , configTypeScript = isTs } resExists <- doesFileExist resf let partialName = root ++ "_partial.res" partialExists <- doesFileExist partialName compileFromTo config file (Just out)- result <- runJavaScriptFile out+ result <- Compile.runScriptFile isTs out if resExists then do output <- readFile resf assertEqual file output (either show snd result)@@ -119,11 +130,9 @@ -- | Test the generated code output for the given file with -- optimizations turned on. This disables runtime generation and -- things like that; it's only concerned with the core of the program.-testCodegen :: Maybe FilePath -> Maybe FilePath -> String -> IO ()-testCodegen packageConf basePath file = do- let root = (reverse . drop 1 . dropWhile (/='.') . reverse) file- out = toJsName file- resf = root <.> "res"+testCodegen :: Maybe FilePath -> Maybe FilePath -> Bool -> String -> IO ()+testCodegen packageConf basePath isTs file = do+ let (_, out, resf) = fns isTs file config = addConfigDirectoryIncludePaths ["tests/codegen/"] defaultConfig@@ -135,14 +144,12 @@ , configPrettyPrint = True , configLibrary = True , configExportRuntime = False+ , configTypeScript = isTs } compileFromTo config file (Just out) actual <- readStripped out- expected <- readStripped resf+ expected <- readStripped $ resf ++ (if isTs then "_ts" else "") assertEqual file expected actual where readStripped = fmap (unlines . filter (not . null) . lines) . readFile --- | Run a JS file.-runJavaScriptFile :: String -> IO (Either (String,String) (String,String))-runJavaScriptFile file = readAllFromProcess "node" [file] ""
tests/Nullable.hs view
@@ -40,4 +40,4 @@ r2 = ffi "{ instance : 'R', slot1 : null }" parseInt :: String -> Nullable Int-parseInt = ffi "(function () { var n = global.parseInt(%1, 10); if (isNaN(n)) return null; return n; })()"+parseInt = ffi "(function () { var n = parseInt(%1, 10); if (isNaN(n)) return null; return n; })()"
− tests/String.hs
@@ -1,3 +0,0 @@-module String where--main = putStrLn "Hello, World!"
− tests/String.res
@@ -1,1 +0,0 @@-Hello, World!
+ tests/Strings.hs view
@@ -0,0 +1,3 @@+module Strings where++main = putStrLn "Hello, World!"
+ tests/Strings.res view
@@ -0,0 +1,1 @@+Hello, World!
tests/WhenUnlessRecursion.hs view
@@ -3,7 +3,7 @@ import FFI getStackSize :: Fay Int-getStackSize = ffi "(Error.stackTraceLimit = Infinity, new Error().stack.split('\\n').length)"+getStackSize = ffi "(Error[\"stackTraceLimit\"] = Infinity, new Error().stack.split('\\n').length)" checkGrowth :: Maybe Int -> Int -> Fay () checkGrowth Nothing _ = return ()