diff --git a/SneathLane.hs b/SneathLane.hs --- a/SneathLane.hs +++ b/SneathLane.hs @@ -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 diff --git a/SneathLane/BasicWidgets.hs b/SneathLane/BasicWidgets.hs new file mode 100644 --- /dev/null +++ b/SneathLane/BasicWidgets.hs @@ -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 diff --git a/SneathLane/Graphics.hs b/SneathLane/Graphics.hs --- a/SneathLane/Graphics.hs +++ b/SneathLane/Graphics.hs @@ -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) diff --git a/SneathLane/Widget.hs b/SneathLane/Widget.hs new file mode 100644 --- /dev/null +++ b/SneathLane/Widget.hs @@ -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 diff --git a/sneathlane-haste.cabal b/sneathlane-haste.cabal --- a/sneathlane-haste.cabal +++ b/sneathlane-haste.cabal @@ -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