diff --git a/examples/CodeWorld.hs b/examples/CodeWorld.hs new file mode 100644 --- /dev/null +++ b/examples/CodeWorld.hs @@ -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 () diff --git a/examples/CodeWorldMain.hs b/examples/CodeWorldMain.hs new file mode 100644 --- /dev/null +++ b/examples/CodeWorldMain.hs @@ -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 diff --git a/examples/Cont.hs b/examples/Cont.hs new file mode 100644 --- /dev/null +++ b/examples/Cont.hs @@ -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 (>>=*) = (>>=) diff --git a/examples/FayFromJs.hs b/examples/FayFromJs.hs new file mode 100644 --- /dev/null +++ b/examples/FayFromJs.hs @@ -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) diff --git a/examples/FayFromJs.html b/examples/FayFromJs.html new file mode 100644 --- /dev/null +++ b/examples/FayFromJs.html @@ -0,0 +1,36 @@ + + + + + + + + + + + + diff --git a/examples/Separated.hs b/examples/Separated.hs new file mode 100644 --- /dev/null +++ b/examples/Separated.hs @@ -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 diff --git a/examples/X.hs b/examples/X.hs new file mode 100644 --- /dev/null +++ b/examples/X.hs @@ -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 diff --git a/examples/Y.hs b/examples/Y.hs new file mode 100644 --- /dev/null +++ b/examples/Y.hs @@ -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 diff --git a/examples/alert.html b/examples/alert.html new file mode 100644 --- /dev/null +++ b/examples/alert.html @@ -0,0 +1,8 @@ + + + + + + + + diff --git a/examples/calc.hs b/examples/calc.hs new file mode 100644 --- /dev/null +++ b/examples/calc.hs @@ -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 "" + 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 "
" & appendTo body + dtr <- select "" & appendTo table + select "" & appendTo dtr & append display + forM_ buttons $ \row -> do + tr <- select "" & appendTo table + forM_ row $ \(text,action) -> do + td <- select "" & appendTo tr + select "" + & 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)" diff --git a/examples/calc.html b/examples/calc.html new file mode 100644 --- /dev/null +++ b/examples/calc.html @@ -0,0 +1,16 @@ + + + + Calc + + + + + + +

Calc

+

A clone of Pit's calculator app

+

JS generated by Fay, a Haskell + subset. Source code

+ + diff --git a/examples/codeworld.html b/examples/codeworld.html new file mode 100644 --- /dev/null +++ b/examples/codeworld.html @@ -0,0 +1,9 @@ + + + + + + + + + diff --git a/examples/dom.html b/examples/dom.html new file mode 100644 --- /dev/null +++ b/examples/dom.html @@ -0,0 +1,8 @@ + + + + + + + + diff --git a/examples/jquery.hs b/examples/jquery.hs new file mode 100644 --- /dev/null +++ b/examples/jquery.hs @@ -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)" diff --git a/examples/jquery.html b/examples/jquery.html new file mode 100644 --- /dev/null +++ b/examples/jquery.html @@ -0,0 +1,10 @@ + + + jQuery demo + + + + + + + diff --git a/examples/json.hs b/examples/json.hs new file mode 100644 --- /dev/null +++ b/examples/json.hs @@ -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)" diff --git a/examples/node.hs b/examples/node.hs new file mode 100644 --- /dev/null +++ b/examples/node.hs @@ -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)" diff --git a/examples/nqueens.hs b/examples/nqueens.hs new file mode 100644 --- /dev/null +++ b/examples/nqueens.hs @@ -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()" diff --git a/examples/obj.hs b/examples/obj.hs new file mode 100644 --- /dev/null +++ b/examples/obj.hs @@ -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)" diff --git a/examples/oscillator.hs b/examples/oscillator.hs new file mode 100644 --- /dev/null +++ b/examples/oscillator.hs @@ -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]" diff --git a/examples/oscillator.html b/examples/oscillator.html new file mode 100644 --- /dev/null +++ b/examples/oscillator.html @@ -0,0 +1,92 @@ + + + + + + + + +

Ring oscillator demo

+ +
+
+ +
+
+ + + + +

N = +
+ α = +
+ ω = +
+ deven = +
+ dodd = +
+ β = +
+ σ = +

+
+
+
+ +
+
+ + diff --git a/examples/pat.hs b/examples/pat.hs new file mode 100644 --- /dev/null +++ b/examples/pat.hs @@ -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)" diff --git a/examples/properties.hs b/examples/properties.hs new file mode 100644 --- /dev/null +++ b/examples/properties.hs @@ -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 diff --git a/examples/properties.html b/examples/properties.html new file mode 100644 --- /dev/null +++ b/examples/properties.html @@ -0,0 +1,7 @@ + + + + + + Hello! + diff --git a/examples/showExamples.hs b/examples/showExamples.hs new file mode 100644 --- /dev/null +++ b/examples/showExamples.hs @@ -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 + + +-} diff --git a/fay.cabal b/fay.cabal --- a/fay.cabal +++ b/fay.cabal @@ -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 diff --git a/js/runtime.js b/js/runtime.js --- a/js/runtime.js +++ b/js/runtime.js @@ -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. diff --git a/src/Fay/Compiler/Typecheck.hs b/src/Fay/Compiler/Typecheck.hs --- a/src/Fay/Compiler/Typecheck.hs +++ b/src/Fay/Compiler/Typecheck.hs @@ -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 diff --git a/src/tests/Tests.hs b/src/tests/Tests.hs --- a/src/tests/Tests.hs +++ b/src/tests/Tests.hs @@ -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 diff --git a/tests/JsFunctionPassing.hs b/tests/JsFunctionPassing.hs new file mode 100644 --- /dev/null +++ b/tests/JsFunctionPassing.hs @@ -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 diff --git a/tests/JsFunctionPassing.res b/tests/JsFunctionPassing.res new file mode 100644 --- /dev/null +++ b/tests/JsFunctionPassing.res @@ -0,0 +1,2 @@ +1 +2 diff --git a/tests/ModuleReExport/ExportsIdentifier.hs b/tests/ModuleReExport/ExportsIdentifier.hs new file mode 100644 --- /dev/null +++ b/tests/ModuleReExport/ExportsIdentifier.hs @@ -0,0 +1,8 @@ +module ModuleReExport.ExportsIdentifier where + +import Prelude + +div :: () -> String +div _ = "I am the identifier!" + +div' = "bob" diff --git a/tests/ModuleReExport/ExportsIdentifier.res b/tests/ModuleReExport/ExportsIdentifier.res new file mode 100644 --- /dev/null +++ b/tests/ModuleReExport/ExportsIdentifier.res diff --git a/tests/ModuleReExport/ExportsModule.hs b/tests/ModuleReExport/ExportsModule.hs new file mode 100644 --- /dev/null +++ b/tests/ModuleReExport/ExportsModule.hs @@ -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 diff --git a/tests/ModuleReExport/ExportsModule.res b/tests/ModuleReExport/ExportsModule.res new file mode 100644 --- /dev/null +++ b/tests/ModuleReExport/ExportsModule.res diff --git a/tests/ModuleReExports.hs b/tests/ModuleReExports.hs new file mode 100644 --- /dev/null +++ b/tests/ModuleReExports.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE NamedFieldPuns #-} + +module ModuleReExports where + +import ModuleReExport.ExportsModule + +main = putStrLn (div ()) diff --git a/tests/ModuleReExports.res b/tests/ModuleReExports.res new file mode 100644 --- /dev/null +++ b/tests/ModuleReExports.res @@ -0,0 +1,1 @@ +I am the identifier!