packages feed

sneathlane-haste (empty) → 1

raw patch · 5 files changed

+601/−0 lines, 5 filesdep +basedep +haste-compilerdep +haste-libsetup-changed

Dependencies added: base, haste-compiler, haste-lib

Files

+ LICENSE view
@@ -0,0 +1,26 @@+Copyright (c) 2015, Jason Priestley+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the+   distribution.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ SneathLane.hs view
@@ -0,0 +1,337 @@+{-# LANGUAGE KindSignatures, RankNTypes, GADTs, OverloadedStrings #-}++module SneathLane+       (+         -- * Widgets+         Widget(..),+         WidgetFocus(..),+         zipW,++         -- * Build Widgets+         graphicWidget,+         above,+         beside,++         -- * Run Widgets+         runOnCanvas,++         -- * Graphics+         GraphicTree(..),+         graphicList,+         graphicTreeBounds,++         -- * Events+         MouseButton(..),+         Key,++         -- * Utility+         balancedFold,++         -- * Type synonyms+         Output,+         CombineGraphics,+         Animate,+         MouseOut,+         HandleKey,+         TimeDifference+       )+       where++import Control.Applicative (Applicative(..), liftA2)+import Control.Monad (mplus)+import Data.Functor ((<$))+import Data.Maybe (fromMaybe)+import Data.IORef (newIORef, readIORef, writeIORef, modifyIORef)++import Haste (elemById, writeLog, onEvent, setTimeout, focus, blur, mkCallback, attr, style, set, (=:), Event (..), Elem, JSFun, JSString)+import Haste.Foreign (ffi)+import SneathLane.Graphics++-- | Which mouse button (if any) was being pressed+data MouseButton = NoButton | LeftButton++type Key = Int++-- | A tree of graphics, used as widget output type. FMap functions are stored in the tree+-- instead of being mapped over the leaves, so that tree reconstruction is fast when a widget changes.+-- This is why GraphicTree is a GADT.+--+-- Offset: a sub-tree translated by a point+--+-- Branch: Two sub-trees; graphicTreeBounds are cached for each+--+-- Leaf: A leaf, consisting of a single graphic element+--+-- FMap: A graphic tree composed with a function.++data GraphicTree :: * -> * where+  Offset :: Point -> GraphicTree a -> GraphicTree a+  Branch :: Rect -> GraphicTree a -> Rect -> GraphicTree a -> GraphicTree a+  Leaf :: Graphic -> GraphicTree ()+  FMap :: (a -> b) -> GraphicTree a -> GraphicTree b++instance Functor GraphicTree where+  fmap = FMap++-- | Construct a graphic tree from a nonempty list of graphics.+graphicList :: [Graphic] -> GraphicTree ()+graphicList gs = balancedFold (\g g' -> Branch (graphicTreeBounds g) g (graphicTreeBounds g') g') (map (\g -> Leaf g) gs)++-- | Apply a fold in a balanced fashion over a list. Recommended for+-- combining lists of widgets, so that the widget tree has+-- logarithmic depth.++balancedFold :: (a -> a -> a) -> [a] -> a+balancedFold _ [] = error "balancedFold: empty list"+balancedFold _ [x] = x+balancedFold fn xs = balancedFold fn (combinePairs xs)+  where+    combinePairs [] = []+    combinePairs [x] = [x]+    combinePairs (x:y:xs') = fn x y : combinePairs xs'+++graphicAtPoint :: Point -> GraphicTree a -> Maybe (Point, a)+graphicAtPoint (x,y) gt = case gt of+  Offset (x',y') gt' -> graphicAtPoint (x - x', y - y') gt'+  Branch bounds gt' bounds' gt'' ->+    case ((x,y) `inRect` bounds, (x,y) `inRect` bounds') of+      (False, False) -> Nothing+      (False, True) -> graphicAtPoint (x,y) gt''+      (True, False) -> graphicAtPoint (x,y) gt'+      (True, True) -> graphicAtPoint (x,y) gt'' `mplus` graphicAtPoint (x,y) gt'+  Leaf g -> if (x,y) `inGraphic` g then Just ((x,y), ()) else Nothing+  FMap fn gt' -> fmap (\(pt,a) -> (pt, fn a)) (graphicAtPoint (x,y) gt')+++drawGraphicTree :: Canvas -> GraphicTree a -> IO ()+drawGraphicTree canv gt = render canv $ go (0,0) gt+  where+    go :: Point -> GraphicTree a -> Picture ()+    go (x,y) (Offset (x',y') gt') = go (x + x', y + y') gt'+    go pt (Branch _ gt' _ gt'') = go pt gt' >> go pt gt''+    go pt (FMap _ gt') = go pt gt'+    go pt (Leaf g) = drawGraphic g pt+++-- | Find a rectangle containing the entire contents of the graphic tree+graphicTreeBounds :: GraphicTree a -> Rect+graphicTreeBounds gt = case gt of+  Offset (x,y) gt' -> let (Rect x' y' w h) = graphicTreeBounds gt' in Rect (x+x') (y+y') w h+  Branch (Rect x y w h) _ (Rect x' y' w' h') _ -> Rect (min x x') (min y y') (max (x + w) (x' + w') - min x x') (max (y + h) (y' + h') - min y y')+  FMap _ gt' -> graphicTreeBounds gt'+  Leaf g -> graphicBounds g++type Output a = GraphicTree ((Point,MouseButton) -> a)++type MouseOut a = a++type HandleKey a = Key -> a++type TimeDifference = Double++type Animate a = TimeDifference -> a++-- | Atom of a sneath lane application+data Widget z = Finish z+              | Continue (Output (Widget z)) (Maybe (MouseOut (Widget z))) (Maybe (Animate (Widget z))) (WidgetFocus z)++-- | Determines the focus behavior of the widget+data WidgetFocus z = NotFocusable -- ^ Widget can not take keyboard focus+                   | Focusable (Widget z) (Widget z) -- ^ Widget can take keyboard focus, but does not have it now+                   | Focused (Widget z) (Widget z, Bool) (Widget z, Bool) (HandleKey (Widget z)) -- ^ Widget has keyboard focus++type CombineGraphics a = GraphicTree a -> GraphicTree a -> GraphicTree a++-- | Combine two widgets to run in parallel as a single widget+zipW :: CombineGraphics ((Point, MouseButton) -> Widget z) -> Widget z -> Widget z -> Widget z++bindW :: (a -> Widget b) -> Widget a -> Widget b+bindW fn (Finish w) = fn w+bindW fn (Continue out mouseOut anim foc) =+  let+    out' = (fmap.fmap) (bindW fn) out+    mouseOut' = fmap (bindW fn) mouseOut+    anim' = (fmap.fmap) (bindW fn) anim+    foc' = case foc of+      NotFocusable -> NotFocusable+      Focusable fromLeft fromRight -> Focusable (bindW fn fromLeft) (bindW fn fromRight)+      Focused blur (tabLeft,ld) (tabRight,rd) key -> Focused (bindW fn blur) (bindW fn tabLeft,ld) (bindW fn tabRight,rd) (fmap (bindW fn) key)+  in Continue out' mouseOut' anim' foc'++instance Functor Widget where+  fmap fn = bindW (Finish . fn)++instance Applicative Widget where+  pure = Finish++  (<*>) wf w = bindW (\fn -> bindW (Finish . fn) w) wf++instance Monad Widget where+  return = Finish++  (>>=) = flip bindW+++zipW comb lw rw = case (lw, rw) of+  (Finish z, _) -> Finish z+  (_, Finish z) -> Finish z++  (Continue _ _ _ (Focused blur _ _ _), Continue _ _ _ (Focused _ _ _ _)) -> zipW comb blur rw++  (Continue out mouseOut anim foc, Continue out' mouseOut' anim' foc') ->+    let+      updateLeft lw' rw' = case (lw', rw') of+        (Continue _ _ _ (Focused _ _ _ _), Continue _ _ _ (Focused blur _ _ _)) -> zipW comb lw' blur+        _ -> zipW comb lw' rw'++      out'' = comb+              ((fmap.fmap) (\lw' -> updateLeft lw' (fromMaybe rw mouseOut')) out)+              ((fmap.fmap) (\rw' -> zipW comb (fromMaybe lw mouseOut) rw') out')++      mouseOut'' = case (mouseOut, mouseOut') of+        (Nothing, Nothing) -> Nothing+        (Just lw', Nothing) -> Just $ updateLeft lw' rw+        (_, Just rw') -> Just $ zipW comb (fromMaybe lw mouseOut) rw'++      anim'' = case (anim, anim') of+        (Nothing, Nothing) -> Nothing+        (Just animFn, Nothing) -> Just $ \t -> updateLeft (animFn t) rw+        (_, Just animFn') -> Just $ liftA2 (zipW comb) (fromMaybe (const lw) anim) animFn'++      foc'' = case (foc, foc') of+        (NotFocusable, NotFocusable) -> NotFocusable+        (Focused _ _ _ _, Focused _ _ _ _) -> error "paired focus elements should cause blur above"++        (NotFocusable, Focusable fromLeft fromRight) -> Focusable (zipW comb lw fromLeft) (zipW comb lw fromRight)+        (Focusable fromLeft fromRight, NotFocusable) -> Focusable (updateLeft fromLeft rw) (updateLeft fromRight rw)+        (Focusable fromLeft _, Focusable _ fromRight) -> Focusable (updateLeft fromLeft rw) (zipW comb lw fromRight)++        (Focused blur (tabLeft,ld) (tabRight,False) key, Focusable fromLeft _) ->+          Focused (updateLeft blur rw) (updateLeft tabLeft rw, ld) (updateLeft tabRight fromLeft, True) (fmap (\lw' -> updateLeft lw' rw) key)+        (Focusable _ fromRight, Focused blur (tabLeft,False) (tabRight,rd) key) ->+          Focused (zipW comb lw blur) (zipW comb fromRight tabLeft, True) (zipW comb lw tabRight, rd) (fmap (\rw' -> zipW comb lw rw') key)++        (Focused blur (tabLeft,ld) (tabRight,rd) key, _) ->+          Focused (updateLeft blur rw) (updateLeft tabLeft rw, ld) (updateLeft tabRight rw, rd) (fmap (\lw' -> updateLeft lw' rw) key)+        (_, Focused blur (tabLeft,ld) (tabRight,rd) key) ->+          Focused (zipW comb lw blur) (zipW comb lw tabLeft, ld) (zipW comb lw tabRight, rd) (fmap (\rw' -> zipW comb lw rw') key)+    in Continue out'' mouseOut'' anim'' foc''+++jsNow :: IO Double+jsNow = ffi "(function() { return new Date().getTime(); })"++jsKeyDown :: Elem -> (Int -> Bool -> IO Bool) -> IO ()+jsKeyDown = ffi "(function(elem, onKey) { elem.addEventListener('keydown', function(ev) { if(!onKey(ev.keyCode,ev.shiftKey)){ev.preventDefault();} })})"++jsRequestAnimationFrame :: (() -> IO ()) -> IO ()+jsRequestAnimationFrame = ffi "(function(fn) { window.requestAnimationFrame(fn); })"++-- | Run the widget on the canvas element with ID "canvas"+runOnCanvas :: String -> Double -> Double -> (forall z. Widget z) -> IO ()+runOnCanvas elemId width height w = do+  wref <- newIORef w+  Just ce <- elemById elemId+  set ce [attr "width" =: show (pixelRatio * width),+          attr "height" =: show (pixelRatio * height),+          style "width" =: (show width ++ "px"),+          style "height" =: (show height ++ "px")]+  (Just canvas) <- getCanvas ce+  ce `onEvent` OnMouseDown $ (\_ pt -> modifyIORef wref (mouseEvent (fromIntegral $ fst pt, fromIntegral $ snd pt) LeftButton) >> adjustFocus ce wref)+  ce `onEvent` OnMouseMove $ (\pt -> modifyIORef wref (mouseEvent (fromIntegral $ fst pt, fromIntegral $ snd pt) NoButton) >> adjustFocus ce wref)+  jsKeyDown ce (\key shift -> keyEvent wref key shift)+  --ce `onEvent` OnKeyDown $ (\key -> modifyIORef wref (keyEvent key) >> adjustFocus ce wref)++  tm <- jsNow+  renderFrame 16.0 tm canvas wref+  return ()+    where+      adjustFocus ce wref = do+        Continue _ _ _ foc <- readIORef wref+        case foc of+          Focused _ _ _ _ -> focus ce+          _ -> blur ce++      renderFrame mspf prevTime canvas wref = do+        Continue out _ anim _ <- readIORef wref+        drawGraphicTree canvas out+        tm <- jsNow+        case anim of+          Just fn -> writeIORef wref (fn $ tm - prevTime)+          _ -> return ()+        let mspf' = mspf*0.95 + (tm - prevTime)*0.05+        --writeLog (show $ floor $ 1000/mspf')+        jsRequestAnimationFrame (\_ -> renderFrame mspf' tm canvas wref)++      mouseEvent _ _ (Finish _) = error "top-level finish"+      mouseEvent pt button w'@(Continue out mouseOut _ _) =+        case graphicAtPoint pt out of+          Nothing -> fromMaybe w' mouseOut+          Just (oset, fw) -> fw (oset, button)++      keyEvent wref key shift = do+        Continue _ _ _ foc <- readIORef wref+        case (key,shift) of+          (9,False) -> case foc of+            Focused _ _ (tabRight, rd) _ -> writeIORef wref tabRight >> return (not rd)+            Focusable fromLeft _ -> writeIORef wref fromLeft >> return False+          (9,True) -> case foc of+            Focused _ (tabLeft, ld) _ _ -> writeIORef wref tabLeft >> return (not ld)+            Focusable _ fromRight -> writeIORef wref fromRight >> return False+          _ -> case foc of+            Focused _ _ _ onKey -> case onKey key of+              w'@(Continue _ _ _ (Focused _ _ _ _)) -> writeIORef wref w' >> return False+              w' -> writeIORef wref w' >> return True+++-- | A widget which just shows a constant graphic output.+graphicWidget :: GraphicTree () -> Widget a+graphicWidget g = Continue (const (graphicWidget g) <$ g) Nothing Nothing NotFocusable++combineBeside :: CombineGraphics a+combineBeside gt gt' =+  let bounds@(Rect l t w h) = graphicTreeBounds gt+      (Rect l' t' w' h') = graphicTreeBounds gt'+  in Branch bounds gt (Rect (l + w) t' w' h') (Offset (l + w - l', 0) gt')++-- | Combine two widgets side by side+beside :: Widget z -> Widget z -> Widget z+beside = zipW combineBeside++combineAbove :: CombineGraphics a+combineAbove gt gt' =+  let bounds@(Rect l t w h) = graphicTreeBounds gt+      (Rect l' t' w' h') = graphicTreeBounds gt'+  in Branch bounds gt (Rect l' (t+h) w' h') (Offset (0, t + h - t') gt')++-- | Combine two widgets one above the other+above :: Widget z -> Widget z -> Widget z+above = zipW combineAbove++{-+hoverWidget :: GraphicTree () -> GraphicTree () -> Widget a+hoverWidget g1 g2 = outside+  where+    outside = Continue (Leaf g1 (const inside)) Nothing Nothing NotFocusable+    inside = Continue (Leaf g2 (const inside)) (Just outside) Nothing NotFocusable+-}++{-+hw = hoverWidget (Graphic (Rect 0 0 40 40) (RGBA 100 200 100)) (Graphic (Rect 0 0 40 40) (RGBA 200 100 100))++hw' = hoverWidget' (\frac -> Graphic (Rect 0 0 40 40) (RGBA (floor $ frac * 100) 100 100))+++main :: IO ()+main = runOnCanvas (seven `above` seven)+  where+    one = hw' `beside` hw'+    two = one `beside` one+    three = two `beside` two+    four = three `beside` three+    five = four `above` four+    six = five `above` five+    seven = six `above` six++-}
+ SneathLane/Graphics.hs view
@@ -0,0 +1,204 @@+{-# LANGUAGE OverloadedStrings #-}++module SneathLane.Graphics (+  -- * Type+  Graphic(..),++  -- * Functions+  drawGraphic,+  graphicBounds,+  inGraphic,++  inRect,+  measureText,+  pixelRatio,++  -- * Auxiliary Types+  Point,+  Rect(..),+  Color(..),+  PathStyle(..),+  TextStyle(..),++  -- * Re-exported+  Canvas,+  Picture,+  render,+  getCanvas+  ) where++import Data.Maybe (fromJust, isJust)+import Control.Monad (when)++import Haste (JSString, toJSString, catJSStr)+import Haste.Foreign (ffi)+import Haste.Graphics.Canvas (Canvas, Picture, Ctx, createCanvas, getCanvas, withContext, render)++import System.IO.Unsafe (unsafePerformIO)++-- | A point, represented as (x,y); following browser convention, positive x points right and positive y points downward.+type Point = (Double, Double)++-- | A rectangle, stored as left, top, width, height+data Rect = Rect Double Double Double Double++inRect :: Point -> Rect -> Bool+inRect (x,y) (Rect l t w h) = x >= l && x < l + w && y >= t && y < t + h++-- | An RGBA color, each number should be between 0 and 1. Future version will include gradients.+data Color = RGBA Double Double Double Double++colorToString :: Color -> JSString+colorToString (RGBA r g b a) =+  catJSStr "" ["rgba(",+               intToJSString $ floor $ 255 * r, ",",+               intToJSString $ floor $ 255 * g, ",",+               intToJSString $ floor $ 255 * b, ",",+               toJSString a, ")"]++-- | Determines how a path is drawn. Stroke includes width as well as color.+data PathStyle = PathStyle {+      ps_stroke :: Maybe (Color, Double),+      ps_fill :: Maybe Color+}++-- | Determines how a text string is drawn to the canvas.+data TextStyle = TextStyle {+      ts_color :: Color,+      ts_size :: Int,+      ts_lineHeight :: Int,+      ts_italic :: Bool,+      ts_bold :: Bool,+      ts_font :: JSString+}++toFontString :: TextStyle -> JSString+toFontString ts = catJSStr "" [if ts_italic ts then "italic " else "",+                               if ts_bold ts then "bold " else "",+                               intToJSString $ floor (pixelRatio * fromIntegral (ts_size ts)), "px ",  --"px / ", toJSString $ ts_lineHeight ts, "px ",+                               ts_font ts]++-- | The Graphic type+data Graphic = QuadraticPath PathStyle Point [(Point, Point)] -- ^ A path made up of quadratic Bezier curves, start point + (control point, end point) list.+             | Text TextStyle Point JSString -- ^ Text string, point indicates top left of text bounding box+             | BlankGraphic Rect -- ^ Invisible graphic which takes up space. Useful for e.g. a spacer.++++-- | Draw a graphic to a canvas, with the given point as the top left+drawGraphic :: Graphic -> Point -> Picture ()+drawGraphic (Text ts (x, y) str) (x',y') = withContext $ \ctx -> do+  jsFillStyle ctx (colorToString $ ts_color ts)+  jsFont ctx (toFontString ts)+  let bottom = 0.5 * fromIntegral (ts_size ts) + 0.5 * fromIntegral (ts_lineHeight ts)+  jsFillText ctx str (pixelRatio*(x+x')) (pixelRatio*(y+y'+bottom))++drawGraphic (QuadraticPath ps (x,y) comps) (x',y') = withContext $ \ctx -> do+  maybe (return ()) (\(clr, width) -> jsStrokeStyle ctx (colorToString clr) >> jsStrokeWidth ctx (pixelRatio*width)) (ps_stroke ps)+  maybe (return ()) (\clr -> jsFillStyle ctx (colorToString clr)) (ps_fill ps)++  jsBeginPath ctx+  jsMoveTo ctx (pixelRatio * (x + x')) (pixelRatio * (y + y'))+  mapM_+    (\((x1,y1),(x2,y2)) ->+      jsQuadraticCurveTo ctx (pixelRatio * (x' + x1)) (pixelRatio * (y' + y1)) (pixelRatio * (x' + x2)) (pixelRatio * (y' + y2)))+    comps++  when (isJust $ ps_stroke ps) (jsStroke ctx)+  when (isJust $ ps_fill ps) (jsFill ctx)++drawGraphic (BlankGraphic _) _ = return ()++-- | Find a rectangle that contains the entire graphic+graphicBounds :: Graphic -> Rect+graphicBounds (QuadraticPath ps (x,y) comps) =+  let (minX, minY, maxX, maxY) = foldl (\(ax,ay,zx,zy) ((x',y'),(x'',y'')) -> (min (min ax x') x'', min (min ay y') y'', max (max zx x') x'', max (max zy y') y'')) (x, y, x, y) comps+      sw = maybe 0 snd (ps_stroke ps)+  in Rect (minX-sw) (minY-sw) (2*sw + maxX - minX) (2*sw + maxY - minY)++graphicBounds (Text ts (x,y) str) = Rect x y (measureText ts str) (fromIntegral $ ts_lineHeight ts)++graphicBounds (BlankGraphic rct) = rct++-- | Determine if a point is inside a graphic.+--+-- A point is considered inside a text string if it is within the+-- rectangle defined by the line height and width of the text.+--+-- A point is considered inside a path if a ray from the point+-- directly to the left crosses the path an odd number of times. This+-- works as expected for closed non-intersecting paths.+inGraphic :: Point -> Graphic -> Bool+inGraphic pt g@(Text _ _ _) = pt `inRect` (graphicBounds g)++inGraphic pt (BlankGraphic rct) = pt `inRect` rct++inGraphic (x,y) (QuadraticPath _ pt comps) = odd $ length $ filter (< x) $ xCrossings pt comps y++xCrossings :: Point -> [(Point,Point)] -> Double -> [Double]+xCrossings _ [] _ = []++xCrossings (x,y) (((cx,cy), (ex,ey)) : comps) y' =+    let rest = xCrossings (ex,ey) comps y'+        (sx,sy) = (x - cx, y - cy)+        (ex',ey') = (ex - cx, ey - cy)+    in if sy + ey' == 0+       then let xs = map (\t -> cx + (1-t)*(1-t)*sx + t*t*ex') $ filter (\t -> t >= 0 && t <= 1) [-(y' - y)/(2*sy)] in xs ++ rest+       else let radicand = (sy*sy + (ey' + sy)*(y' - y)) / ((ey' + sy)*(ey' + sy))+            in if radicand <= 0+               then rest+               else let t0 = sy / (ey' + sy)+                        t1 = t0 + sqrt radicand+                        t2 = t0 - sqrt radicand+                        xs = map (\t -> cx + (1-t)*(1-t)*sx + t*t*ex') $ filter (\t -> t >= 0 && t <= 1) [t1, t2]+                    in xs ++ rest++-- Canvas FFI++jsQuadraticCurveTo :: Ctx -> Double -> Double -> Double -> Double -> IO ()+jsQuadraticCurveTo = ffi "(function(ctx, x1, y1, x2, y2) { ctx.quadraticCurveTo(x1,y1,x2,y2); })"++jsBeginPath :: Ctx -> IO ()+jsBeginPath = ffi "(function(ctx) { ctx.beginPath(); })"++jsStrokeStyle :: Ctx -> JSString -> IO ()+jsStrokeStyle = ffi "(function(ctx, str) { ctx.strokeStyle = str; })"++jsFillStyle :: Ctx -> JSString -> IO ()+jsFillStyle = ffi "(function(ctx, str) { ctx.fillStyle = str; })"++jsFont :: Ctx -> JSString -> IO ()+jsFont = ffi "(function(ctx, str) { ctx.font = str; })"++jsStroke :: Ctx -> IO ()+jsStroke = ffi "(function(ctx) { ctx.stroke(); })"++jsFill :: Ctx -> IO ()+jsFill = ffi "(function(ctx) { ctx.fill(); })"++jsMeasureText :: Ctx -> JSString -> IO Double+jsMeasureText = ffi "(function(ctx, str) { return ctx.measureText(str).width; })"++measureCanvas :: Canvas+measureCanvas = fromJust $ unsafePerformIO (createCanvas 1 1)++measureText :: TextStyle -> JSString -> Double+measureText textStyle text = (1/pixelRatio) * (unsafePerformIO $ render measureCanvas $ withContext (\ctx -> jsFont ctx (toFontString textStyle) >> jsMeasureText ctx text))++jsFillText :: Ctx -> JSString -> Double -> Double -> IO ()+jsFillText = ffi "(function(ctx, str, x, y) { return ctx.fillText(str, x, y); })"++jsStrokeWidth :: Ctx -> Double -> IO ()+jsStrokeWidth = ffi "(function(ctx, sw) { ctx.strokeWidth = sw; })"++jsMoveTo :: Ctx -> Double -> Double -> IO ()+jsMoveTo = ffi "(function(ctx, x, y) { return ctx.moveTo(x, y); })"++intToJSString :: Int -> JSString+intToJSString = toJSString++getPixelRatio :: IO Double+getPixelRatio = ffi "(function() { return window.devicePixelRatio; })"++pixelRatio :: Double+pixelRatio = unsafePerformIO $ getPixelRatio
+ sneathlane-haste.cabal view
@@ -0,0 +1,32 @@+-- Initial sneathlane-haste.cabal generated by cabal init.  For further+-- documentation, see http://haskell.org/cabal/users-guide/++name:                sneathlane-haste+version:             1+synopsis:            A compositional web UI library, which draws to a Canvas element+description:         A simple library for construction UIs in the browser. Uses Haste to compile to JS and a Canvas element to draw the UI to the page. A UI can be written using ordinary Monadic combinators.+homepage:            http://sneathlane.com+license:             BSD2+license-file:        LICENSE+author:              Jason Priestley+maintainer:          jason@sneathlane.com+-- copyright:+category:            GUI+build-type:          Simple+-- extra-source-files:+cabal-version:       >=1.10++flag haste-inst+  Description: either if it is being compiled with haste-inst or with cabal+  Default: False++library+  exposed-modules:     SneathLane, SneathLane.Graphics+  if flag(haste-inst)+    build-depends: base >=4.0 && <5, haste-lib >=0.4 && <0.5+    ghc-options: --dont-link+  else+    build-depends: base >=4.0 && <5, haste-compiler >=0.4 && <0.5+    ghc-options:+  other-extensions:    KindSignatures, GADTs, OverloadedStrings+  default-language:    Haskell2010