diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/SneathLane.hs b/SneathLane.hs new file mode 100644 --- /dev/null +++ b/SneathLane.hs @@ -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 + +-} diff --git a/SneathLane/Graphics.hs b/SneathLane/Graphics.hs new file mode 100644 --- /dev/null +++ b/SneathLane/Graphics.hs @@ -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 diff --git a/sneathlane-haste.cabal b/sneathlane-haste.cabal new file mode 100644 --- /dev/null +++ b/sneathlane-haste.cabal @@ -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