packages feed

sneathlane-haste 1 → 2

raw patch · 5 files changed

+570/−336 lines, 5 filesdep ~haste-compilerdep ~haste-lib

Dependency ranges changed: haste-compiler, haste-lib

Files

SneathLane.hs view
@@ -2,336 +2,10 @@  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+         module SneathLane.Graphics,+         module SneathLane.Widget        )        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---}+import SneathLane.Widget
+ SneathLane/BasicWidgets.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE KindSignatures, RankNTypes, GADTs, OverloadedStrings #-}++module SneathLane.BasicWidgets where++import Control.Applicative (Applicative(..), liftA2)+import Control.Monad (mplus, when)+import Data.Monoid ((<>))+import Data.Functor ((<$))+import Data.Maybe (fromMaybe)+import Control.Arrow ((***))++import SneathLane.Graphics+import SneathLane.Widget++import System.IO.Unsafe (unsafePerformIO)++import Haste (writeLog, catJSStr, toJSString, fromJSStr)++logging x y = unsafePerformIO (writeLog (show x) >> return y)++rectPath ps w h r = QuadraticPath ps (0,r) [((0,0),(r,0)),+                                            ((w-r,0),(w-r,0)),+                                            ((w,0),(w,r)),+                                            ((w,h-r),(w,h-r)),+                                            ((w,h),(w-r,h)),+                                            ((r,h),(r,h)),+                                            ((0,h),(0,h-r)),+                                            ((0,r),(0,r))]++button textStyle label = blur+  where+    blur = Continue (output (RGBA 0 0 0 1)) Nothing Nothing (Focusable focus focus)++    focus = Continue (output (RGBA 0 1 0 1)) Nothing Nothing (Focused blur (blur, False) (blur, False) (\key -> case key of+                                                                                                               EvKeyDown 13 _ -> Finish () -- enter+                                                                                                               _ -> focus))++    output clr = handler <$ graphicList [rectPath (PathStyle (Just (clr, 2)) Nothing) (labelWidth + 10) 30 5,+                                             Text textStyle (5,5) label]++    handler (EvMouseDown _ LeftButton) = (Nothing, Finish ())+    handler _ = (Nothing, blur)++    labelWidth = measureText textStyle label++tabs textStyle ts n =+  let buttons = zipWith (\(label,_) n' -> button textStyle label >> return (Left n')) ts [0..]+      curr = fmap Right $ nextFrame $ snd $ ts !! n+  in do+    ret <- balancedFold beside buttons `above` curr+    case ret of+      Right (Finish z) -> Finish z+      Right w' -> tabs textStyle (zipWith (\(label,w) n' -> if n' == n then (label, w') else (label, w)) ts [0..]) n+      Left n' ->+        let (Continue out _ _ _) = curr+            (Rect _ _ _ h) = graphicTreeBounds out+        in tabs textStyle (zipWith (\(label,w) n -> (label, if n == n' then slideToHeight h 0.2 w else w)) ts [0..]) n'++slideToHeight initialHeight duration (Finish z) = Finish z++slideToHeight initialHeight duration (Continue out mouseOut anim foc) =+    let (Rect x y w h) = graphicTreeBounds out+        anim' = fromMaybe (\tm -> Continue out mouseOut Nothing foc) anim+        anim'' tm = let w' = anim' tm+                    in if tm > duration+                       then w'+                       else slideToHeight (initialHeight + (tm/duration)*(h - initialHeight)) (duration - tm) w'++        out' = Clip (Rect x y w initialHeight) out+        mouseOut' = fmap (slideToHeight initialHeight duration) mouseOut+        foc' = mapWidgetFocus (slideToHeight initialHeight duration) foc++    in Continue out' mouseOut' (Just anim'') foc'++nextFrame widget = case widget of+  Finish z -> Finish (Finish z)+  Continue out mouseOut anim foc ->+    let out' = (fmap . fmap) (\(murl, w) -> (murl, Finish w)) out+        mouseOut' = fmap Finish mouseOut+        anim' = (fmap . fmap) Finish anim+        foc' = mapWidgetFocus Finish foc+    in Continue out' mouseOut' anim' foc'++textInput ww ts txt focused = Continue out Nothing Nothing foc+  where+    out = const (Nothing, textInput ww ts txt True) <$ graphicList [+      rectPath (PathStyle (Just (if focused then RGBA 0 0 1 1 else RGBA 0 0 0 1, 1)) Nothing) ww (fromIntegral $ ts_lineHeight ts + 6) 5,+      Text ts (5,3) txt+      ]++    foc = if focused+          then Focused blur (blur, False) (blur, False) keys+          else Focusable focus focus++    keys = (\key -> case key of+              EvKeyDown 8 _ -> Finish (toJSString $ reverse $ drop 1 $ reverse $ fromJSStr txt, False)+              EvKeyDown 13 _ -> Finish (txt, True)+              EvKeyInput str -> Finish (catJSStr "" [txt, str], False)+              _ -> textInput ww ts txt focused)++    blur = textInput ww ts txt False+    focus = textInput ww ts txt True++autoComplete ts fcomps txt focused =+  let comps = fcomps txt+      ww = maximum $ map (measureText ts) (txt:map fst comps)+      ti = textInput (ww + 10) ts txt focused+      wi = balancedFold above (ti : map showComp comps)+      showComp comp = graphicWidget Nothing+                      (graphicList [+                           rectPath (PathStyle (Just (RGBA 0.4 0.4 0.4 1, 1)) (Just $ RGBA 0.9 0.9 0.9 1)) (ww + 10) (fromIntegral $ ts_lineHeight ts) 0,+                           Text ts (5,0) (fst comp)])+  in do+    (txt', finish) <- wi+    case finish of+      True -> if null comps+              then autoComplete ts fcomps txt True+              else return (snd $ head comps)+      False -> if txt' /= "" && null (fcomps txt')+               then autoComplete ts fcomps txt True+               else autoComplete ts fcomps txt' True++simpleFocus fw keys = focus+  where+    focus = fw $ Focused blur (blur, False) (blur, False) keys+    blur = fw $ Focusable focus focus
SneathLane/Graphics.hs view
@@ -8,6 +8,7 @@   drawGraphic,   graphicBounds,   inGraphic,+  noGraphic,    inRect,   measureText,@@ -180,7 +181,7 @@ jsMeasureText = ffi "(function(ctx, str) { return ctx.measureText(str).width; })"  measureCanvas :: Canvas-measureCanvas = fromJust $ unsafePerformIO (createCanvas 1 1)+measureCanvas = 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))@@ -202,3 +203,6 @@  pixelRatio :: Double pixelRatio = unsafePerformIO $ getPixelRatio++noGraphic :: Graphic+noGraphic = BlankGraphic (Rect 0 0 0 0)
+ SneathLane/Widget.hs view
@@ -0,0 +1,430 @@+{-# LANGUAGE KindSignatures, RankNTypes, GADTs, OverloadedStrings #-}++module SneathLane.Widget+       (+         -- * Widgets+         Widget(..),+         WidgetFocus(..),+         zipW,++         -- * Build Widgets+         graphicWidget,+         above,+         combineAbove,+         beside,+         combineBeside,+         mapGraphic,+         mapWidgetFocus,++         -- * Run Widgets+         runOnCanvas,++         -- * Graphics+         GraphicTree(..),+         graphicList,+         graphicTreeBounds,++         -- * Events+         MouseEv(..),+         MouseButton(..),+         Key(..),++         -- * Utility+         balancedFold,++         -- * Type synonyms+         OutputFn,+         Animate,+         MouseOut,+         HandleKey,+         TimeDifference+       )+       where++import Control.Applicative (Applicative(..), liftA2)+import Control.Monad (mplus, when)+import Data.Functor ((<$))+import Data.Maybe (fromMaybe)+import Data.IORef (newIORef, readIORef, writeIORef, modifyIORef)++import Control.Arrow ((***))++import Haste+import Haste.DOM+import Haste.Graphics.AnimationFrame+import qualified Haste.Graphics.Canvas as HC+import Haste.Foreign+import Haste.Events hiding (MouseButton)+import SneathLane.Graphics++import System.IO.Unsafe (unsafePerformIO)+logging x y = unsafePerformIO (writeLog (show x) >> return y)++data MouseEv = EvMouseUp Point MouseButton | EvMouseDown Point MouseButton | EvMouseMove Point++getMousePoint mev = case mev of+  EvMouseUp pt _ -> pt+  EvMouseDown pt _ -> pt+  EvMouseMove pt -> pt++setMousePoint mev pt = case mev of+  EvMouseUp _ b -> EvMouseUp pt b+  EvMouseDown _ b -> EvMouseDown pt b+  EvMouseMove _ -> EvMouseMove pt++-- | Which mouse button (if any) was being pressed+data MouseButton = RightButton | LeftButton++data Key = EvKeyDown Int Bool | EvKeyUp Int Bool | EvKeyInput JSString++-- | 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+  Clip :: Rect -> GraphicTree a -> GraphicTree a+  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+  Clip rect gt' -> if (x,y) `inRect` rect then graphicAtPoint (x,y) gt' else Nothing+  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')++refineBounds :: Rect -> Rect -> Maybe Rect+refineBounds (Rect x y w h) (Rect x' y' w' h') =+  let x'' = max x x'+      y'' = max y y'+      w'' = min (x + w) (x' + w') - x''+      h'' = min (y + h) (y' + h') - y''+  in if w'' > 0 && h'' > 0+     then Just (Rect x'' y'' w'' h'')+     else Nothing++drawGraphicTree :: Canvas -> GraphicTree a -> IO ()+drawGraphicTree canv gt = render canv $ go (0,0) Nothing gt+  where+    go :: Point -> Maybe Rect -> GraphicTree a -> Picture ()+    go (x,y) bounds (Offset (x',y') gt') = let bounds' = case bounds of+                                                 Nothing -> Nothing+                                                 Just (Rect x y w h) -> Just (Rect (x - x') (y - y') w h)+                                           in go (x + x', y + y') bounds' gt'+    go pt bounds (Clip rect gt') = go pt (maybe (Just rect) (refineBounds rect) bounds) gt'+    go pt bounds (Branch bounds' gt' bounds'' gt'') = case bounds of+                                                           Nothing -> go pt Nothing gt' >> go pt Nothing gt''+                                                           Just rect -> do+                                                             maybe (return ()) (\b -> go pt (Just b) gt') (refineBounds rect bounds')+                                                             maybe (return ()) (\b -> go pt (Just b) gt'') (refineBounds rect bounds'')+    go pt bounds (FMap _ gt') = go pt bounds gt'+    go pt@(x',y') bounds (Leaf g) =+      let pic = drawGraphic g pt+      in case bounds of+      Just (Rect x y w h) -> HC.clip (HC.rect (x+x',y+y') (x+w+x',y+h+y')) pic+      Nothing -> pic+++-- | Find a rectangle containing the entire contents of the graphic tree+graphicTreeBounds :: GraphicTree a -> Rect+graphicTreeBounds gt = case gt of+  Clip rect _ -> rect+  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 OutputFn f z = MouseEv -> (Maybe String, Widget f z)++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 f z = Finish z+              | Continue (f (OutputFn f z)) (Maybe (MouseOut (Widget f z))) (Maybe (Animate (Widget f z))) (WidgetFocus f z)++-- | Determines the focus behavior of the widget+data WidgetFocus f z = NotFocusable -- ^ Widget can not take keyboard focus+                     | Focusable (Widget f z) (Widget f z) -- ^ Widget can take keyboard focus, but does not have it now+                     | Focused (Widget f z) (Widget f z, Bool) (Widget f z, Bool) (HandleKey (Widget f z)) -- ^ Widget has keyboard focus++bindW :: (Functor f) => (a -> Widget f b) -> Widget f a -> Widget f b+bindW fn (Finish w) = fn w+bindW fn (Continue out mouseOut anim foc) =+  let+    out' = (fmap.fmap) (id *** 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 f) => Functor (Widget f) where+  fmap fn = bindW (Finish . fn)++instance (Functor f) => Applicative (Widget f) where+  pure = Finish++  (<*>) wf w = bindW (\fn -> bindW (Finish . fn) w) wf++instance (Functor f) => Monad (Widget f) where+  return = Finish++  (>>=) = flip bindW+++-- | Combine two widgets to run in parallel as a single widget+zipW :: (Functor f, Functor g, Functor h) => (f (OutputFn h z) -> g (OutputFn h z) -> h (OutputFn h z)) -> Widget f z -> Widget g z -> Widget h z+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) (\(murl,lw') -> (murl, updateLeft lw' (fromMaybe rw mouseOut'))) out)+              ((fmap.fmap) (\(murl,rw') -> (murl, 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();} }) })"++jsKeyUp :: Elem -> (Int -> Bool -> IO Bool) -> IO ()+jsKeyUp = ffi "(function(elem, onKey) { elem.addEventListener('keyup', function(ev) { if(!onKey(ev.keyCode,ev.shiftKey)){ev.preventDefault();} })})"++jsKeyInput :: Elem -> (JSString -> IO JSString) -> IO ()+jsKeyInput = ffi "(function(elem, onKey) { elem.addEventListener('input', function(ev) { elem.value = onKey(elem.value); }) })"++jsRequestAnimationFrame :: (() -> IO ()) -> IO ()+jsRequestAnimationFrame = ffi "(function(fn) { window.requestAnimationFrame(fn); })"++jsOnResize :: (() -> IO ()) -> IO ()+jsOnResize = ffi "(function(fn) { window.onresize = fn; })"++jsGetWidth :: IO Double+jsGetWidth = ffi "(function() { return window.innerWidth; })"++jsGetHeight :: IO Double+jsGetHeight = ffi "(function() { return window.innerHeight; })"++jsRemoveHref :: Elem -> IO ()+jsRemoveHref = ffi "(function(elem) { elem.removeAttribute('href'); })"++-- | Create a Canvas element filling the browser viewport, and run the given Widget there+runOnCanvas :: (forall z. Double -> Widget GraphicTree z) -> IO ()+runOnCanvas fw = do+  atag <- newElem "a"+  ce <- newElem "canvas"+  (Just canvas) <- getCanvas ce++  keyInput <- newElem "input"+  set keyInput [attr "type" =: "text",+             style "position" =: "absolute",+             style "left" =: "-1000px"]+  appendChild documentBody keyInput++  appendChild documentBody atag+  appendChild atag ce++  ww <- jsGetWidth+  wref <- newIORef (fw ww)++  ce `onEvent` MouseDown $ (\ev -> mouseEvent atag (EvMouseDown (fromIntegral $ fst $ mouseCoords ev, fromIntegral $ snd $ mouseCoords ev) LeftButton) wref >> adjustFocus keyInput wref)+  ce `onEvent` MouseUp $ (\ev -> mouseEvent atag (EvMouseUp (fromIntegral $ fst $ mouseCoords ev, fromIntegral $ snd $ mouseCoords ev) LeftButton) wref >> adjustFocus keyInput wref)+  ce `onEvent` MouseMove $ (\ev -> mouseEvent atag (EvMouseMove (fromIntegral $ fst $ mouseCoords ev, fromIntegral $ snd $ mouseCoords ev)) wref >> adjustFocus keyInput wref)++  jsKeyDown keyInput (\key shift -> keyEvent wref (EvKeyDown key shift))+  jsKeyInput keyInput (\str -> keyEvent wref (EvKeyInput str) >> return "")+  jsKeyUp keyInput (\key shift -> keyEvent wref (EvKeyUp key shift))++  jsOnResize (\_ -> do+                 ww <- jsGetWidth+                 writeIORef wref (fw ww))++  tm <- jsNow+  renderFrame 16.0 tm ce canvas wref+  return ()+    where+      adjustFocus elem wref = do+        Continue _ _ _ foc <- readIORef wref+        case foc of+          Focused _ _ _ _ -> focus elem+          _ -> blur elem++      renderFrame mspf prevTime ce canvas wref = do+        Continue out _ anim _ <- readIORef wref++        let Rect ox oy ow oh = graphicTreeBounds out++        set ce [attr "width" =: show (pixelRatio * (ox + ow)),+                attr "height" =: show (ceiling $ pixelRatio * (oy + oh)),+                style "width" =: (show (ox + ow) ++ "px"),+                style "height" =: (show (ceiling $ oy + oh) ++ "px")]++        drawGraphicTree canvas out+        tm <- jsNow+        case anim of+          Just fn -> writeIORef wref (fn $ (tm - prevTime) / 1000)+          _ -> return ()+        let mspf' = mspf*0.95 + (tm - prevTime)*0.05+        --writeLog (show $ floor $ 1000/mspf')+        requestAnimationFrame (\_ -> renderFrame mspf' tm ce canvas wref)+        return ()++      mouseEvent atag mev wref = do+        Continue out mouseOut _ _ <- readIORef wref+        let pt = getMousePoint mev++        case graphicAtPoint pt out of+          Nothing -> do+            jsRemoveHref atag+            case mouseOut of+              Just w' -> writeIORef wref w'+              _ -> return ()+          Just (oset, fw) -> do+            let (murl, w') = fw (setMousePoint mev oset)+            case murl of+              Just url -> do+                currUrl <- getAttr atag "href"+                when (currUrl /= url) (set atag [attr "href" =: url])+              Nothing -> jsRemoveHref atag+            writeIORef wref w'++      keyEvent wref kEv = do+        Continue _ _ _ foc <- readIORef wref+        case kEv of+          EvKeyDown 9 False -> case foc of+            Focused _ _ (tabRight, rd) _ -> writeIORef wref tabRight >> return (not rd)+            Focusable fromLeft _ -> writeIORef wref fromLeft >> return False+            _ -> return True++          EvKeyDown 9 True -> case foc of+            Focused _ (tabLeft, ld) _ _ -> writeIORef wref tabLeft >> return (not ld)+            Focusable _ fromRight -> writeIORef wref fromRight >> return False+            _ -> return True++          _ -> case foc of+            Focused _ _ _ onKey -> case onKey kEv of+              w'@(Continue _ _ _ (Focused _ _ _ _)) -> writeIORef wref w' >> return True+              w' -> writeIORef wref w' >> return True+            _ -> return True++mapWidgetFocus fwidget foc = case foc of+  NotFocusable -> NotFocusable+  Focusable fromLeft fromRight -> Focusable (fwidget fromLeft) (fwidget fromRight)+  Focused blur (tabLeft,ld) (tabRight,rd) key -> Focused (fwidget blur) (fwidget tabLeft, ld) (fwidget tabRight, rd) (fmap fwidget key)++mapGraphic fn w = case w of+  Finish z -> Finish z+  Continue out mouseOut anim foc -> let+    out' = fn $ (fmap.fmap) (id *** mapGraphic fn) out+    mouseOut' = fmap (mapGraphic fn) mouseOut+    anim' = (fmap.fmap) (mapGraphic fn) anim+    foc' = mapWidgetFocus (mapGraphic fn) foc+    in Continue out' mouseOut' anim' foc'++-- | A widget which just shows a constant graphic output.+graphicWidget :: (Functor f) => Maybe String -> f () -> Widget f a+graphicWidget murl g = Continue (const (murl, graphicWidget murl g) <$ g) Nothing Nothing NotFocusable++combineBeside :: GraphicTree a -> GraphicTree a -> GraphicTree 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 GraphicTree z -> Widget GraphicTree z -> Widget GraphicTree z+beside = zipW combineBeside++combineAbove :: GraphicTree a -> GraphicTree a -> GraphicTree 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 GraphicTree z -> Widget GraphicTree z -> Widget GraphicTree z+above = zipW combineAbove
sneathlane-haste.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/  name:                sneathlane-haste-version:             1+version:             2 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@@ -16,17 +16,17 @@ -- extra-source-files: cabal-version:       >=1.10 -flag haste-inst+Flag Haste-inst   Description: either if it is being compiled with haste-inst or with cabal   Default: False  library-  exposed-modules:     SneathLane, SneathLane.Graphics+  exposed-modules:     SneathLane, SneathLane.Graphics, SneathLane.Widget, SneathLane.BasicWidgets   if flag(haste-inst)-    build-depends: base >=4.0 && <5, haste-lib >=0.4 && <0.5-    ghc-options: --dont-link+    build-depends: base >=4.0 && <5, haste-lib >=0.5 && <0.6+    ghc-options: --link-jslib   else-    build-depends: base >=4.0 && <5, haste-compiler >=0.4 && <0.5+    build-depends: base >=4.0 && <5, haste-compiler >=0.5 && <0.6     ghc-options:   other-extensions:    KindSignatures, GADTs, OverloadedStrings   default-language:    Haskell2010