fay 0.2.1.0 → 0.2.2.0
raw patch · 9 files changed
+236/−34 lines, 9 filesbinary-addedPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
+ Language.Fay: prettyPrintFile :: String -> IO String
+ Language.Fay: printCompile :: (Show from, Show to, CompilesTo from to) => CompileConfig -> (from -> Compile to) -> String -> IO ()
+ Language.Fay.Types: configExportBuiltins :: CompileConfig -> Bool
+ Language.Fay.Types: configFlattenApps :: CompileConfig -> Bool
- Language.Fay.Types: CompileConfig :: Bool -> Bool -> CompileConfig
+ Language.Fay.Types: CompileConfig :: Bool -> Bool -> Bool -> Bool -> CompileConfig
Files
- examples/canvas.water.html +10/−0
- examples/canvaswater.hs +154/−0
- examples/haskell.png binary
- fay.cabal +7/−8
- js/runtime.js +9/−0
- src/Language/Fay.hs +39/−18
- src/Language/Fay/Compiler.hs +10/−5
- src/Language/Fay/Types.hs +5/−3
- src/Main.hs +2/−0
+ examples/canvas.water.html view
@@ -0,0 +1,10 @@+<!doctype html>+<html>+ <head>+ <title>Canvas demo -- water effect</title> + <script src="canvaswater.js"></script>+ </head>+ <body style="margin:0;padding:0">+ <canvas width="230" height="230" id="can"></canvas>+ </body>+</html>
+ examples/canvaswater.hs view
@@ -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
+ examples/haskell.png view
binary file changed (absent → 5315 bytes)
fay.cabal view
@@ -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: <https://github.com/chrisdone/fay/commits> 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
js/runtime.js view
@@ -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;
src/Language/Fay.hs view
@@ -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
src/Language/Fay/Compiler.hs view
@@ -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 [";"
src/Language/Fay/Types.hs view
@@ -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
src/Main.hs view
@@ -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