diff --git a/examples/canvas.water.html b/examples/canvas.water.html
new file mode 100644
--- /dev/null
+++ b/examples/canvas.water.html
@@ -0,0 +1,10 @@
+
+
+
+ Canvas demo -- water effect
+
+
+
+
+
+
diff --git a/examples/canvaswater.hs b/examples/canvaswater.hs
new file mode 100644
--- /dev/null
+++ b/examples/canvaswater.hs
@@ -0,0 +1,154 @@
+-- | Compile with: dist/build/fay/fay -autorun examples/canvaswater.hs
+
+{-# LANGUAGE EmptyDataDecls #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+-- | A demonstration of Fay using the canvas element to display a
+-- simple effect.
+
+module CanvasWater (main) where
+
+import Language.Fay.FFI
+import Language.Fay.Prelude
+
+-- | Main entry point.
+main :: Fay ()
+main = do
+ img <- newImage
+ addEventListener img "load" (start img) False
+ setSrc img "haskell.png"
+
+-- | Start the animation.
+start :: Image -> Fay ()
+start img = do
+ canvas <- getElementById "can"
+ context <- getContext canvas "2d"
+ drawImage context img 0 0
+ step <- newRef (0 :: Double)
+ setInterval (animate context img step) 30
+
+-- | Animate the water effect.
+animate :: Context -> Image -> Ref Double -> Fay ()
+animate context img step = do
+ stepn <- readRef step
+ setFillStyle context "rgb(255,255,255)"
+ forM_ [0..imgHeight] $ \i ->
+ drawImageSpecific context img
+ 0 0
+ imgWidth imgHeight
+ (sin(3*(stepn+i/20.0))*(i/2.0)) (140+i)
+ imgWidth imgHeight
+ writeRef step (stepn + 0.05)
+
+imgHeight = 140
+imgWidth = 200
+
+--------------------------------------------------------------------------------
+-- Elements
+
+class Eventable a
+
+-- | A DOM element.
+data Element
+instance Foreign Element
+instance Eventable Element
+
+-- | Add an event listener to an element.
+addEventListener :: (Foreign a,Eventable a) => a -> String -> Fay () -> Bool -> Fay ()
+addEventListener = foreignPropFay "addEventListener" FayNone
+
+-- | Get an element by its ID.
+getElementById :: String -> Fay Element
+getElementById = foreignFay "document.getElementById" FayNone
+
+--------------------------------------------------------------------------------
+-- Images
+
+data Image
+instance Foreign Image
+instance Eventable Image
+
+-- | Make a new image.
+newImage :: Fay Image
+newImage = foreignFay "new Image" FayNone
+
+-- | Make a new image.
+setSrc :: Image -> String -> Fay ()
+setSrc = foreignSetProp "src"
+
+--------------------------------------------------------------------------------
+-- Canvas
+
+-- | A canvas context.
+data Context
+instance Foreign Context
+
+-- | Get an element by its ID.
+getContext :: Element -> String -> Fay Context
+getContext = foreignPropFay "getContext" FayNone
+
+-- | Draw an image onto a canvas rendering context.
+drawImage :: Context -> Image -> Double -> Double -> Fay ()
+drawImage = foreignPropFay "drawImage" FayNone
+
+-- | Draw an image onto a canvas rendering context.
+--
+-- Nine arguments: the element, source (x,y) coordinates, source width and
+-- height (for cropping), destination (x,y) coordinates, and destination width
+-- and height (resize).
+--
+-- context.drawImage(img_elem, sx, sy, sw, sh, dx, dy, dw, dh);
+drawImageSpecific :: Context -> Image
+ -> Double -> Double -> Double -> Double -> Double -> Double -> Double -> Double
+ -> Fay ()
+drawImageSpecific = foreignPropFay "drawImage" FayNone
+
+-- | Set the fill style.
+setFillStyle :: Context -> String -> Fay ()
+setFillStyle = foreignSetProp "fillStyle"
+
+-- | Set the fill style.
+setFillRect :: Context -> Double -> Double -> Double -> Double -> Fay ()
+setFillRect = foreignPropFay "fillRect" FayNone
+
+--------------------------------------------------------------------------------
+-- Ref
+
+-- | A mutable reference like IORef.
+data Ref a
+instance Foreign a => Foreign (Ref a)
+
+-- | Make a new mutable reference.
+newRef :: Foreign a => a -> Fay (Ref a)
+newRef = foreignFay "new Fay$$Ref" FayNone
+
+-- | Replace the value in the mutable reference.
+writeRef :: Foreign a => Ref a -> a -> Fay ()
+writeRef = foreignFay "Fay$$writeRef" FayNone
+
+-- | Get the referred value from the mutable value.
+readRef :: Foreign a => Ref a -> Fay a
+readRef = foreignFay "Fay$$readRef" FayNone
+
+--------------------------------------------------------------------------------
+-- Misc
+
+-- | Alert using window.alert.
+alert :: Foreign a => a -> Fay ()
+alert = foreignFay "window.alert" FayNone
+
+-- | Alert using window.alert.
+print :: Double -> Fay ()
+print = foreignFay "console.log" FayNone
+
+-- | Alert using window.alert.
+log :: String -> Fay ()
+log = foreignFay "console.log" FayNone
+
+-- | Alert using window.alert.
+sin :: Double -> Double
+sin = foreignPure "Math.sin" FayNone
+
+-- | Alert using window.alert.
+setInterval :: Fay () -> Double -> Fay ()
+setInterval = foreignFay "window.setInterval" FayNone
diff --git a/examples/haskell.png b/examples/haskell.png
new file mode 100644
Binary files /dev/null and b/examples/haskell.png differ
diff --git a/fay.cabal b/fay.cabal
--- a/fay.cabal
+++ b/fay.cabal
@@ -1,5 +1,5 @@
name: fay
-version: 0.2.1.0
+version: 0.2.2.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,15 +22,13 @@
.
/Release Notes/
.
- Support setting properties.
- .
- * Support assigning props (closes #10).
+ Some more compilation options.
.
- * Support zero-arg functions i.e. values.
+ * Optional flat function application (-flatten-apps).
.
- * Add node example (closes #15).
+ * Exporting-builtins is optional (-no-export-builtins).
.
- * Add warning in the build script.
+ * The main module is annotated as a Closure \@constructor.
.
See full history at:
homepage: http://fay-lang.org/
@@ -46,7 +44,8 @@
hs/stdlib.hs
src/Language/Fay/Stdlib.hs
extra-source-files: examples/ref.hs examples/alert.hs examples/console.hs examples/dom.hs
- examples/tailrecursive.hs examples/data.hs
+ examples/tailrecursive.hs examples/data.hs examples/canvaswater.hs
+ examples/canvas.water.html examples/haskell.png
-- Test cases
tests/10 tests/10.hs tests/11 tests/11.hs tests/12 tests/12.hs tests/13
tests/13.hs tests/14 tests/14.hs tests/15 tests/15.hs tests/16 tests/16.hs
diff --git a/js/runtime.js b/js/runtime.js
--- a/js/runtime.js
+++ b/js/runtime.js
@@ -13,6 +13,15 @@
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;
diff --git a/src/Language/Fay.hs b/src/Language/Fay.hs
--- a/src/Language/Fay.hs
+++ b/src/Language/Fay.hs
@@ -25,7 +25,7 @@
import Data.Maybe
import Data.String
import Language.Haskell.Exts
--- import System.Process.Extra
+import System.Process.Extra
--------------------------------------------------------------------------------
-- Top level entry points
@@ -74,17 +74,17 @@
(with)
(parse from)
--- printCompile :: (Show from,Show to,CompilesTo from to)
--- => Config
--- -> (from -> Compile to)
--- -> String
--- -> IO ()
--- printCompile config with from = do
--- result <- compileViaStr config with from
--- case result of
--- Left err -> putStrLn $ show err
--- Right ok -> do writeFile "/tmp/x.js" ok
--- prettyPrintFile "/tmp/x.js" >>= putStr
+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 -> putStrLn $ show err
+ Right (ok,_) -> do writeFile "/tmp/x.js" ok
+ prettyPrintFile "/tmp/x.js" >>= putStr
--------------------------------------------------------------------------------
-- Compilers
@@ -403,8 +403,8 @@
expand _ = Nothing
-- -- | Run a JS file.
--- prettyPrintFile :: String -> IO String
--- prettyPrintFile file = fmap (either id id) (readAllFromProcess "js-beautify" file)
+prettyPrintFile :: String -> IO String
+prettyPrintFile file = fmap (either id id) (readAllFromProcess "js-beautify" file)
-- | Compile a right-hand-side expression.
compileRhs :: Rhs -> Compile JsExp
@@ -465,10 +465,31 @@
-- | Compile simple application.
compileApp :: Exp -> Exp -> Compile JsExp
-compileApp exp1 exp2 =
- JsApp <$> (forceFlatName <$> compileExp exp1)
- <*> fmap return (compileExp exp2)
- where forceFlatName name = JsApp (JsName "_") [name]
+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
diff --git a/src/Language/Fay/Compiler.hs b/src/Language/Fay/Compiler.hs
--- a/src/Language/Fay/Compiler.hs
+++ b/src/Language/Fay/Compiler.hs
@@ -40,17 +40,22 @@
Right (jscode,state) -> do
let (ModuleName modulename) = stateModuleName state
exports = stateExports state
- return (Right (unlines ["var " ++ modulename ++ " = function(){"
+ return (Right (unlines ["/** @constructor"
+ ,"*/"
+ ,"var " ++ modulename ++ " = function(){"
,raw
,jscode
,"// Exports"
,unlines (map printExport exports)
,"// Built-ins"
,"this.$force = _;"
- ,"this.$ = $;"
- ,"this.$list = Fay$$list;"
- ,"this.$encodeShow = Fay$$encodeShow;"
- ,"this.$eval = Fay$$eval;"
+ ,if configExportBuiltins config
+ then unlines ["this.$ = $;"
+ ,"this.$list = Fay$$list;"
+ ,"this.$encodeShow = Fay$$encodeShow;"
+ ,"this.$eval = Fay$$eval;"
+ ]
+ else ""
,"};"
,if autorun
then unlines [";"
diff --git a/src/Language/Fay/Types.hs b/src/Language/Fay/Types.hs
--- a/src/Language/Fay/Types.hs
+++ b/src/Language/Fay/Types.hs
@@ -35,13 +35,15 @@
-- | Configuration of the compiler.
data CompileConfig = CompileConfig
- { configTCO :: Bool
- , configInlineForce :: Bool
+ { configTCO :: Bool
+ , configInlineForce :: Bool
+ , configFlattenApps :: Bool
+ , configExportBuiltins :: Bool
} deriving (Show)
-- | Default configuration.
instance Default CompileConfig where
- def = CompileConfig False False
+ def = CompileConfig False False False True
-- | State of the compiler.
data CompileState = CompileState
diff --git a/src/Main.hs b/src/Main.hs
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -21,6 +21,8 @@
forM_ files $ \file -> do
compileFromTo def { configTCO = elem "tco" opts
, configInlineForce = elem "inline-force" opts
+ , configFlattenApps = elem "flatten-apps" opts
+ , configExportBuiltins = not (elem "no-export-builtins" opts)
}
(elem "autorun" opts)
file