fay 0.18.0.3 → 0.18.0.4

raw patch · 37 files changed

+2080/−398 lines, 37 files

Files

examples/CodeWorld.hs +469/−0
examples/CodeWorldMain.hs +134/−0
examples/Cont.hs +67/−0
examples/FayFromJs.hs +16/−0
examples/FayFromJs.html +36/−0
examples/Separated.hs +18/−0
examples/X.hs +13/−0
examples/Y.hs +13/−0
examples/alert.html +8/−0
examples/calc.hs +124/−0
examples/calc.html +16/−0
examples/codeworld.html +9/−0
examples/dom.html +8/−0
examples/jquery.hs +48/−0
examples/jquery.html +10/−0
examples/json.hs +35/−0
examples/node.hs +26/−0
examples/nqueens.hs +44/−0
examples/obj.hs +23/−0
examples/oscillator.hs +621/−0
examples/oscillator.html +92/−0
examples/pat.hs +13/−0
examples/properties.hs +43/−0
examples/properties.html +7/−0
examples/showExamples.hs +48/−0
fay.cabal +30/−328
js/runtime.js +49/−68
src/Fay/Compiler/Typecheck.hs +3/−1
src/tests/Tests.hs +3/−1
tests/JsFunctionPassing.hs +22/−0
tests/JsFunctionPassing.res +2/−0
tests/ModuleReExport/ExportsIdentifier.hs +8/−0
tests/ModuleReExport/ExportsIdentifier.res +0/−0
tests/ModuleReExport/ExportsModule.hs +14/−0
tests/ModuleReExport/ExportsModule.res +0/−0
tests/ModuleReExports.hs +7/−0
tests/ModuleReExports.res +1/−0

+ examples/CodeWorld.hs view

@@ -0,0 +1,469 @@+{-+    (By Chris Smith)+    Reimplementation of gloss (minus bitmaps) in terms of Fay.  This is a proof+    of concept that Fay is in a state where it can support use cases like+    gloss-web on the client.++    TODO:+    - Fix the problem with unary negation+    - Implement support for events and game mode++    To try it out, skip the boilerplate section at the top; in the final+    implementation, it will eventually be moved to a different module and+    imported.  Change the definition of go to one of drawIt, animateIt, or+    simulateIt to try the various modes.+-}++{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE EmptyDataDecls    #-}++module CodeWorld where++import Prelude+import FFI+++data Element++getElementById :: String -> Fay Element+getElementById = ffi "document['getElementById'](%1)"++focusElement :: Element -> Fay ()+focusElement = ffi "%1.focus()"++data Event++addEventListener :: String -> Bool -> (Event -> Fay Bool) -> Fay ()+addEventListener = ffi "window['addEventListener'](%1,%3,%2)"++--getEventKeyCode :: Event -> Fay String+--getEventKeyCode = ffi "%1['keyCode']"++getEventMouseButton :: Event -> Fay Int+getEventMouseButton = ffi "%1['button']"++data Timer++setInterval :: Double -> Fay () -> Fay Timer+setInterval = ffi "window['setInterval'](%2,%1)"++data Ref a++newRef :: a -> Fay (Ref a)+newRef = ffi "new Fay$$Ref(%1)"++writeRef :: Ref a -> a -> Fay ()+writeRef = ffi "Fay$$writeRef(%1,%2)"++readRef :: Ref a -> Fay a+readRef = ffi "Fay$$readRef(%1)"++currentTimeMillis :: Fay Double+currentTimeMillis = ffi "(Date.now?Date.now():new Date().getTime())"++data Context++getContext :: Element -> String -> Fay Context+getContext = ffi "%1['getContext'](%2)"++clearRect :: Context -> Double -> Double -> Double -> Double -> Fay ()+clearRect = ffi "%1['clearRect'](%2,%3,%4,%5)"++save :: Context -> Fay ()+save = ffi "%1['save']()"++restore :: Context -> Fay ()+restore = ffi "%1['restore']()"++canvasTranslate :: Context -> Double -> Double -> Fay ()+canvasTranslate = ffi "%1['translate'](%2,%3)"++canvasScale :: Context -> Double -> Double -> Fay ()+canvasScale = ffi "%1['scale'](%2,%3)"++transform :: Context+          -> Double -> Double -> Double -> Double -> Double -> Double+          -> Fay ()+transform = ffi "%1['transform'](%2,%3,%4,%5,%6,%7)"++setTextAlign :: Context -> String -> Fay ()+setTextAlign = ffi "%1['textAlign']=%2"++setTextBaseline :: Context -> String -> Fay ()+setTextBaseline = ffi "%1['textBaseline']=%2"++setLineWidth :: Context -> Double -> Fay ()+setLineWidth = ffi "%1['lineWidth']=%2"++setFont :: Context -> String -> Fay ()+setFont = ffi "%1['font']=%2"++setStrokeStyle :: Context -> String -> Fay ()+setStrokeStyle = ffi "%1['strokeStyle']=%2"++setFillStyle :: Context -> String -> Fay ()+setFillStyle = ffi "%1['fillStyle']=%2"++beginPath :: Context -> Fay ()+beginPath = ffi "%1['beginPath']()"++closePath :: Context -> Fay ()+closePath = ffi "%1['closePath']()"++fill :: Context -> Fay ()+fill = ffi "%1['fill']()"++stroke :: Context -> Fay ()+stroke = ffi "%1['stroke']()"++fillText :: Context ->String -> Double -> Double -> Fay ()+fillText = ffi "%1['fillText'](%2,%3,%4)"++moveTo :: Context -> Double -> Double -> Fay ()+moveTo = ffi "%1['moveTo'](%2,%3)"++lineTo :: Context -> Double -> Double -> Fay ()+lineTo = ffi "%1['lineTo'](%2,%3)"++canvasArc :: Context -> Double -> Double -> Double -> Double -> Double -> Bool -> Fay ()+canvasArc = ffi "%1['arc'](%2,%3,%4,%5,%6,%7)"++-- Special functions defined in codeworld.js++getSpecialKey :: Event -> Fay String+getSpecialKey = ffi "window.getSpecialKey(%1)"++getPressedKey :: Event -> Fay String+getPressedKey = ffi "window.getPressedKey(%1)"++getReleasedKey :: Event -> Fay String+getReleasedKey = ffi "window.getReleasedKey(%1)"++stopEvent :: Event -> Fay ()+stopEvent = ffi "window.stopEvent(%1)"++mouseToElementX :: Event -> Fay Double+mouseToElementX = ffi "window.mouseToElementX(%1)"++mouseToElementY :: Event -> Fay Double+mouseToElementY = ffi "window.mouseToElementY(%1)"++type Transform = (Double, Double, Double, Double, Double, Double)++translateTransform :: Double -> Double -> Transform -> Transform+translateTransform x y (a,b,c,d,e,f) =+    (a, b, c, d, a * x + c * y + e, b * x + d * y + f)++scaleTransform :: Double -> Double -> Transform -> Transform+scaleTransform x y (a,b,c,d,e,f) =+    (x*a, x*b, y*c, y*d, e, f)++rotateTransform :: Double -> Transform -> Transform+rotateTransform r (a,b,c,d,e,f) = let th = r * pi / 180 in+    (a * cos th + c * sin th,+     b * cos th + d * sin th,+     c * cos th - a * sin th,+     d * cos th - b * sin th,+     e, f)++withTransform :: Context -> Transform -> Fay () -> Fay ()+withTransform ctx (a,b,c,d,e,f) action = do+    save ctx+    transform ctx a b c d e f+    beginPath ctx+    action+    restore ctx++data Color = RGBA Double Double Double Double++white, black :: Color+white = RGBA 1 1 1 1+black = RGBA 0 0 0 1++red, green, blue, cyan, magenta, yellow :: Color+red        = RGBA 1 0 0 1+green      = RGBA 0 1 0 1+blue       = RGBA 0 0 1 1+yellow     = RGBA 1 1 0 1+cyan       = RGBA 0 1 1 1+magenta    = RGBA 1 0 1 1++orange, rose, chartreuse, aquamarine, violet, azure :: Color+orange     = RGBA 1.0 0.5 0.0 1+rose       = RGBA 1.0 0.0 0.5 1+chartreuse = RGBA 0.5 1.0 0.0 1+aquamarine = RGBA 0.0 1.0 0.5 1+violet     = RGBA 0.5 0.0 1.0 1+azure      = RGBA 0.0 0.5 1.0 1++light :: Color -> Color+light (RGBA r g b a) = RGBA+    (min 1 (r + 0.2))+    (min 1 (g + 0.2))+    (min 1 (b + 0.2))+    a++dark :: Color -> Color+dark (RGBA r g b a) = RGBA+    (max 0 (r - 0.2))+    (max 0 (g - 0.2))+    (max 0 (b - 0.2))+    a++gray, grey :: Double -> Color+gray = grey+grey k = RGBA k k k 1++type Point = (Double, Double)+type Vector = Point++data Picture = Polygon [Point]+             | Line [Point]+             | ThickArc Double Double Double Double+             | Text String+             | Color Color Picture+             | Translate Double Double Picture+             | Scale Double Double Picture+             | Rotate Double Picture+             | Pictures [Picture]++blank :: Picture+blank = Pictures []++polygon :: [Point] -> Picture+polygon = Polygon++line :: [Point] -> Picture+line = Line++thickArc :: Double -> Double -> Double -> Double -> Picture+thickArc = ThickArc++arc :: Double -> Double -> Double -> Picture+arc b e r = thickArc b e r 0++circle :: Double -> Picture+circle = arc 0 360++circleSolid :: Double -> Picture+circleSolid r = thickCircle (r/2) r++thickCircle :: Double -> Double -> Picture+thickCircle = thickArc 0 360++text :: String -> Picture+text = Text++color :: Color -> Picture -> Picture+color = Color++translate :: Double -> Double -> Picture -> Picture+translate = Translate++scale :: Double -> Double -> Picture -> Picture+scale = Scale++rotate :: Double -> Picture -> Picture+rotate = Rotate++pictures :: [Picture] -> Picture+pictures = Pictures++rectangleSolid :: Double -> Double -> Picture+rectangleSolid w h = polygon [+    (0-w/2, 0-h/2), (w/2, 0-h/2), (w/2, h/2), (0-w/2, h/2)+    ]++rectangleWire :: Double -> Double -> Picture+rectangleWire w h = line [+    (0-w/2, 0-h/2), (w/2, 0-h/2), (w/2, h/2), (0-w/2, h/2), (0-w/2, 0-h/2)+    ]++pathFromPoints :: Context -> [Point] -> Fay ()+pathFromPoints _   [] = return ()+pathFromPoints ctx ((sx,sy):ps) = do+    moveTo ctx sx sy+    forM_ ps $ \(x,y) -> lineTo ctx x y++drawPicture :: Context -> Transform -> Picture -> Fay ()+drawPicture ctx t (Polygon ps) = do+    withTransform ctx t $ pathFromPoints ctx ps+    fill ctx++drawPicture ctx t (Line ps) = do+    withTransform ctx t $ pathFromPoints ctx ps+    stroke ctx++drawPicture ctx t (ThickArc b e r w) = do+    save ctx+    withTransform ctx t $ do+        when (r > 0) $ canvasArc ctx 0 0 r (b*pi/180) (e*pi/180) False+        closePath ctx+    when (w > 0) $ setLineWidth ctx w+    stroke ctx+    restore ctx++drawPicture ctx t (Text txt) =+    withTransform ctx t $ do+        canvasScale ctx 1 (0-1)+        fillText ctx txt 0 0++drawPicture ctx t (Color (RGBA r g b a) p) = do+    let str = "rgba(" ++ show (r * 100) ++ "%,"+                      ++ show (g * 100) ++ "%,"+                      ++ show (b * 100) ++ "%,"+                      ++ show a ++ ")"+    save ctx+    setStrokeStyle ctx str+    setFillStyle ctx str+    drawPicture ctx t p+    restore ctx++drawPicture ctx t (Translate x y p) = drawPicture ctx (translateTransform x y t) p+drawPicture ctx t (Scale x y p)     = drawPicture ctx (scaleTransform x y t) p+drawPicture ctx t (Rotate r p)      = drawPicture ctx (rotateTransform r t) p+drawPicture ctx t (Pictures ps)     = mapM_ (drawPicture ctx t) ps++withCanvas :: (Element -> Context -> Fay ()) -> Fay ()+withCanvas go = addEventListener "load" False $ const $ do+    canvas <- getElementById "canvas"+    ctx    <- getContext canvas "2d"+    go canvas ctx+    return False++drawOn :: Context -> Picture -> Fay ()+drawOn ctx pic = do+    clearRect ctx 0 0 500 500+    save ctx+    canvasTranslate ctx 250 250+    canvasScale ctx 1 (0-1)+    setTextAlign ctx "left"+    setTextBaseline ctx "alphabetic"+    setLineWidth ctx 0+    setFont ctx "100px Times Roman"+    drawPicture ctx (1,0,0,1,0,0) pic+    restore ctx++displayInCanvas :: Picture -> Fay ()+displayInCanvas pic = withCanvas $ \ canvas ctx -> drawOn ctx pic++animateInCanvas :: (Double -> Picture) -> Fay ()+animateInCanvas anim = withCanvas $ \ canvas ctx -> do+    startTime <- currentTimeMillis+    setInterval 30 $ do+        currentTime <- currentTimeMillis+        let t = (currentTime - startTime) / 1000+        drawOn ctx (anim t)+    return ()++data SimState a = SimState a++withSimState :: (a -> a) -> Ref (SimState a) -> Fay a+withSimState f ref = do+    SimState val <- readRef ref+    let newVal = f val+    writeRef ref (SimState newVal)+    return newVal++-- XXX: This is a hack to pretend to have a decent purely functional+-- random number generator.  It should be replaced by a correct+-- implementation as soon as possible.++unsafeRand :: Double -> Double -> Double+unsafeRand = ffi "Math.random()*%2+%1"++data StdGen = StdGen++newStdGen :: Fay StdGen+newStdGen = return StdGen++splitR :: StdGen -> (StdGen, StdGen)+splitR g = (g, g)++randomR :: (Double, Double) -> StdGen -> (Double, StdGen)+randomR (lo, hi) g = (unsafeRand lo (hi - lo), g)++simulateInCanvas :: (StdGen -> a)+                 -> (Double -> a -> a)+                 -> (a -> Picture)+                 -> Fay ()+simulateInCanvas i s d = withCanvas $ \ canvas ctx -> do+    startTime <- currentTimeMillis+    g <- newStdGen+    valueRef <- newRef (SimState (i g))+    timeRef <- newRef startTime+    setInterval 30 $ do+        lastTime     <- readRef timeRef+        currentTime  <- currentTimeMillis+        let dt     = (currentTime - lastTime) / 1000+        val <- withSimState (s dt) valueRef+        writeRef timeRef currentTime+        drawOn ctx (d val)+    return ()++data GameEvent = KeyPressEvent String+               | KeyReleaseEvent String+               | MousePressEvent Int Point+               | MouseReleaseEvent Int Point+               | MouseMoveEvent Point+  deriving Show+playInCanvas :: (StdGen -> a)+             -> (Double -> a -> a)+             -> (GameEvent -> a -> a)+             -> (a -> Picture)+             -> Fay ()+playInCanvas i s e d = withCanvas $ \ canvas ctx -> do+    startTime <- currentTimeMillis+    g <- newStdGen+    valueRef <- newRef (SimState (i g))+    timeRef <- newRef startTime+    addEventListener "keydown" False $ \ev -> do+        k <- getSpecialKey ev+        if k == "None" then return True else do+            withSimState (e (KeyPressEvent k)) valueRef+            stopEvent ev+            return False+    addEventListener "keypress" False $ \ev -> do+        k <- getPressedKey ev+        if k == "None" then return True else do+            withSimState (e (KeyPressEvent k)) valueRef+            stopEvent ev+            return False+    addEventListener "keyup" False $ \ev -> do+        k <- getReleasedKey ev+        if k == "None" then return True else do+            withSimState (e (KeyReleaseEvent k)) valueRef+            stopEvent ev+            return False+    addEventListener "mousedown" False $ \ev -> do+        focusElement canvas+        x <- mouseToElementX ev+        y <- mouseToElementY ev+        if abs x > 250 || abs y > 250 then return True else do+            b <- getEventMouseButton ev+            withSimState (e (MousePressEvent b (x,y))) valueRef+            stopEvent ev+            return False+    addEventListener "mouseup" False $ \ev -> do+        x <- mouseToElementX ev+        y <- mouseToElementY ev+        if abs x > 250 || abs y > 250 then return True else do+            b <- getEventMouseButton ev+            withSimState (e (MouseReleaseEvent b (x,y))) valueRef+            stopEvent ev+            return False+    addEventListener "mousemove" False $ \ev -> do+        x <- mouseToElementX ev+        y <- mouseToElementY ev+        if abs x > 250 || abs y > 250 then return True else do+            withSimState (e (MouseMoveEvent (x,y))) valueRef+            stopEvent ev+            return False+    setInterval 30 $ do+        lastTime     <- readRef timeRef+        currentTime  <- currentTimeMillis+        let dt     = (currentTime - lastTime) / 1000+        val <- withSimState (s dt) valueRef+        writeRef timeRef currentTime+        drawOn ctx (d val)+    return ()

+ examples/CodeWorldMain.hs view

@@ -0,0 +1,134 @@+-- By Chris Smith++{-# LANGUAGE NoImplicitPrelude #-}++module MyDrawing where++import Prelude+import FFI+import CodeWorld++main = playInCanvas initial step event draw++data World = World {+    stars     :: [(Double, Double, Double)],+    asts      :: [(Point, Vector)],+    ship      :: (Point, Vector),+    direction :: Double,+    left      :: Double,+    right     :: Double,+    thrust    :: Double,+    energy    :: Double,+    score     :: Double,+    lastScore :: Double,+    maxScore  :: Double,+    savedGen  :: StdGen+    }++initial g = initialWith 0 0 g++initialWith m l g0 =+  case splitR g0 of+    (genStars, g1) -> case splitR g1 of+      (genAsts,  g2) ->+        World {+            stars     = take 40 (makeStars genStars),+            asts      = take 20 (makeAsts  genAsts),+            ship      = ((0,0), (0,0)),+            direction = 0,+            left      = 0,+            right     = 0,+            thrust    = 0,+            energy    = 1,+            score     = 0,+            maxScore  = m,+            lastScore = l,+            savedGen  = g2+            }++makeStars g0 = case randomR (-250, 250) g0 of+  (x, g1) -> case randomR (-250, 250) g1 of+    (y, g2) -> case randomR (   1,   3) g2 of+      (r, g3) -> (x,y,r) : makeStars g3++makeAsts  g0 = case randomR (-250, 250) g0 of+  (x,  g1) -> case randomR (-250, 250) g1 of+    (y,  g2) -> case randomR ( -30,  30) g2 of+      (vx, g3) -> case randomR ( -30,  30) g3 of+        (vy, g4) -> ((x,y), (vx, vy)) : makeAsts g4++effective w x | energy w > 0 = x w+              | otherwise    = 0++lost w = any (collision (ship w)) (asts w)+    where collision ((x1,y1),_) ((x2,y2),_) = (((x2-x1)^2::Double) + ((y2-y1)^2::Double)) < 1764++step dt w = if lost w+    then initialWith (maxScore w) (if score w < 1 then lastScore w else score w) (savedGen w)+    else w {+        asts      = map (stepBody dt) (asts w),+        ship      = stepThrust dt (stepBody dt (ship w)) (effective w thrust) (direction w),+        direction = stepDir    dt (direction w) (left w) (right w),+        energy    = fence 0 1 (energy w + dt * (0.5 * (1 - thrust w) - 1.0 * thrust w)),+        score     = score w + dt,+        maxScore  = max (maxScore w) (score w)+        }++fence lo hi v = max 0 (min hi v)++stepThrust dt ((x,y), (sx,sy)) th dir = ((x,y), (sx', sy'))+    where sx' = sx + th * (-30) * sin (dir * pi / 180) * dt+          sy' = sy + th *   30  * cos (dir * pi / 180) * dt++stepDir dt dir l r = dir + l * 90 * dt - r * 90 * dt++stepBody dt ((x,y),(sx,sy)) = ((wrap (x + sx * dt), wrap (y + sy * dt)), (sx, sy))+  where wrap k | k <= (-300) = k + 600+               | k >=   300  = k - 600+               | otherwise   = k++draw w = pictures [+    rectangleSolid 500 500,+    drawStars (stars w),+    drawAsts (asts w),+    drawShip (ship w) (direction w) (effective w thrust),+    drawEnergyBar (energy w),+    drawScoreBar (score w) (lastScore w) (maxScore w)+    ]++drawStars ss = pictures [+    color (gray 0.5) (translate x y (circleSolid r ))+        | (x,y,r)   <- ss+    ]++drawAsts  as = pictures [+    color (light red) (translate x y (circleSolid 30))+        | ((x,y),_) <- as+    ]++drawShip ((x,y),_) dir th = translate x y (rotate dir (pictures [+    color (gray 0.2) (circle 12),+    color cyan   (polygon [(-9, -8), (9, -8), ( 0, 12) ]),+    if th > 0 then color orange (polygon [( -8, -8), (-10, -11), (10, -11), (8, -8)])+              else blank+    ]))++drawEnergyBar e = color yellow $ translate 0 (-230) $ rectangleSolid (400 * e) 15++drawScoreBar s l m = pictures [+  color blue $ translate 0 230 $ rectangleSolid 500 15,+  color white $ translate (-200) 225 $ scale 0.2 0.15 $ text $ "Score: " ++ fmtScore s,+  color white $ translate ( -25) 225 $ scale 0.2 0.15 $ text $ "Last: " ++ fmtScore l,+  color white $ translate ( 150) 225 $ scale 0.2 0.15 $ text $ "Max: " ++ fmtScore m+  ]++fmtScore :: Double -> String+fmtScore s = show (floor (10 * s))++event (KeyPressEvent   "Up")    w = w { thrust = 1 }+event (KeyReleaseEvent "Up")    w = w { thrust = 0 }+event (KeyPressEvent   "Left")  w = w { left   = 1 }+event (KeyReleaseEvent "Left")  w = w { left   = 0 }+event (KeyPressEvent   "Right") w = w { right  = 1 }+event (KeyReleaseEvent "Right") w = w { right  = 0 }+event _                         w = w

+ examples/Cont.hs view

@@ -0,0 +1,67 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE NoImplicitPrelude #-}++-- | An example implementation of the lovely continuation monad.++module Cont where++import FFI+import Prelude++--------------------------------------------------------------------------------+-- Entry point.++-- | Main entry point.+main :: Fay ()+main = runContT demo (const (return ()))++demo :: Deferred ()+demo = case contT of+  CC return (>>=) (>>) callCC lift -> do+    lift (putStrLn "Hello!")+    sync setTimeout 500+    contents <- sync readFile "README.md"+    lift (putStrLn ("File contents is: " ++ take 10 contents ++ "..."))++--------------------------------------------------------------------------------+-- Deferred library.++-- | An example deferred monad.+type Deferred a = ContT () Fay a++-- | Set an asynchronous timeout.+setTimeout :: Int -> (() -> Fay ()) -> Fay ()+setTimeout = ffi "global.setTimeout(%2,%1)"++readFile :: String -> (String -> Fay b) -> Fay b+readFile = ffi "require('fs').readFile(%1,'utf-8',function(_,s){ %2(s); })"++sync :: (t -> (a -> Fay r) -> Fay r) -> t -> ContT r Fay a+sync m a = ContT $ \c -> m a c++--------------------------------------------------------------------------------+-- Continuation library.++-- | The continuation monad.+data ContT r m a = ContT { runContT :: (a -> m r) -> m r }+class Monad (m :: * -> *)+instance (Monad m) => Monad (ContT r m)++data CC = CC+  { cc_return :: forall a r. a -> ContT r Fay a+  , cc_bind :: forall a b r. ContT r Fay a -> (a -> ContT r Fay b) -> ContT r Fay b+  , cc_then :: forall a b r. ContT r Fay a -> ContT r Fay b -> ContT r Fay b+  , cc_callCC :: forall a b r. ((a -> ContT r Fay b) -> ContT r Fay a) -> ContT r Fay a+  , cc_lift :: forall a r. Fay a -> ContT r Fay a+  }++-- | The continuation monad module.+contT =+  let return a = ContT (\f -> f a)+      m >>= k = ContT $ \c -> runContT m (\a -> runContT (k a) c)+      m >> n = m >>= \_ -> n+      callCC f = ContT $ \c -> runContT (f (\a -> ContT $ \_ -> c a)) c+      lift m = ContT (\x -> m >>=* x)+  in CC return (>>=) (>>) callCC lift where (>>=*) = (>>=)

+ examples/FayFromJs.hs view

@@ -0,0 +1,16 @@+-- | Compile with `fay examples/FayFromJs.hs --strict FayFromJs`++module FayFromJs where++import           Prelude++data Vector = Vector { x :: Double , y :: Double }++aVector :: Vector+aVector = Vector 1 2++len :: Vector -> Double+len (Vector a b) = sqrt (a^^2 + b^^2)++add :: Vector -> Vector -> Vector+add (Vector a b) (Vector c d) = Vector (a+c) (b+d)

+ examples/FayFromJs.html view

@@ -0,0 +1,36 @@+<!doctype html>+<html>+  <head>+    <meta http-equiv='Content-Type' content='text/html; charset=utf-8'>++    <script type="text/javascript" src="FayFromJs.js"></script>+    </script>+    <script>+      function print(label, v)+      {+        var div = document.createElement("div");+        div.innerHTML = label + JSON.stringify(v);+        document.body.appendChild(div);+      }++      window.onload = function () {+        var V = Strict.FayFromJs;+        // Constant+        print("aVector = ", V.aVector);+        // Simple function calls+        print("|aVector| = ", V.len(V.aVector));+        // Arguments are deserialized from JSON using Automatic.+        print("|[10, 20]| = ", V.len({ instance : "Vector", x : 10, y : 20 }));+        // Call with uncurried arguments+        // Return values are serialized to the JSON format using Automatic.+        print( "aVector + [10, 20] = "+             , V.add(V.aVector, { instance : "Vector", x : 10, y : 20 }));+        // Curried call is also fine+        print( "aVector + [10, 20] = "+             , V.add(V.aVector)({ instance : "Vector", x : 10, y : 20 }));+      };+    </script>+  </head>+  <body>+  </body>+</html>

+ examples/Separated.hs view

@@ -0,0 +1,18 @@+-- $ fay --print-runtime > examples/separated-rts.js+-- $ fay --include examples --stdlib --no-dispatcher --naked --no-ghc --no-rts --pretty examples/Separated.hs -o examples/separated-stdlib.js+-- $ fay --include examples --no-stdlib --dispatcher --naked --no-ghc --no-rts --pretty examples/Separated.hs -o examples/separated-dispatcher.js+-- $ fay --include examples --no-stdlib --no-dispatcher --no-ghc --no-rts --naked --pretty examples/Y.hs -o examples/separated-y.js+-- $ fay --include examples --no-stdlib --no-dispatcher --no-ghc --no-rts --naked --pretty examples/X.hs -o examples/separated-x.js+-- $ (cat examples/separated-rts.js; cat examples/separated-stdlib.js; cat examples/separated-dispatcher.js; cat examples/separated-y.js; echo 'Fay$$_(Y$main)') | node+-- { instance: 'Bar', slot1: [ 1, 2, 3 ], slot2: 'Hello, Bar!' }+-- $ (cat examples/separated-rts.js; cat examples/separated-stdlib.js; cat examples/separated-dispatcher.js; cat examples/separated-x.js; echo 'Fay$$_(X$main)') | node+-- { instance: 'Foo', slot1: [ 1, 2, 3 ], slot2: 'Hello, Foo!' }+-- $++module Separated where++import FFI+import Prelude++import X+import Y

+ examples/X.hs view

@@ -0,0 +1,13 @@+module X where++import FFI+import Prelude++data Foo = Foo [Int] String++printFoo :: Foo -> Fay ()+printFoo = ffi "console.log(%1)"++fooGo = printFoo (Foo [1,2,3] "Hello, Foo!")++main = fooGo

+ examples/Y.hs view

@@ -0,0 +1,13 @@+module Y where++import FFI+import Prelude++data Bar = Bar [Int] String++printBar :: Bar -> Fay ()+printBar = ffi "console.log(%1)"++barGo = printBar (Bar [1,2,3] "Hello, Bar!")++main = barGo

+ examples/alert.html view

@@ -0,0 +1,8 @@+<html>+  <head>+    <title></title>+    <script src="alert.js"></script>+  </head>+  <body>+  </body>+</html>

+ examples/calc.hs view

@@ -0,0 +1,124 @@+-- | Calculator based on http://trelford.com/PitCalculatorApp.htm+--+-- Compile with+-- $ fay -p --html-wrapper --html-js-lib jquery.min.js examples/calc.hs+-- You also need to download jquery.min.js.+--++{-# OPTIONS -fno-warn-orphans -fno-warn-type-defaults -fno-warn-unused-do-bind #-}+{-# LANGUAGE EmptyDataDecls #-}++module Calc (main) where++import           FFI+import           Prelude++main :: Fay ()+main = do+  display <- select "<input type='text' value='' style='text-align:right'>"+  operation <- newRef Nothing :: Fay (Ref (Maybe (Double -> Double)))+  appendMore <- newRef False++  let buttons =+        [[enter 7, enter 8, enter 9, ("/",operator (/))]+        ,[enter 4, enter 5, enter 6, ("*",operator (*))]+        ,[enter 1, enter 2, enter 3, ("-",operator (-))]+        ,[("C",clear), enter 0, ("=",calculate), ("+",operator (+))]]+      enter :: Double -> (String,Fay ())+      enter n = (show n,do current <- getVal display+                           addit <- readRef appendMore+                           if addit+                              then do setVal (current ++ show n) display+                                      return ()+                              else do setVal (show n) display+                                      writeRef appendMore True)+      getInput = getVal display >>= (return . parseDouble 10)+      operator op = do+        calculate+        num <- getInput+        writeRef operation (Just (op num))+      clear = do+        setVal "0" display+        writeRef operation Nothing+        calculate+      calculate = do+        op <- readRef operation+        case op of+          Nothing -> return ()+          Just maths -> do+            num <- getInput+            setVal (show (maths num)) display+            return ()+        writeRef operation Nothing+        writeRef appendMore False++  ready $ do+    body <- select "body"+    table <- select "<table></table>" & appendTo body+    dtr <- select "<tr></tr>" & appendTo table+    select "<td colspan='4'></td>" & appendTo dtr & append display+    forM_ buttons $ \row -> do+      tr <- select "<tr></tr>" & appendTo table+      forM_ row $ \(text,action) -> do+        td <- select "<td></td>" & appendTo tr+        select "<input type='button' value='' style='width:32px'>"+              & setVal text+              & appendTo td+              & onClick (do action; return False)++--------------------------------------------------------------------------------+-- JQuery bindings+-- These are provided in the fay-jquery package.++data JQuery+instance Show JQuery++data Element++-- | Nicer/easier binding for >>=.+(&) :: Fay a -> (a -> Fay b) -> Fay b+x & y = x >>= y+infixl 1 &++getVal :: JQuery -> Fay String+getVal = ffi "%1['val']()"++setVal :: String -> JQuery -> Fay JQuery+setVal = ffi "%2['val'](%1)"++select :: String -> Fay JQuery+select = ffi "window['jQuery'](%1)"++ready :: Fay () -> Fay ()+ready = ffi "window['jQuery'](%1)"++append :: JQuery -> JQuery -> Fay JQuery+append = ffi "%2['append'](%1)"++appendTo :: JQuery -> JQuery -> Fay JQuery+appendTo = ffi "%2['appendTo'](%1)"++onClick :: Fay Bool -> JQuery -> Fay JQuery+onClick = ffi "%2['click'](%1)"++--------------------------------------------------------------------------------+-- Utilities++parseDouble :: Int -> String -> Double+parseDouble = ffi "parseFloat(%2,%1) || 0"++--------------------------------------------------------------------------------+-- Refs+-- This will be provided in the fay package by default.++data Ref a+instance Show (Ref a)++newRef :: a -> Fay (Ref a)+newRef = ffi "new Fay$$Ref(%1)"++writeRef :: Ref a -> a -> Fay ()+writeRef = ffi "Fay$$writeRef(%1,%2)"++readRef :: Ref a -> Fay a+readRef = ffi "Fay$$readRef(%1)"

+ examples/calc.html view

@@ -0,0 +1,16 @@+<!doctype html>+<html>+  <head>+    <title>Calc</title>+    <meta http-equiv='Content-Type' content='text/html; charset=utf-8'>+    <script type="text/javascript" src="jquery.min.js"></script>+    <script type="text/javascript" src="calc.js"></script>+    </script>+  </head>+  <body>+    <h1>Calc</h1>+    <p>A clone of <a href="http://trelford.com/PitCalculatorApp.htm">Pit's calculator app</a></p>+    <p>JS generated by <a href="http://fay-lang.org/">Fay</a>, a Haskell+    subset. <a href="https://github.com/faylang/fay/blob/master/examples/calc.hs">Source code</a></p>+  </body>+</html>

+ examples/codeworld.html view

@@ -0,0 +1,9 @@+<html>+<head>+  <script type="text/javascript" src="codeworld.js"></script>+  <script type="text/javascript" src="CodeWorldMain.js"></script>+</head>+<body>+<canvas id="canvas" style="border: solid black 1px" width="500" height="500"></canvas>+</body>+</html>

+ examples/dom.html view

@@ -0,0 +1,8 @@+<html>+  <head>+    <title></title>+    <script src="dom.js"></script>+  </head>+  <body>+  </body>+</html>

+ examples/jquery.hs view

@@ -0,0 +1,48 @@+{-# LANGUAGE EmptyDataDecls    #-}+++module JQuery where++import           FFI+import           Prelude++main :: Fay ()+main = do+  ready $ do+    putStrLn (showDouble 123)+    body <- select "body"+    printArg body+    addClassWith (\i s -> do putStrLn ("i… " ++ showDouble i)+                             putStrLn ("s… " ++ showString s)+                             return "abc")+                 body+    addClassWith (\i s -> do putStrLn ("i… " ++ showDouble i)+                             putStrLn ("s… " ++ showString s)+                             putStrLn (showString ("def: " ++ s))+                             return "foo")+                 body+    printArg body+    return ()++data JQuery+instance Show JQuery++data Element++printArg :: a -> Fay ()+printArg = ffi "console.log(\"%%o\",%1)"++showDouble :: Double -> String+showDouble = ffi "(%1).toString()"++showString :: String -> String+showString = ffi "JSON.stringify(%1)"++select :: String -> Fay JQuery+select = ffi "jQuery(%1)"++addClassWith :: (Double -> String -> Fay String) -> JQuery -> Fay JQuery+addClassWith = ffi "%2.addClass(%1)"++ready :: Fay () -> Fay ()+ready = ffi "jQuery(%1)"

+ examples/jquery.html view

@@ -0,0 +1,10 @@+<html>+  <head>+    <title>jQuery demo</title>+    <meta http-equiv="Content-Type" content="charset=utf-8">+    <script src="jquery.min.js"></script>+    <script src="jquery.js"></script>+  </head>+  <body>+  </body>+</html>

+ examples/json.hs view

@@ -0,0 +1,35 @@+++module Console where++import           FFI+import           Prelude+import           Fay.Text++data MyData = MyData  { xVar :: Text, yVar :: Int }++myData :: MyData+myData = MyData { xVar = pack "asdfasd", yVar = 9 }+++main = do+	jsonSerialized <- toJSON myData+	jsonDeserialized <- toMyData jsonSerialized+	fromStringData <- toMyData "{\"xVar\":3,\"yVar\":-1,\"instance\":\"MyData\"}"+	print' jsonSerialized++-- | Print using console.log.+print' :: String -> Fay ()+print' = ffi "console.log(%1)"++printBool :: Bool -> Fay ()+printBool = ffi "console.log(%1)"++printInt :: Int -> Fay ()+printInt = ffi "console.log(%1)"++toMyData :: String -> Fay MyData+toMyData = ffi "JSON.parse(%1)"++toJSON :: MyData -> Fay String+toJSON = ffi "JSON.stringify(%1)"

+ examples/node.hs view

@@ -0,0 +1,26 @@+-- | Simple example interfacing with node.++{-# LANGUAGE EmptyDataDecls    #-}+++module Test where++import           FFI+import           Prelude++data Sys++data Details+instance Show Details++main = do+  sys <- require' "sys"+  npm <- require' "npm"+  details <- inspect sys npm+  print $ details++require' :: String -> Fay Sys+require' = ffi "require(%1)"++inspect :: Sys -> Automatic a -> Fay Details+inspect = ffi "%1.inspect(%2)"

+ examples/nqueens.hs view

@@ -0,0 +1,44 @@+++-- !!! count the number of solutions to the "n queens" problem.++module NQueens where++import Prelude+import FFI++main :: Fay ()+main = benchmark $ print (nsoln 11)++listLength :: [a] -> Int -> Int+listLength [] acc = acc+listLength (_:l) acc = listLength l (1 + acc)++listFilter :: (a -> Bool) -> [a] -> [a]+listFilter f [] = []+listFilter f  (a : l)+    | f a       = a : (listFilter f l)+    | otherwise = listFilter f l++nsoln :: Int -> Int+nsoln nq = listLength (gen nq) 0+ where+    safe :: Int -> Int -> [Int] -> Bool+    safe x d []        = True+    safe x d ( q : l) = (x /= q) && (x /= (q+d)) && (x /= (q-d)) && safe x (d+1) l++    gen :: Int -> [[Int]]+    gen 0 =  [] : []+    gen n = concat $ map (\bs -> map (\q ->  q : bs) $ listFilter (\q -> safe q 1 bs) ([1..nq])) (gen (n-1))++benchmark m = do+  start <- getSeconds+  m+  end <- getSeconds+  printS (show (end-start) ++ "ms")++printS :: String -> Fay ()+printS = ffi "console.log(%1)"++getSeconds :: Fay Double+getSeconds = ffi "new Date()"

+ examples/obj.hs view

@@ -0,0 +1,23 @@+++module Print where++import FFI+import Prelude++data Foo = Foo { foo :: Double, bar :: String }++main :: Fay ()+main = do+  callback (Foo 123 "abc")+           (\(Foo n s) -> do printDouble n+                             printString s)++callback :: Foo -> (Foo -> Fay ()) -> Fay ()+callback = ffi "global.callback(%1,%2)"++printDouble :: Double -> Fay ()+printDouble = ffi "console.log(%1)"++printString :: String -> Fay ()+printString = ffi "console.log(%1)"

+ examples/oscillator.hs view

@@ -0,0 +1,621 @@+{-# LANGUAGE EmptyDataDecls    #-}+{-# LANGUAGE NoImplicitPrelude #-}++module RingOscillator (main) where++import FFI+import Prelude+++-- System parameters.+--+data Params = Params { alpha :: Double+                     , omega :: Double+                     , deven :: Double+                     , dodd :: Double+                     , beta :: Double+                     , sigma :: Double+                     , nosc :: Int } deriving Show++-- Update functions for system parameters used in the event handlers+-- for the parameter select lists.  Not pretty, but there's not really+-- a nicer way to do it.+--+alphaUpd, omegaUpd :: Params -> Double -> Params+devenUpd, doddUpd :: Params -> Double -> Params+betaUpd, sigmaUpd :: Params -> Double -> Params+noscUpd :: Params -> Int -> Params+alphaUpd p val = p { alpha = val }+omegaUpd p val = p { omega = val }+devenUpd p val = p { deven = val }+doddUpd p val = p { dodd = val }+betaUpd p val = p { beta = val }+sigmaUpd p val = p { sigma = val }+noscUpd p val = p { nosc = val }++-- Need this to be able to make a 'Ref Params'.+--++-- Default values for the system parameters (taken from Bridges &+-- Reich 2001).+--+defaultParams = Params { alpha = 1, omega = 1.8, deven = 0.0075, dodd = 0.0125,+                         beta = 1, sigma = 4, nosc = 5 }+++-- The system state is represented as: [y, x1, ..., xN, y', x1', ..., xN']+-- where y is the position of the external forcing oscillator, x1..xN+-- are the positions of the oscillators in the ring, and y' and+-- x1'..xN' are the time derivatives.  The initial state has some+-- non-zero displacements to get us going and zero velocities.+--+initialState :: Params -> [Double]+initialState p = replicate (nosc p + 1) 1 ++ replicate (nosc p + 1) 0++-- Default initial state.+--+ic = centre defaultParams (initialState defaultParams)++-- Make data storage for scrolling graph view.+--+makeGraphData :: Int -> Int -> Fay (Double,[Buffer])+makeGraphData no size = do+  bufs <- replicateM no (newBuf size)+  return (0,bufs)+++-- Calculate system right hand side, i.e. the equations that determine+-- the time derivative of the system state.+--+rhs :: Params -> [Double] -> [Double]+rhs p state = [dy] ++ dxs ++ [dy'] ++ dxs'+  where n = nosc p++        -- Split system state: Fay doesn't yet allow us to to+        -- something like ((y:xs),(y':xs')) = splitAt (n+1) state, so+        -- we just decompose things manually.+        ss = splitAt (n + 1) state+        sss = fst ss ; sss' = snd ss+        y = head sss ; xs = tail sss+        y' = head sss' ; xs' = tail sss'++        -- Time derivatives of y and the xs are immediately+        -- accessible.+        dy = y' ; dxs = xs'++        -- Forcing system right hand side.+        dy' = 0 - alpha p * (y^2 - 1) * y' - ((omega p)^2::Double) * y++        -- Right hand side for ring oscillators:++        -- Displacement differences.+        xdiffs = (head xs - (xs !! (n - 1))) : zipWith (-) (tail xs) xs++        -- Nonlinear inter-oscillator potential calculation:+        -- V(x) = 1/2 x^2 + 1/4 x^4  =>  V'(x) = x + x^3+        vprime x = x + x^3+        vp = map vprime xdiffs++        -- Differences between adjacent potential values.+        vfacs = zipWith (-) vp (tail vp) ++ [vp !! (n - 1) - head vp]++        -- Damping factors alternate between even and odd numbered+        -- oscillators.+        ds = cycle [dodd p, deven p]++        -- Calculate basic time derivative for each oscillator.+        dxstmp = zipWith3 (\d x' vf -> 0 - d * x' - beta p * vf) ds xs' vfacs++        -- Add forcing term for first oscillator in ring.+        dxs' = (head dxstmp + sigma p * y) : tail dxstmp+++-- Take a single fourth order Runge-Kutta step for an autonomous+-- system.  The arguments are the right hand side function, a system+-- state and a time step.+--+rk4 :: ([Double] -> [Double]) -> [Double] -> Double -> [Double]+rk4 f yn h = zipWith5 (\y a b c d -> y+(a+2*b+2*c+d)/6) yn k1 k2 k3 k4+  where k1 = map mh $ f yn+        k2 = map mh $ f (zipWith (+) yn (map half k1))+        k3 = map mh $ f (zipWith (+) yn (map half k2))+        k4 = map mh $ f (zipWith (+) yn k3)+        mh x = h * x+        half x = 0.5 * x+++-- Because the *velocities* are damped in our model, but not the+-- displacements, there tends to be a more or less linear drift in the+-- average position of the oscillators over time.  This isn't a+-- problem for displaying the positions on the ring, but it's+-- inconvenient for displaying time traces of the positions as a+-- graph.  To make this a bit easier, we centre the oscillator values+-- for graph display by subtracting the mean displacement for the ring+-- oscillators for each ring oscillator.  The forcing displacement and+-- the time derivative values are not affected by this centring, and+-- in fact none of the time derivative calculations for the system are+-- affected either, since they all depend exclusively on *differences*+-- between displacements, not the absolute values of the+-- displacements.+--+centre :: Params -> [Double] -> [Double]+centre p s = [y] ++ xsc ++ [y'] ++ xs'+  where ss = splitAt (nosc p + 1) s+        sss = fst ss ; sss' = snd ss+        y = head sss ; xs = tail sss+        y' = head sss' ; xs' = tail sss'+        m = (sum xs) / fromIntegral (length xs)+        xsc = map (\x->x-m) xs+++-- Display dimensions.+--+ww, wh :: Double                -- Ring canvas dimensions.+ww = 400 ; wh = 400++gww, gwh :: Double              -- Graph canvas dimensions.+gww = 640 ; gwh = 200++-- Other display parameters.+--+dt = 0.025                      -- Integration time step.+framems = 30                    -- Milliseconds between frames.+renderrng = 6.0                 -- Nominal range for graph and ring displays.++-- Sizing for ring view elements.+--+rdotfac, rinner, rdot, fyoff :: Double+rdotfac = 0.0375+rinner = wh / (2 + 7 * rdotfac)+rdot = rdotfac * rinner+fyoff = rinner + 3 * rdot+ctr :: Point+ctr = (0.5 * ww, 5 * rdot + rinner) -- Centre point of ring display.++-- Sizing for graph view elements.+--+gwbuf, ticklen, gwwtime :: Double+gwbuf = 20                      -- Buffer at right end of graph.+ticklen = 10                    -- Graph time tick size.+gwwtime = 10                    -- Time range displayed in graph.+pxpert, pxpersamp :: Double+pxpert = gww / gwwtime          -- Pixels per time unit.+pxpersamp = dt * pxpert         -- Pixels per sample.+nsamp :: Int+nsamp = floor ((gww - gwbuf) / pxpersamp) -- Samples in graph.+++-- Main entry point.  Just register an "onload" handler.+--+main :: Fay ()+main = addWindowEventListener "load" run++-- Main function: runs at load time.+--+run :: Event -> Fay Bool+run _ = do+  -- Get DOM elements and canvas contexts.+  [can,graph] <- mapM getElementById ["canvas","graph"]+  [go,stop,reset] <- mapM getElementById ["go","stop","reset"]+  sels <- mapM getElementById ["alpha","omega","deven","dodd","beta","sigma"]+  noscSel <- getElementById "nosc"+  [c,cg] <- mapM (\c -> getContext c "2d") [can,graph]++  -- Set up references to parameter values, current state, a timer+  -- identifier and the data required for rendering the graph view.+  pref <- newRef defaultParams+  xref <- newRef ic+  timerref <- newRef (Nothing :: Maybe Int)+  gd <- makeGraphData (nosc defaultParams) nsamp+  gdataref <- newRef gd++  -- Render initial ring and graph views.+  render c defaultParams ic renderrng+  renderGraph cg pref gdataref (centre defaultParams ic) renderrng++  -- Event listeners for buttons and parameter value selection.+  addEventListener go "click" $+    doGo timerref (animate c cg pref xref gdataref renderrng) framems+  addEventListener stop "click" $ doStop timerref+  addEventListener reset "click" $ doReset c cg timerref pref xref gdataref sels+  forM_ (zip sels [alphaUpd,omegaUpd,devenUpd,doddUpd,betaUpd,sigmaUpd]) $ \(s, pfn) -> do+    addEventListener s "change" $ doParamChange pref pfn+  addEventListener noscSel "change" $+    doNoscChange c cg timerref pref xref gdataref+  return False+++-- If the simulation isn't currently running (marked by the timer+-- reference being Nothing), start it by causing the animation+-- function to be called at the appropriate interval.+--+doGo :: Ref (Maybe Int) -> Fay () -> Double -> Event -> Fay Bool+doGo tref anim interval _ = do+  oldtimer <- readRef tref+  case oldtimer of+    Nothing -> do+      timer <- setInterval anim interval+      writeRef tref (Just timer)+    Just _ -> return ()+  return False++-- If the simulation is running (marked by the timer reference having+-- a Just value), stop it.+--+doStop :: Ref (Maybe Int) -> Event -> Fay Bool+doStop tref _ = do+  oldtimer <- readRef tref+  case oldtimer of+    Nothing -> return ()+    Just timer -> do+      clearInterval timer+      writeRef tref Nothing+  return False++-- Stop the simulation and set everything back to the state it was at+-- the beginning, including all parameter values (the default values+-- are the middle ones out of five possibilities).+--+doReset :: Context -> Context -> Ref (Maybe Int) -> Ref Params ->+           Ref [Double] -> Ref (Double,[Buffer]) -> [Element] ->+           Event -> Fay Bool+doReset c cg tref pref xref gdataref sels e = do+  doStop tref e+  writeRef pref defaultParams+  writeRef xref ic+  gd <- makeGraphData (nosc defaultParams) nsamp+  writeRef gdataref gd+  render c defaultParams ic renderrng+  renderGraph cg pref gdataref (centre defaultParams ic) renderrng+  forM_ sels $ \s -> setSelectIndex s 2+  return False++-- Simple parameter change: just get the selected value and update the+-- parameter reference.+--+doParamChange :: Ref Params -> (Params -> Double -> Params) -> Event -> Fay Bool+doParamChange pref updfn e = do+  target <- eventTarget e+  sval <- selectValue target+  p <- readRef pref+  writeRef pref (updfn p (parseDouble sval))+  return False++-- A change in number of oscillators is a bit more complicated.  We+-- stop the simulation and reset everything to start over -- there's+-- no obvious way to derive a state with a different number of+-- oscillators from the current state.+--+doNoscChange :: Context -> Context ->+                Ref (Maybe Int) -> Ref Params ->+                Ref [Double] -> Ref (Double,[Buffer]) -> Event -> Fay Bool+doNoscChange c cg timerref pref xref gdataref e = do+  doStop timerref e+  target <- eventTarget e+  sval <- selectValue target+  let newNosc = parseInt sval+  p <- readRef pref+  let pnew = p { nosc = newNosc }+  let xnew = centre pnew (initialState pnew)+  writeRef pref pnew+  writeRef xref xnew+  gd <- makeGraphData newNosc nsamp+  writeRef gdataref gd+  render c pnew xnew renderrng+  renderGraph cg pref gdataref xnew renderrng+  return False+++-- Animation function.  Take a single step of the ODE system and+-- re-render the ring and the graph views.+--+animate :: Context -> Context -> Ref Params -> Ref [Double] ->+           Ref (Double,[Buffer]) -> Double -> Fay ()+animate c cg pref xref gdataref rng = do+  p <- readRef pref+  x <- readRef xref+  let newx = rk4 (rhs p) x dt+  writeRef xref newx+  render c p newx rng+  renderGraph cg pref gdataref (centre p newx) rng+++-- Render the ring view.+--+render :: Context -> Params -> [Double] -> Double -> Fay ()+render c p s rng = do+  -- Extract the forcing and the ring oscillator displacements.+  let f = head s+  let xs = take (nosc p) $ tail s++  -- Draw "furniture": ring and baseline for forcing oscillator.+  clearRect c (0,0) (ww, wh)+  beginPath c+  arc c ctr rinner 0 (2*pi)+  let fscale = rinner * 2 * pi / 5+  moveTo c $ offset ctr (-0.5*fscale,-fyoff)+  lineTo c $ offset ctr (0.5*fscale,-fyoff)+  moveTo c $ offset ctr (0, -dtickin)+  lineTo c $ offset ctr (0, -dtickout)+  setLineWidth c 2+  setStrokeStyle c "grey"+  stroke c++  -- Blobs for ring oscillators: first, forced oscillator is picked+  -- out in blue.+  forM_ [0..(nosc p)-1] (\i -> do+    let th0 = fromIntegral i * 2 * pi / fromIntegral (nosc p)+    let th = th0 + (xs !! i) / rng * 2 * pi / fromIntegral (nosc p)+    let dctr = offset ctr (rinner * sin th, -rinner * cos th)+    beginPath c+    arc c dctr rdot 0 (2*pi)+    setFillStyle c (if i == 0 then "blue" else "red")+    fill c)++  -- Blob for forcing oscillator.+  let dctr = offset ctr (f / rng * fscale, -fyoff)+  beginPath c+  arc c dctr rdot 0 (2*pi)+  setFillStyle c "grey"+  fill c+  where dtickin = fyoff - 0.5 * ticklen+        dtickout = fyoff + 0.5 * ticklen+++-- Render the graph view.+--+renderGraph :: Context -> Ref Params -> Ref (Double,[Buffer]) ->+               [Double] -> Double -> Fay ()+renderGraph cg pref gdataref x rng = do+  -- Get values for parameters and time and state list.+  p <- readRef pref+  (ts,bufs) <- readRef gdataref++  -- Graph "furniture": axes and time ticks.+  setFont cg "10pt sans-serif"+  setStrokeStyle cg "grey"+  setFillStyle cg "grey"+  setLineWidth cg 2+  clearRect cg (0,0) (gww,gwh)+  beginPath cg+  moveTo cg (0,gwh/2)+  lineTo cg (gww,gwh/2)+  moveTo cg (1,0)+  lineTo cg (1,gwh)+  let ticks = takeWhile (\t -> t <= floor (ts + gwwtime)) [floor ts + 1..]+  let tickxs = map (\t -> (fromIntegral t - ts) * pxpert) ticks+  forM_ (zip ticks tickxs) $ \(t,x) -> do+    moveTo cg (x,gwh/2-ticklen/2)+    lineTo cg (x,gwh/2+ticklen/2)+    let txt = show t+    txtw <- measureText cg txt+    fillText cg txt (x-txtw/2,gwh/2+2*ticklen) Nothing+  stroke cg++  -- Add new samples to circular buffers and draw traces: grey for+  -- forcing, blue for forced ring oscillator, red for the other ring+  -- oscillators.+  setLineWidth cg 1+  newbufs <- forM (zip3 x bufs ("grey":"blue":repeat "red")) $ \(newx,buf,col) -> do+    newbuf <- bufAdd buf newx+    beginPath cg+    setStrokeStyle cg col+    y0 <- bufVal newbuf 0+    moveTo cg (0, gwh/2*(1-y0/renderrng))+    when (bufCurSize buf > 1) $ forM_ [1..bufCurSize buf-1] $ \i -> do+      y <- bufVal newbuf i+      lineTo cg (fromIntegral i * pxpersamp, gwh/2*(1-y/renderrng))+    stroke cg+    return newbuf++  -- Update the graph data reference.+  writeRef gdataref (ts+if bufCurSize (head newbufs) < nsamp then 0 else dt,newbufs)+++--------------------------------------------------------------------------------+-- Utilities++zipWith5 :: (a->b->c->d->e->f) -> [a]->[b]->[c]->[d]->[e]->[f]+zipWith5 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) = z a b c d e :+                                                zipWith5 z as bs cs ds es+zipWith5 _ _ _ _ _ _ = []++mapM :: (a -> Fay b) -> [a] -> Fay [b]+mapM m (x:xs) = m x >>= (\mx -> mapM m xs >>= (\mxs -> return (mx:mxs)))+mapM _ [] = return []++forM :: [a] -> (a -> Fay b) -> Fay [b]+forM (x:xs) m = m x >>= (\mx -> mapM m xs >>= (\mxs -> return (mx:mxs)))+forM [] _ = return []++replicateM :: Int -> Fay a -> Fay [a]+replicateM n x = sequence (replicate n x)++parseDouble :: String -> Double+parseDouble = ffi "parseFloat(%1)"++parseInt :: String -> Int+parseInt = ffi "parseInt(%1)"++--------------------------------------------------------------------------------+-- DOM++data Element+instance Show Element++type Size = (Int,Int)++getElementById :: String -> Fay Element+getElementById = ffi "document['getElementById'](%1)"++data Event++addWindowEventListener :: String -> (Event -> Fay Bool) -> Fay ()+addWindowEventListener = ffi "window['addEventListener'](%1,%2,false)"++addEventListener :: Element -> String -> (Event -> Fay Bool) -> Fay ()+addEventListener = ffi "%1['addEventListener'](%2,%3,false)"++setInterval :: Fay () -> Double -> Fay Int+setInterval = ffi "window['setInterval'](%1,%2)"++clearInterval :: Int -> Fay ()+clearInterval = ffi "window['clearInterval'](%1)"++print :: a -> Fay ()+print = ffi "console.log(%1)"++eventTarget :: Event -> Fay Element+eventTarget = ffi "%1['target']"++selectValue :: Element -> Fay String+selectValue = ffi "%1[%1['selectedIndex']]['value']"++setSelectIndex :: Element -> Int -> Fay ()+setSelectIndex = ffi "%1['selectedIndex']=%2"++--------------------------------------------------------------------------------+-- Ref++-- | A mutable reference like IORef.+data Ref a++-- | Make a new mutable reference.+newRef :: a -> Fay (Ref a)+newRef = ffi "new Fay$$Ref(%1)"++-- | Replace the value in the mutable reference.+writeRef :: Ref a -> a -> Fay ()+writeRef = ffi "Fay$$writeRef(%1,%2)"++-- | Get the referred value from the mutable value.+readRef :: Ref a -> Fay a+readRef = ffi "Fay$$readRef(%1)"++--------------------------------------------------------------------------------+-- Canvas API++data Context+instance Show Context++type Point = (Double,Double)+type Dim = (Double,Double)++getContext :: Element -> String -> Fay Context+getContext = ffi "%1.getContext(%2)"++offset :: Point -> Dim -> Point+offset (x,y) (dx,dy) = (x+dx,y+dy)++-- Basic attributes++setFillStyle :: Context -> String -> Fay ()+setFillStyle = ffi "%1['fillStyle']=%2"++setFont :: Context -> String -> Fay ()+setFont = ffi "%1['font']=%2"++setLineWidth :: Context -> Double -> Fay ()+setLineWidth = ffi "%1['lineWidth']=%2"++setStrokeStyle :: Context -> String -> Fay ()+setStrokeStyle = ffi "%1['strokeStyle']=%2"++-- Path methods++arc :: Context -> Point -> Double -> Double -> Double -> Fay ()+arc c (x,y) r beg end = arc' c x y r beg end True++arcC :: Context -> Point -> Double -> Double -> Double -> Fay ()+arcC c (x,y) r beg end = arc' c x y r beg end False++arc' :: Context -> Double -> Double -> Double -> Double -> Double ->+        Bool -> Fay ()+arc' = ffi "%1['arc'](%2,%3,%4,%5,%6,%7)"++beginPath :: Context -> Fay ()+beginPath = ffi "%1['beginPath']()"++clip :: Context -> Fay ()+clip = ffi "%1['clip']()"++closePath :: Context -> Fay ()+closePath = ffi "%1['closePath']()"++fill :: Context -> Fay ()+fill = ffi "%1['fill']()"++lineTo :: Context -> Point -> Fay ()+lineTo c (x,y) = lineTo' c x y++lineTo' :: Context -> Double -> Double -> Fay ()+lineTo' = ffi "%1['lineTo'](%2,%3)"++moveTo :: Context -> Point -> Fay ()+moveTo c (x,y) = moveTo' c x y++moveTo' :: Context -> Double -> Double -> Fay ()+moveTo' = ffi "%1['moveTo'](%2,%3)"++stroke :: Context -> Fay ()+stroke = ffi "%1['stroke']()"++-- Rectangles++clearRect :: Context -> Point -> Dim -> Fay ()+clearRect c (x,y) (w,h) = clearRect' c x y w h++clearRect' :: Context -> Double -> Double -> Double -> Double -> Fay ()+clearRect' = ffi "%1['clearRect'](%2,%3,%4,%5)"++-- Text++fillText :: Context -> String -> Point -> Maybe Double -> Fay ()+fillText c s (x,y) Nothing = fillText1 c s x y+fillText c s (x,y) (Just mw) = fillText2 c s x y mw++fillText1 :: Context -> String -> Double -> Double -> Fay ()+fillText1 = ffi "%1['fillText'](%2,%3,%4)"++fillText2 :: Context -> String -> Double -> Double -> Double -> Fay ()+fillText2 = ffi "%1['fillText'](%2,%3,%4,%5)"++measureText :: Context -> String -> Fay Double+measureText = ffi "%1['measureText'](%2)['width']"+++--------------------------------------------------------------------------------+-- Circular buffers++data Array++data Buffer = Buffer { bufSize :: Int+                     , bufCurSize :: Int+                     , bufNext :: Int+                     , bufArr :: Array }++newBuf :: Int -> Fay Buffer+newBuf size = do+  arr <- newArray size+  return $ Buffer size 0 0 arr++bufAdd :: Buffer -> Double -> Fay Buffer+bufAdd (Buffer sz cursz nxt arr) x = do+  let cursz' = if cursz < sz then cursz + 1 else sz+  setArrayVal arr nxt x+  let nxt' = (nxt + 1) `rem` sz+  return $ Buffer sz cursz' nxt' arr++bufVal :: Buffer -> Int -> Fay Double+bufVal (Buffer sz cursz nxt arr) i = do+  let idx = (if cursz < sz then i else nxt + i) `rem` sz+  arrayVal arr idx >>= return++newArray :: Int -> Fay Array+newArray = ffi "new Array(%1)"++setArrayVal :: Array -> Int -> Double -> Fay ()+setArrayVal = ffi "%1[%2]=%3"++arrayVal :: Array -> Int -> Fay Double+arrayVal = ffi "%1[%2]"

+ examples/oscillator.html view

@@ -0,0 +1,92 @@+<!doctype html>+<html>+<head>+  <meta http-equiv='Content-Type' content='text/html; charset=utf-8'>+  <script type="text/javascript" src="oscillator.js"></script>+  <style>+    .container { width: 100%; margin-left: 0; margin-right: 0; }+    .animation { display: block; float: left; margin-left: 0; margin-right: 0; }+    .controls { display: block; float: left; margin-left: 10px; margin-right: 0; }+    .graph { display: block; float: left; margin-left: 10px; margin-right: 0; }+    .clear { clear: both; }+    .container .animation { width: 400px; }+    .container .controls { width: 200px; }+    .container .graph { width: 640px; }+  </style>+</head>+<body>+  <h1>Ring oscillator demo</h1>++  <div class="container">+    <div class="animation">+      <canvas id="canvas" width=400 height=400></canvas>+    </div>+    <div class="controls">+      <input id="go" type="button" style="background-image: url(play-icon.png); width: 20px;" value="">+      <input id="stop" type="button" style="background-image: url(stop-icon.png); width: 20px;" value="">+      <input id="reset" type="button" value="Reset">++      <p>N = <select id="nosc">+          <option value="3">3</option>+          <option value="4">4</option>+          <option selected value="5">5</option>+          <option value="6">6</option>+          <option value="10">10</option>+        </select>+      <br>+      &alpha; = <select id="alpha">+          <option value="0.6">0.6</option>+          <option value="0.8">0.8</option>+          <option selected value="1">1</option>+          <option value="1.2">1.2</option>+          <option value="1.4">1.4</option>+        </select>+      <br>+      &omega; = <select id="omega">+          <option value="1.0">1</option>+          <option value="1.4">1.4</option>+          <option selected value="1.8">1.8</option>+          <option value="2.2">2.2</option>+          <option value="2.6">2.6</option>+        </select>+      <br>+      d<sub>even</sub> = <select id="deven">+          <option value="0.0025">0.0025</option>+          <option value="0.005">0.005</option>+          <option selected value="0.0075">0.0075</option>+          <option value="0.01">0.01</option>+          <option value="0.0125">0.0125</option>+        </select>+      <br>+      d<sub>odd</sub> = <select id="dodd">+          <option value="0.0075">0.0075</option>+          <option value="0.01">0.01</option>+          <option selected value="0.0125">0.0125</option>+          <option value="0.015">0.015</option>+          <option value="0.0175">0.0175</option>+        </select>+      <br>+      &beta; = <select id="beta">+          <option value="0.6">0.6</option>+          <option value="0.8">0.8</option>+          <option selected value="1">1</option>+          <option value="1.2">1.2</option>+          <option value="1.4">1.4</option>+        </select>+      <br>+      &sigma; = <select id="sigma">+          <option value="2">2</option>+          <option value="3">3</option>+          <option selected value="4">4</option>+          <option value="5">5</option>+          <option value="6">6</option>+        </select>+      </p>+    </div>+    <div class="clear"></div>+    <div class="graph">+      <canvas id="graph" width=640 height=200></canvas>+    </div>+  </div>+</body>+</html>

+ examples/pat.hs view

@@ -0,0 +1,13 @@+import Prelude++import FFI++main :: Fay ()+main =+      case [1,2] of+        []    -> alert "got []"+        [a]   -> alert "got one value."+        [a,b] -> alert "got two values."++alert :: String -> Fay ()+alert = ffi "console.log(%1)"

+ examples/properties.hs view

@@ -0,0 +1,43 @@+{-# LANGUAGE EmptyDataDecls    #-}+++module Dom where++import           FFI+import           Prelude++main :: Fay ()+main = addEventListener "load" updateBody False++updateBody :: Fay ()+updateBody = do+  printList [[1,2,3],[4,5,6]]+  print thebody+  print thewindow+  setInnerHtml thebody "Hai!"+  inner <- getInnerHtml thebody+  print' ("'" ++ inner ++ "'")++printList :: [[Double]] -> Fay ()+printList = ffi "console.log(%1)"++-- | Print using window.print.+print' :: String -> Fay ()+print' = ffi "console['log'](%1)"++addEventListener :: String -> Fay () -> Bool -> Fay ()+addEventListener = ffi "window['addEventListener'](%1,%2,%3)"++setInnerHtml :: Element -> String -> Fay ()+setInnerHtml = ffi "%1['innerHTML']=%2"++getInnerHtml :: Element -> Fay String+getInnerHtml = ffi "%1['innerHTML']"++thebody :: Element+thebody = ffi "document.body"++thewindow :: Element+thewindow = ffi "window"++data Element

+ examples/properties.html view

@@ -0,0 +1,7 @@+<html>+  <head>+    <title></title>+    <script src="properties.js"></script>+  </head>+  <body>Hello!</body>+</html>

+ examples/showExamples.hs view

@@ -0,0 +1,48 @@+import           FFI+import           Prelude++main = do+  let a1 = ("string",1) :: (String,Int)+  putStrLn $ showPair a1+  putStrLn $ showList [1..3]+  putStrLn $ showString "Just a plain string"+  l1 <- readList "[4,5,6]"+  putStrLn . showList . map (1+) $ l1+  (s,i) <- readPair "[\"first\",2]"+  putStrLn $ s ++ " was first and " ++ showInt i ++ " was second"++showInt :: Int -> String+showInt = ffi "JSON.stringify(%1)"++showString :: String -> String+showString = ffi "JSON.stringify(%1)"++showPair :: (String,Int) -> String+showPair = ffi "JSON.stringify(%1)"++showList :: [Int] -> String+showList = ffi "JSON.stringify(%1)"++readList :: String -> Fay [Int]+readList = ffi "JSON.parse(%1)"++readPair :: String -> Fay (String,Int)+readPair = ffi "JSON.parse(%1)"++{-++compile with:+ fay showExamples.hs+run with: (on Debian)+ nodejs showExamples.hs++Produces:++["string",1]+[1,2,3]+"Just a plain string"+[5,6,7]+first was first and 2 was second+++-}

fay.cabal view

@@ -1,5 +1,5 @@ name:                fay-version:             0.18.0.3+version:             0.18.0.4 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,@@ -32,334 +32,36 @@                      src/Fay/FFI.hs extra-source-files:   -- Examples-  examples/alert.hs-  examples/canvaswater.hs-  examples/canvaswater.html-  examples/console.hs-  examples/data.hs-  examples/dom.hs-  examples/haskell.png-  examples/ref.hs-  examples/tailrecursive.hs+  examples/*.hs+  examples/*.html+  examples/*.png   -- Test cases-  tests/asPatternMatch.hs-  tests/asPatternMatch.res-  tests/automatic.hs-  tests/automatic.res-  tests/AutomaticList.hs-  tests/AutomaticList.res-  tests/baseFixities.hs-  tests/baseFixities.res-  tests/basicFunctions.hs-  tests/basicFunctions.res-  tests/Bool.hs-  tests/Bool.res-  tests/case.hs-  tests/case.res-  tests/case2.hs-  tests/case2.res-  tests/caseList.hs-  tests/caseList.res-  tests/caseWildcard.hs-  tests/caseWildcard.res-  tests/Char.hs-  tests/Char.res-  tests/circular.hs-  tests/Compile/CPPMultiLineStrings.hs-  tests/Compile/CPPTypecheck.hs-  tests/Compile/ImportRecords.hs-  tests/Compile/Records.hs-  tests/Compile/StrictWrapper.hs-  tests/Compile/StrictWrapper.res-  tests/CPP.hs-  tests/CPP.res-  tests/curry.hs-  tests/curry.res-  tests/cycle.hs-  tests/cycle.res-  tests/Defined.hs-  tests/Defined.res-  tests/do.hs-  tests/do.res-  tests/doAssingPatternMatch.hs-  tests/doAssingPatternMatch.res-  tests/doBindAssign.hs-  tests/doBindAssign.res-  tests/doLet.hs-  tests/doLet.res-  tests/DoLet2.hs-  tests/DoLet2_partial.res-  tests/DoLet3.hs-  tests/DoLet3_partial.res-  tests/Double.hs-  tests/Double.res-  tests/Double2.hs-  tests/Double2.res-  tests/Double3.hs-  tests/Double3.res-  tests/Double4.hs-  tests/Double4.res-  tests/Either.hs-  tests/Either.res-  tests/emptyMain.hs-  tests/emptyMain.res-  tests/enumFrom.hs-  tests/enumFrom.res-  tests/Eq.hs-  tests/Eq.res-  tests/error.hs-  tests/ExportEThingAll.hs-  tests/ExportEThingAll.res-  tests/ExportEThingAll_Export.hs-  tests/ExportEThingAll_Export.res-  tests/ExportEThingWith.hs-  tests/ExportEThingWith.res-  tests/ExportList.hs-  tests/ExportList.res-  tests/ExportList_A.hs-  tests/ExportList_A.res-  tests/ExportList_B.hs-  tests/ExportList_B.res-  tests/ExportList_C.hs-  tests/ExportList_C.res-  tests/ExportList_D.hs-  tests/ExportList_D.res-  tests/ExportQualified_Export.hs-  tests/ExportQualified_Export.res-  tests/ExportQualified_Import.hs-  tests/ExportQualified_Import.res-  tests/ExportType.hs-  tests/ExportType.res-  tests/ffiExpr.hs-  tests/ffiExpr.res-  tests/ffimunging.hs-  tests/ffimunging.res-  tests/fix.hs-  tests/fix.res-  tests/Floating.hs-  tests/Floating.res-  tests/fromInteger.hs-  tests/fromInteger.res-  tests/fromIntegral.hs-  tests/fromIntegral.res-  tests/FromString/Dep.hs-  tests/FromString/Dep.res-  tests/FromString/DepDep.hs-  tests/FromString/DepDep.res-  tests/FromString/FayText.hs-  tests/FromString/FayText.res-  tests/FromString.hs-  tests/FromString.res-  tests/GADTs_without_records.hs-  tests/GADTs_without_records.res-  tests/guards.hs-  tests/guards.res-  tests/GuardWhere.hs-  tests/GuardWhere.res-  tests/HidePreludeImport.hs-  tests/HidePreludeImport.res-  tests/HidePreludeImport_Import.hs-  tests/HidePreludeImport_Import.res-  tests/Hierarchical/Export.hs-  tests/Hierarchical/Export.res-  tests/Hierarchical/RecordDefined.hs-  tests/Hierarchical/RecordDefined.res-  tests/HierarchicalImport.hs-  tests/HierarchicalImport.res-  tests/ImportHiding.hs-  tests/ImportHiding.res-  tests/ImportIThingAll.hs-  tests/ImportIThingAll.res-  tests/ImportList.hs-  tests/ImportList.res-  tests/ImportList1/A.hs-  tests/ImportList1/A.res-  tests/ImportList1/B.hs-  tests/ImportList1/B.res-  tests/ImportList1/C.hs-  tests/ImportList1/C.res-  tests/ImportListType.hs-  tests/ImportListType.res-  tests/ImportType.hs-  tests/ImportType.res-  tests/ImportType2.hs-  tests/ImportType2.res-  tests/ImportType2I/A.hs-  tests/ImportType2I/A.res-  tests/ImportType2I/B.hs-  tests/ImportType2I/B.res-  tests/infixDataConst.hs-  tests/infixDataConst.res-  tests/Integral.hs-  tests/Integral.res-  tests/ints.hs-  tests/ints.res-  tests/Issue215/B.hs-  tests/Issue215/B.res-  tests/Issue215A.hs-  tests/Issue215A.res-  tests/Js2FayFunc.hs-  tests/Js2FayFunc.res-  tests/LazyOperators.hs-  tests/LazyOperators.res-  tests/linesAndWords.hs-  tests/linesAndWords.res-  tests/List.hs-  tests/List.res-  tests/List2.hs-  tests/List2.res-  tests/listComprehensions.hs-  tests/listComprehensions.res-  tests/listlen.hs-  tests/listlen.res-  tests/ModuleRecordClash/R.hs-  tests/ModuleRecordClash/R.res-  tests/ModuleRecordClash.hs-  tests/ModuleRecordClash.res-  tests/Monad.hs-  tests/Monad.res-  tests/Monad2.hs-  tests/Monad2.res-  tests/mutableReference.hs-  tests/mutableReference.res-  tests/namedFieldPuns.hs-  tests/namedFieldPuns.res-  tests/nameGen.hs-  tests/nameGen.res-  tests/negation.hs-  tests/negation.res-  tests/NestedImporting/A.hs-  tests/NestedImporting/A.res-  tests/NestedImporting.hs-  tests/NestedImporting.res-  tests/NestedImporting2/A.hs-  tests/NestedImporting2/A.res-  tests/NestedImporting2.hs-  tests/NestedImporting2.res-  tests/newtype.hs-  tests/newtype.res-  tests/NewtypeImport_Export.hs-  tests/NewtypeImport_Export.res-  tests/NewtypeImport_Import.hs-  tests/NewtypeImport_Import.res-  tests/Nullable.hs-  tests/Nullable.res-  tests/Num.hs-  tests/Num.res-  tests/nums.hs-  tests/nums.res-  tests/numTheory.hs-  tests/numTheory.res-  tests/Ord.hs-  tests/Ord.res-  tests/pats.hs-  tests/pats.res-  tests/patternGuards.hs-  tests/patternGuards.res-  tests/patternMatchFail.hs-  tests/patternMatchingTuples.hs-  tests/patternMatchingTuples.res-  tests/QualifiedImport/X.hs-  tests/QualifiedImport/X.res-  tests/QualifiedImport/Y.hs-  tests/QualifiedImport/Y.res-  tests/QualifiedImport.hs-  tests/QualifiedImport.res-  tests/Ratio.hs-  tests/Ratio.res-  tests/RealFrac.hs-  tests/RealFrac.res-  tests/RecCon.hs-  tests/RecCon.res-  tests/RecDecl.hs-  tests/RecDecl.res-  tests/recordFunctionPatternMatch.hs-  tests/recordFunctionPatternMatch.res-  tests/RecordImport2_Export1.hs-  tests/RecordImport2_Export1.res-  tests/RecordImport2_Export2.hs-  tests/RecordImport2_Export2.res-  tests/RecordImport2_Import.hs-  tests/RecordImport2_Import.res-  tests/RecordImport_Export.hs-  tests/RecordImport_Export.res-  tests/RecordImport_Import.hs-  tests/RecordImport_Import.res-  tests/recordPatternMatch.hs-  tests/recordPatternMatch.res-  tests/recordPatternMatch2.hs-  tests/recordPatternMatch2.res-  tests/records.hs-  tests/records.res-  tests/recordUseBeforeDefine.hs-  tests/recordUseBeforeDefine.res-  tests/recordWildCards.hs-  tests/recordWildCards_partial.res-  tests/recursive.hs-  tests/recursive.res-  tests/ReExport1.hs-  tests/ReExport1.res-  tests/ReExport2.hs-  tests/ReExport2.res-  tests/ReExport3.hs-  tests/ReExport3.res-  tests/ReExportGlobally/A.hs-  tests/ReExportGlobally/A.res-  tests/ReExportGlobally.hs-  tests/ReExportGlobally.res-  tests/ReExportGloballyExplicit.hs-  tests/ReExportGloballyExplicit.res-  tests/reservedWords.hs-  tests/reservedWords.res-  tests/sections.hs-  tests/sections.res-  tests/seq-fake.hs-  tests/seq-fake.res-  tests/seq.hs-  tests/serialization.hs-  tests/serialization.res-  tests/Sink.hs-  tests/Sink.res-  tests/SkipLetTypes.hs-  tests/SkipLetTypes.res-  tests/SkipWhereTypes.hs-  tests/SkipWhereTypes.res-  tests/String.hs-  tests/String.res-  tests/StringForcing.hs-  tests/StringForcing.res-  tests/succPred.hs-  tests/succPred.res-  tests/T190.hs-  tests/T190.res-  tests/T190_A.hs-  tests/T190_A.res-  tests/T190_B.hs-  tests/T190_B.res-  tests/T190_C.hs-  tests/T190_C.res-  tests/tailRecursion.hs-  tests/tailRecursion.res-  tests/then.hs-  tests/then.res-  tests/TupleCalls.hs-  tests/TupleCalls.res-  tests/tupleCon.hs-  tests/tupleCon.res-  tests/TyVarSerialization.hs-  tests/TyVarSerialization.res-  tests/unit.hs-  tests/unit.res-  tests/utf8.hs-  tests/utf8.res-  tests/where.hs-  tests/where.res-  tests/whereBind.hs-  tests/whereBind.res-  tests/whereBind2.hs-  tests/whereBind2.res-  tests/whereBind3.hs-  tests/whereBind3.res+  tests/*.hs+  tests/*.res+  tests/Compile/*.hs+  tests/Compile/*.res+  tests/FromString/*.hs+  tests/FromString/*.res+  tests/Hierarchical/*.hs+  tests/Hierarchical/*.res+  tests/ImportList1/*.hs+  tests/ImportList1/*.res+  tests/ImportType2I/*.hs+  tests/ImportType2I/*.res+  tests/Issue215/*.hs+  tests/Issue215/*.res+  tests/ModuleReExport/*.hs+  tests/ModuleReExport/*.res+  tests/ModuleRecordClash/*.hs+  tests/ModuleRecordClash/*.res+  tests/NestedImporting/*.hs+  tests/NestedImporting/*.res+  tests/NestedImporting2/*.hs+  tests/NestedImporting2/*.res+  tests/QualifiedImport/*.hs+  tests/QualifiedImport/*.res+  tests/ReExportGlobally/*.hs+  tests/ReExportGlobally/*.res  source-repository head   type: git

js/runtime.js view

@@ -148,14 +148,14 @@   if(base == "action") {     // A nullary monadic action. Should become a nullary JS function.     // Fay () -> function(){ return ... }-    jsObj = function(){+    return function(){       return Fay$$fayToJs(args[0],Fay$$_(fayObj,true).value);     };    }   else if(base == "function") {     // A proper function.-    jsObj = function(){+    return function(){       var fayFunc = fayObj;       var return_type = args[args.length-1];       var len = args.length;@@ -196,7 +196,7 @@    }   else if(base == "string") {-    jsObj = Fay$$fayToJs_string(fayObj);+    return Fay$$fayToJs_string(fayObj);   }   else if(base == "list") {     // Serialize Fay list to JavaScript array.@@ -206,7 +206,7 @@       arr.push(Fay$$fayToJs(args[0],fayObj.car));       fayObj = Fay$$_(fayObj.cdr);     }-    jsObj = arr;+    return arr;   }   else if(base == "tuple") {     // Serialize Fay tuple to JavaScript array.@@ -217,56 +217,47 @@       arr.push(Fay$$fayToJs(args[i++],fayObj.car));       fayObj = Fay$$_(fayObj.cdr);     }-    jsObj = arr;-+    return arr;   }   else if(base == "defined") {     fayObj = Fay$$_(fayObj);-    if (fayObj instanceof Fay.FFI._Undefined) {-      jsObj = undefined;-    } else {-      jsObj = Fay$$fayToJs(args[0],fayObj.slot1);-    }-+    return fayObj instanceof Fay.FFI._Undefined+      ? undefined+      : Fay$$fayToJs(args[0],fayObj.slot1);   }   else if(base == "nullable") {     fayObj = Fay$$_(fayObj);-    if (fayObj instanceof Fay.FFI._Null) {-      jsObj = null;-    } else {-      jsObj = Fay$$fayToJs(args[0],fayObj.slot1);-    }-+    return fayObj instanceof Fay.FFI._Null+      ? null+      : Fay$$fayToJs(args[0],fayObj.slot1);   }   else if(base == "double" || base == "int" || base == "bool") {     // Bools are unboxed.-    jsObj = Fay$$_(fayObj);-+    return Fay$$_(fayObj);   }   else if(base == "ptr" || base == "unknown")     return 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 Function) {-      jsObj = Fay$$fayToJs(["function", "automatic_function"], fayObj);-    } else if(fayObj instanceof Fay$$Cons || fayObj === null){+    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);       }-      jsObj = arr;+      return arr;     } else {       var fayToJsFun = fayObj && fayObj.instance && Fay$$fayToJsHash[fayObj.instance];-      jsObj = fayToJsFun ? fayToJsFun(type,type[2],fayObj) : fayObj;+      return fayToJsFun ? fayToJsFun(type,type[2],fayObj) : fayObj;     }   }-  else-    throw new Error("Unhandled Fay->JS translation type: " + base);-  return jsObj;++  throw new Error("Unhandled Fay->JS translation type: " + base); }  // Stores the mappings from fay types to js objects.@@ -304,7 +295,7 @@   var fayObj;   if(base == "action") {     // Unserialize a "monadic" JavaScript return value into a monadic value.-    fayObj = new Fay$$Monad(Fay$$jsToFay(args[0],jsObj));+    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.@@ -340,19 +331,18 @@           }         };       };-      fayObj = makePartial([]);-    }-    else {-      fayObj =-        function (arg)-        {-           return Fay$$jsToFay(["automatic"], jsObj(Fay$$fayToJs(["automatic"], arg)));-        };+      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).-    fayObj = Fay$$list(jsObj);+    // 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]).@@ -362,8 +352,7 @@       serializedList.push(Fay$$jsToFay(args[0],jsObj[i]));     }     // Pop it all in a Fay list.-    fayObj = Fay$$list(serializedList);-+    return Fay$$list(serializedList);   }   else if(base == "tuple") {     // Unserialize a JS array into a Fay tuple ((a,b,c,...)).@@ -373,24 +362,17 @@       serializedTuple.push(Fay$$jsToFay(args[i],jsObj[i]));     }     // Pop it all in a Fay list.-    fayObj = Fay$$list(serializedTuple);-+    return Fay$$list(serializedTuple);   }   else if(base == "defined") {-    if (jsObj === undefined) {-      fayObj = new Fay.FFI._Undefined();-    } else {-      fayObj = new Fay.FFI._Defined(Fay$$jsToFay(args[0],jsObj));-    }-+    return jsObj === undefined+      ? new Fay.FFI._Undefined()+      : new Fay.FFI._Defined(Fay$$jsToFay(args[0],jsObj));   }   else if(base == "nullable") {-    if (jsObj === null) {-      fayObj = new Fay.FFI._Null();-    } else {-      fayObj = new Fay.FFI.Nullable(Fay$$jsToFay(args[0],jsObj));-    }-+    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.@@ -398,7 +380,7 @@     // 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" ||@@ -406,30 +388,29 @@            base ==  "unknown") {     return 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" || base == "user") {     if (jsObj && jsObj['instance']) {       var jsToFayFun = Fay$$jsToFayHash[jsObj["instance"]];-      fayObj = jsToFayFun ? jsToFayFun(type,type[2],jsObj) : jsObj;+      return jsToFayFun ? jsToFayFun(type,type[2],jsObj) : jsObj;     }     else if (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);       }-      fayObj = list;-    }-    else if (jsObj instanceof Function) {-      var type = [["automatic"]];-      for (var i = 0; i < jsObj.length; i++)-        type.push(["automatic"]);-      return Fay$$jsToFay(["function", type], jsObj);+      return list;     }     else-      fayObj = jsObj;-+      return jsObj;   }-  else { throw new Error("Unhandled JS->Fay translation type: " + base); }-  return fayObj;++  throw new Error("Unhandled JS->Fay translation type: " + base); }  // Stores the mappings from js objects to fay types.

src/Fay/Compiler/Typecheck.hs view

@@ -31,7 +31,9 @@           [ "-fno-code"           , "-XNoImplicitPrelude"           , "-hide-package base"-          , "-cpp", "-pgmPcpphs", "-optP--cpp", "-DFAY=1"+          , "-cpp", "-pgmPcpphs", "-optP--cpp"+          , "-optP-C" -- Don't let hse-cpp remove //-style comments.+          , "-DFAY=1"           , "-main-is"           , "Language.Fay.DummyMain"           , "-i" ++ intercalate ":" includeDirs

src/tests/Tests.hs view

@@ -13,9 +13,11 @@ import           Fay.System.Process.Extra  import           Control.Applicative+import           Data.Char import           Data.Default import           Data.List import           Data.Maybe+import           Data.Ord import           System.Directory import           System.Environment import           System.FilePath@@ -43,7 +45,7 @@ -- | Make the case-by-case unit tests. makeCompilerTests :: Maybe FilePath -> Maybe FilePath -> IO Test makeCompilerTests packageConf basePath = do-  files <- sort . filter (\v -> not (isInfixOf "/Compile/" v) && not (isInfixOf "/regressions/" v)) . filter (isSuffixOf ".hs") <$> getRecursiveContents "tests"+  files <- sortBy (comparing (map toLower)) . filter (\v -> not (isInfixOf "/Compile/" v) && not (isInfixOf "/regressions/" v)) . filter (isSuffixOf ".hs") <$> getRecursiveContents "tests"   return $ testGroup "Tests" $ flip map files $ \file -> testCase file $ do     testFile packageConf basePath False file     testFile packageConf basePath True file

+ tests/JsFunctionPassing.hs view

@@ -0,0 +1,22 @@+{-# LANGUAGE EmptyDataDecls #-}++import           FFI+import           Prelude++data Func++makeFunc0 :: Int -> Func+makeFunc0 = ffi "function() {return %1;}"++callFunc0 :: Func -> Fay Int+callFunc0 = ffi "%1()"++makeFunc1 :: Int -> Func+makeFunc1 = ffi "function(x) {return %1;}"++callFunc1 :: Func -> Fay Int+callFunc1 = ffi "%1(1)"++main = do+  callFunc0 (makeFunc0 1) >>= print+  callFunc1 (makeFunc1 2) >>= print

+ tests/JsFunctionPassing.res view

@@ -0,0 +1,2 @@+1+2

+ tests/ModuleReExport/ExportsIdentifier.hs view

@@ -0,0 +1,8 @@+module ModuleReExport.ExportsIdentifier where++import Prelude++div :: () -> String+div _ = "I am the identifier!"++div' = "bob"

+ tests/ModuleReExport/ExportsIdentifier.res view

+ tests/ModuleReExport/ExportsModule.hs view

@@ -0,0 +1,14 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}++module ModuleReExport.ExportsModule+  ( module ModuleReExport.ExportsIdentifier+  , module Prelude+  , foo+  )+  where++import ModuleReExport.ExportsIdentifier+import Prelude hiding (div)++foo = div

+ tests/ModuleReExport/ExportsModule.res view

+ tests/ModuleReExports.hs view

@@ -0,0 +1,7 @@+{-# LANGUAGE NamedFieldPuns #-}++module ModuleReExports where++import ModuleReExport.ExportsModule++main = putStrLn (div ())

+ tests/ModuleReExports.res view

@@ -0,0 +1,1 @@+I am the identifier!