mirror of
https://github.com/chrisdone-archive/duet.git
synced 2024-10-06 14:17:45 +03:00
Add ghcjs to build
This commit is contained in:
parent
59f0b2623e
commit
357ae94690
1
build.sh
Normal file
1
build.sh
Normal file
@ -0,0 +1 @@
|
||||
stack build --stack-yaml stack-ghcjs.yaml && cp static/index.html .stack-work/dist/x86_64-osx/Cabal-1.24.2.0_ghcjs/build/duet-web/duet-web.jsexe/
|
26
duet.cabal
26
duet.cabal
@ -32,6 +32,10 @@ library
|
||||
Control.Monad.Supply
|
||||
|
||||
executable duet
|
||||
if impl(ghcjs)
|
||||
buildable: False
|
||||
else
|
||||
buildable: True
|
||||
hs-source-dirs:
|
||||
app
|
||||
main-is:
|
||||
@ -46,3 +50,25 @@ executable duet
|
||||
containers
|
||||
default-language:
|
||||
Haskell2010
|
||||
|
||||
executable duet-web
|
||||
if impl(ghcjs)
|
||||
buildable: True
|
||||
else
|
||||
buildable: False
|
||||
default-language:
|
||||
Haskell2010
|
||||
hs-source-dirs:
|
||||
web
|
||||
main-is:
|
||||
Main.hs
|
||||
build-depends:
|
||||
duet,
|
||||
base,
|
||||
parsec,
|
||||
text,
|
||||
exceptions,
|
||||
mtl,
|
||||
containers,
|
||||
ghcjs-base,
|
||||
aeson
|
||||
|
10
stack-ghcjs.yaml
Normal file
10
stack-ghcjs.yaml
Normal file
@ -0,0 +1,10 @@
|
||||
resolver: lts-7.19
|
||||
compiler: ghcjs-0.2.1.9007019_ghc-8.0.1
|
||||
compiler-check: match-exact
|
||||
|
||||
setup-info:
|
||||
ghcjs:
|
||||
source:
|
||||
ghcjs-0.2.1.9007019_ghc-8.0.1:
|
||||
url: http://ghcjs.tolysz.org/ghc-8.0-2017-02-05-lts-7.19-9007019.tar.gz
|
||||
sha1: d2cfc25f9cda32a25a87d9af68891b2186ee52f9
|
19
static/index.html
Normal file
19
static/index.html
Normal file
@ -0,0 +1,19 @@
|
||||
<!DOCTYPE html>
|
||||
<html>
|
||||
<head>
|
||||
<title>Snappy demonstration</title>
|
||||
<meta charset="utf-8">
|
||||
<script src="https://cdnjs.cloudflare.com/ajax/libs/snap.svg/0.5.1/snap.svg-min.js"></script>
|
||||
</head>
|
||||
<body>
|
||||
<p>
|
||||
This app demonstrations dragging a circle around and updating a
|
||||
text element to reflect the circle's X, Y position
|
||||
automatically. You can also select an area of the canvas which
|
||||
shows a kind of selection square. Source code
|
||||
here: <a href="https://github.com/chrisdone/snappy/">https://github.com/chrisdone/snappy</a>
|
||||
</p>
|
||||
<svg id="app" width="800" height="500"></svg>
|
||||
<script language="javascript" src="all.js"></script>
|
||||
</body>
|
||||
</html>
|
27
web/Main.hs
Normal file
27
web/Main.hs
Normal file
@ -0,0 +1,27 @@
|
||||
{-# LANGUAGE RecursiveDo #-}
|
||||
|
||||
module Main where
|
||||
|
||||
import qualified Snap
|
||||
import qualified Snappy
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
element <- Snap.getElementById "app"
|
||||
snap <- Snap.new element
|
||||
rec c <-
|
||||
Snappy.circle
|
||||
snap
|
||||
(Snappy.draggable c 50 Snappy.dragDX)
|
||||
(Snappy.draggable c 45 Snappy.dragDY)
|
||||
(pure 20)
|
||||
_ <-
|
||||
Snappy.text
|
||||
snap
|
||||
(pure 10)
|
||||
(pure 20)
|
||||
(Snappy.zipDynamics
|
||||
(\x y -> "(x,y) = " ++ show (x,y))
|
||||
(Snappy.circleX c)
|
||||
(Snappy.circleY c))
|
||||
pure ()
|
766
web/Snap.hs
Normal file
766
web/Snap.hs
Normal file
@ -0,0 +1,766 @@
|
||||
{-# LANGUAGE EmptyDataDecls #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE ExistentialQuantification #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
|
||||
-- | Snap SVG bindings.
|
||||
|
||||
module Snap
|
||||
where
|
||||
|
||||
import Control.Concurrent
|
||||
import Control.Exception (evaluate)
|
||||
import Data.Aeson (FromJSON(..), ToJSON(..), (.:), Value(..))
|
||||
import Data.Aeson.Types (parseMaybe)
|
||||
import Data.IORef
|
||||
import qualified Data.Text as T
|
||||
|
||||
#ifdef __GHCJS__
|
||||
import GHCJS.Types (JSVal)
|
||||
import GHCJS.Marshal (FromJSVal(..), ToJSVal(..), toJSVal_aeson, toJSValListOf)
|
||||
import GHCJS.Foreign.Callback
|
||||
#endif
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- App
|
||||
|
||||
#ifdef __GHCJS__
|
||||
foreign import javascript unsafe
|
||||
"document.getElementById($1)"
|
||||
js_getElementById :: JSVal -> IO JSVal
|
||||
getElementById :: String -> IO JSVal
|
||||
getElementById str = do v <- toJSVal str
|
||||
js_getElementById v
|
||||
#else
|
||||
getElementById :: String -> IO JSVal
|
||||
getElementById = undefined
|
||||
#endif
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Snap object
|
||||
|
||||
-- | A Snap object.
|
||||
data Snap = Snap JSVal JSVal
|
||||
|
||||
-- | Create a new Snap object.
|
||||
new :: ToJSVal a => a -> IO Snap
|
||||
new e = do
|
||||
j_e <- toJSVal e
|
||||
fmap (`Snap` j_e) (js_newSnap j_e)
|
||||
|
||||
-- | Clear the canvas.
|
||||
clear :: Snap -> IO ()
|
||||
clear (Snap s e) = do
|
||||
js_clear s
|
||||
js_clear_el e
|
||||
|
||||
setDimensions :: Snap -> (Double,Double) -> IO ()
|
||||
setDimensions (Snap _ e) (x,y) =
|
||||
js_snap_set_svg_dimensions e x y
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Circles
|
||||
|
||||
-- | A circle object.
|
||||
newtype Circle = Circle JSVal
|
||||
deriving (ToJSVal)
|
||||
instance HasBBox Circle
|
||||
instance HasAttr Circle
|
||||
instance HasDrag Circle
|
||||
instance HasClick Circle
|
||||
instance HasTransform Circle
|
||||
instance HasPosition Circle
|
||||
instance HasGrouping Circle
|
||||
instance HasHover Circle
|
||||
|
||||
-- | Make a new circle on the snap canvas.
|
||||
circle :: Snap -> Double -> Double -> Double -> IO Circle
|
||||
circle (Snap snap _) circleX circleY circleRadius =
|
||||
fmap Circle (js_circle snap circleX circleY circleRadius)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Rects
|
||||
|
||||
-- | A rect object.
|
||||
newtype Rect = Rect JSVal
|
||||
deriving (ToJSVal)
|
||||
instance HasBBox Rect
|
||||
instance HasHover Rect
|
||||
instance HasAttr Rect
|
||||
instance HasClick Rect
|
||||
instance HasDrag Rect
|
||||
instance HasTransform Rect
|
||||
instance HasPosition Rect
|
||||
instance HasGrouping Rect
|
||||
|
||||
-- | Make a new rect on the snap canvas.
|
||||
rect :: Snap -> Double -> Double -> Double -> Double -> Double -> Double -> IO Rect
|
||||
rect (Snap snap _) rectX rectY width height rx ry =
|
||||
fmap Rect (js_rect snap rectX rectY width height rx ry)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Text
|
||||
|
||||
-- | A text object.
|
||||
newtype Text = Text JSVal
|
||||
deriving (ToJSVal)
|
||||
instance HasClick Text
|
||||
instance HasBBox Text
|
||||
instance HasAttr Text
|
||||
instance HasDrag Text
|
||||
instance HasTransform Text
|
||||
instance HasPosition Text
|
||||
instance HasGrouping Text
|
||||
|
||||
-- | Make a new text on the snap canvas.
|
||||
text :: Snap -> Double -> Double -> String -> IO Text
|
||||
text (Snap snap _) textX textY t = do
|
||||
t_j <- toJSVal t
|
||||
fmap Text (js_text snap textX textY t_j)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Paths
|
||||
|
||||
-- | A path object.
|
||||
newtype Path = Path JSVal
|
||||
deriving (ToJSVal)
|
||||
instance HasBBox Path
|
||||
instance HasClick Path
|
||||
instance HasHover Path
|
||||
instance HasAttr Path
|
||||
instance HasPosition Path
|
||||
instance HasGrouping Path
|
||||
|
||||
data Point = Point
|
||||
{ pointX :: !Double
|
||||
, pointY :: !Double
|
||||
} deriving (Show)
|
||||
|
||||
instance FromJSON Point where
|
||||
parseJSON j = do
|
||||
o <- parseJSON j
|
||||
Point <$> o .: "x" <*> o .: "y"
|
||||
|
||||
-- | Make a new path on the snap canvas.
|
||||
path :: Snap -> String -> IO Path
|
||||
path (Snap snap _) t = do
|
||||
t_j <- toJSVal t
|
||||
fmap Path (js_path snap t_j)
|
||||
|
||||
getTotalLength :: Path -> IO Double
|
||||
getTotalLength (Path j) = js_getTotalLength j
|
||||
|
||||
getPointAtLength :: Path -> Double -> IO Point
|
||||
getPointAtLength (Path j) p = do
|
||||
o <- js_getPointAtLength j p
|
||||
value <- fromJSVal o
|
||||
result <- evaluate (value >>= parseMaybe parseJSON)
|
||||
case result of
|
||||
Nothing -> error "Couldn't parse client rect!"
|
||||
Just r -> return r
|
||||
|
||||
line :: Snap -> Double -> Double -> Double -> Double -> IO Path
|
||||
line snap x1 y1 x2 y2 =
|
||||
Snap.path snap (unwords ["M", show x1, show y1, "L", show x2, show y2])
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Bounding box
|
||||
|
||||
-- | A path object.
|
||||
data BBox = BBox
|
||||
{ bboxWidth :: !Double
|
||||
, bboxHeight :: !Double
|
||||
, bboxLeft :: !Double
|
||||
, bboxTop :: !Double
|
||||
, bboxRight :: !Double
|
||||
, bboxBottom :: !Double
|
||||
} deriving (Show)
|
||||
|
||||
instance FromJSON BBox where
|
||||
parseJSON j = do
|
||||
o <- parseJSON j
|
||||
BBox <$> o .: "width" <*> o .: "height" <*> o .: "x" <*> o .: "y" <*>
|
||||
o .: "x2" <*>
|
||||
o .: "y2"
|
||||
|
||||
class ToJSVal a => HasBBox a
|
||||
|
||||
-- | Make a new getBBox on the snap canvas.
|
||||
getBBox :: HasBBox object => object -> IO BBox
|
||||
getBBox t = do
|
||||
t_j <- toJSVal t
|
||||
o <- js_getBBox t_j
|
||||
value <- fromJSVal o
|
||||
result <- evaluate (value >>= parseMaybe parseJSON)
|
||||
case result of
|
||||
Nothing -> error "Couldn't parse client rect!"
|
||||
Just r -> return r
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Attributes (font, fill, stroke, etc.)
|
||||
|
||||
class ToJSVal a => HasAttr a
|
||||
|
||||
-- | Apply attributes to the object.
|
||||
attr :: HasAttr object => object -> Value -> IO ()
|
||||
attr o attrs = do
|
||||
o_j <- toJSVal o
|
||||
v <- toJSVal_aeson attrs
|
||||
js_attr o_j v
|
||||
|
||||
-- | Apply one dataibute to the object.
|
||||
setData :: (HasAttr object,ToJSVal v) => object -> String -> v -> IO ()
|
||||
setData o key val' = do
|
||||
o_j <- toJSVal o
|
||||
k <- toJSVal key
|
||||
v <- toJSVal val'
|
||||
js_setData o_j k v
|
||||
|
||||
-- | Apply one attribute to the object.
|
||||
setAttr :: (HasAttr object,ToJSVal v) => object -> String -> v -> IO ()
|
||||
setAttr o key val' = do
|
||||
o_j <- toJSVal o
|
||||
k <- toJSVal key
|
||||
v <- toJSVal val'
|
||||
js_setAttr o_j k v
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Positioning
|
||||
|
||||
class ToJSVal a => HasPosition a
|
||||
|
||||
-- | Reposition something after something else.
|
||||
after :: (HasPosition a,HasPosition b) => a -> b -> IO ()
|
||||
after this that = do
|
||||
a <- toJSVal this
|
||||
b <- toJSVal that
|
||||
js_after a b
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Grouping
|
||||
|
||||
class ToJSVal a => HasGrouping a
|
||||
|
||||
newtype Group = Group JSVal
|
||||
deriving (ToJSVal)
|
||||
instance HasGrouping Group
|
||||
instance HasDrag Group
|
||||
instance HasBBox Group
|
||||
instance HasClick Group
|
||||
instance HasTransform Group
|
||||
instance HasHover Group
|
||||
instance HasAttr Group
|
||||
|
||||
group :: Snap -> [Some HasGrouping] -> IO Group
|
||||
group (Snap snap _) xs = do
|
||||
xs' <- mapM (\(Some x) -> toJSVal x) xs >>= toJSVal
|
||||
fmap Group (js_group snap xs')
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Dragging
|
||||
|
||||
class ToJSVal a => HasDrag a
|
||||
|
||||
drag
|
||||
:: HasDrag a
|
||||
=> a -- ^ Draggable thing.
|
||||
-> (Double -> Double -> IO ()) -- ^ During drag.
|
||||
-> (Double -> Double -> IO ()) -- ^ Start drag.
|
||||
-> (Bool -> IO ()) -- ^ End drag.
|
||||
-> IO ()
|
||||
drag d during start end = do
|
||||
duringCallback <-
|
||||
asyncCallback2
|
||||
(\x y -> do
|
||||
Just x' <- fromJSVal x
|
||||
Just y' <- fromJSVal y
|
||||
during x' y')
|
||||
startCallback <-
|
||||
asyncCallback2
|
||||
(\x y -> do
|
||||
Just x' <- fromJSVal x
|
||||
Just y' <- fromJSVal y
|
||||
start x' y')
|
||||
endCallback <-
|
||||
asyncCallback1
|
||||
(\dragged -> do
|
||||
Just v <- fromJSVal dragged
|
||||
end v)
|
||||
d_j <- toJSVal d
|
||||
js_drag d_j duringCallback startCallback endCallback
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Hover
|
||||
|
||||
class ToJSVal a => HasHover a
|
||||
|
||||
hover :: HasHover a => a -> IO () -> IO () -> IO ()
|
||||
hover o on off = do
|
||||
j <- toJSVal o
|
||||
onx <- asyncCallback on
|
||||
offx <- asyncCallback off
|
||||
js_hover j onx offx
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Click
|
||||
|
||||
class ToJSVal a => HasClick a
|
||||
|
||||
newtype Event = Event
|
||||
{ eventEvent :: JSVal
|
||||
}
|
||||
|
||||
stopPropagation :: Event -> IO ()
|
||||
stopPropagation (Event e) = js_stopPropagation e
|
||||
|
||||
data Modifier
|
||||
= AltKey
|
||||
| NoModifier
|
||||
deriving (Show)
|
||||
|
||||
-- | Handle the click event, if another click comes in under 500ms,
|
||||
-- then trigger a double-click instead.
|
||||
singleClick
|
||||
:: HasClick a
|
||||
=> a
|
||||
-> (Event -> Modifier -> Double -> Double -> IO ()) -- Click
|
||||
-> IO ()
|
||||
singleClick o onClick = do
|
||||
j <- toJSVal o
|
||||
onx <-
|
||||
asyncCallback3
|
||||
(\e xy' alt' -> do
|
||||
Just [x, y] <- fromJSVal xy'
|
||||
Just alt <- fromJSVal alt'
|
||||
onClick
|
||||
(Event e)
|
||||
(if alt
|
||||
then AltKey
|
||||
else NoModifier)
|
||||
x
|
||||
y)
|
||||
js_click j onx
|
||||
|
||||
-- | Handle the click event, if another click comes in under 500ms,
|
||||
-- then trigger a double-click instead.
|
||||
bothClicks
|
||||
:: HasClick a
|
||||
=> a
|
||||
-> (Event -> Modifier -> Double -> Double -> IO ()) -- Click
|
||||
-> (Event -> Modifier -> Double -> Double -> IO ()) -- Double click
|
||||
-> IO ()
|
||||
bothClicks o onClick onDblClick = do
|
||||
j <- toJSVal o
|
||||
clicks <- newIORef (0 :: Int)
|
||||
mtid <- newIORef Nothing
|
||||
onx <-
|
||||
asyncCallback3
|
||||
(\e xy' alt' -> do
|
||||
modifyIORef' clicks (+ 1)
|
||||
clickCount <- readIORef clicks
|
||||
Just [x, y] <- fromJSVal xy'
|
||||
Just alt <- fromJSVal alt'
|
||||
if clickCount > 1
|
||||
then do
|
||||
readIORef mtid >>= maybe (return ()) killThread
|
||||
writeIORef clicks 0
|
||||
onDblClick
|
||||
(Event e)
|
||||
(if alt
|
||||
then AltKey
|
||||
else NoModifier)
|
||||
x
|
||||
y
|
||||
else do
|
||||
tid <-
|
||||
forkIO
|
||||
(do threadDelay (1000 * 200)
|
||||
writeIORef clicks 0
|
||||
onClick
|
||||
(Event e)
|
||||
(if alt
|
||||
then AltKey
|
||||
else NoModifier)
|
||||
x
|
||||
y)
|
||||
writeIORef mtid (Just tid))
|
||||
js_click j onx
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Matrix transforms
|
||||
|
||||
newtype Matrix = Matrix JSVal
|
||||
|
||||
class ToJSVal a => HasTransform a
|
||||
|
||||
newMatrix :: IO Matrix
|
||||
newMatrix = fmap Matrix js_newMatrix
|
||||
|
||||
translate :: Matrix -> Double -> Double -> IO ()
|
||||
translate (Matrix m) x y = js_translate m x y
|
||||
|
||||
transform :: HasTransform a => a -> Matrix -> IO ()
|
||||
transform a (Matrix m) = do
|
||||
j <- toJSVal a
|
||||
js_transform j m
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Text boxes
|
||||
|
||||
newtype Textbox = Textbox JSVal
|
||||
|
||||
-- | Create a text box for the user to write into.
|
||||
textbox :: Snap -> Double -> Double -> Double -> Double -> String -> IO Textbox
|
||||
textbox (Snap _ e) x y w h t = do
|
||||
t_j <- toJSVal t
|
||||
fmap Textbox (js_textbox e x y w h t_j)
|
||||
|
||||
val :: Textbox -> IO T.Text
|
||||
val (Textbox j) = do
|
||||
r <- js_val j
|
||||
t <- fromJSVal r
|
||||
case t of
|
||||
Nothing -> return ""
|
||||
Just x -> return x
|
||||
|
||||
keydown :: Textbox -> (Int -> T.Text -> IO ()) -> IO ()
|
||||
keydown (Textbox j) cont = do
|
||||
callback <-
|
||||
asyncCallback2
|
||||
(\key val' -> do
|
||||
Just v <- fromJSVal val'
|
||||
Just k <- fromJSVal key
|
||||
cont k (T.pack v))
|
||||
js_keydown j callback
|
||||
|
||||
change :: Textbox -> (String -> IO ()) -> IO ()
|
||||
change (Textbox j) cont = do
|
||||
callback <-
|
||||
asyncCallback1
|
||||
(\val' -> do
|
||||
Just v <- fromJSVal val'
|
||||
cont v)
|
||||
js_change j callback
|
||||
|
||||
setAttrInt :: Textbox -> String -> Double -> IO ()
|
||||
setAttrInt (Textbox j) key val = do
|
||||
k' <- toJSVal key
|
||||
js_setAttrInt j k' val
|
||||
|
||||
setAttrStr :: Textbox -> String -> IO ()
|
||||
setAttrStr (Textbox j) val = do
|
||||
val' <- toJSVal val
|
||||
js_setAttrStr j val'
|
||||
|
||||
#ifdef __GHCJS__
|
||||
foreign import javascript unsafe
|
||||
"snap_textbox($1, $2, $3, $4, $5, $6)"
|
||||
js_textbox :: JSVal -> Double -> Double -> Double -> Double -> JSVal -> IO JSVal
|
||||
#else
|
||||
js_textbox :: JSVal -> Double -> Double -> Double -> Double -> JSVal -> IO JSVal
|
||||
js_textbox = undefined
|
||||
#endif
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Generalized constrained heterogeneity
|
||||
|
||||
data Some ctx = forall a. ctx a => Some a
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Foreign imports
|
||||
|
||||
#ifdef __GHCJS__
|
||||
foreign import javascript unsafe
|
||||
"$($1).attr({ width: $2, height: $3 })"
|
||||
js_snap_set_svg_dimensions :: JSVal -> Double -> Double -> IO ()
|
||||
#else
|
||||
js_snap_set_svg_dimensions :: JSVal -> Double -> Double -> IO ()
|
||||
js_snap_set_svg_dimensions = undefined
|
||||
#endif
|
||||
|
||||
#ifdef __GHCJS__
|
||||
foreign import javascript unsafe
|
||||
"Snap($1)"
|
||||
js_newSnap :: JSVal -> IO JSVal
|
||||
#else
|
||||
js_newSnap :: JSVal -> IO JSVal
|
||||
js_newSnap = undefined
|
||||
#endif
|
||||
|
||||
#ifdef __GHCJS__
|
||||
foreign import javascript unsafe
|
||||
"($1).stopPropagation()"
|
||||
js_stopPropagation :: JSVal -> IO ()
|
||||
#else
|
||||
js_stopPropagation :: JSVal -> IO ()
|
||||
js_stopPropagation = undefined
|
||||
#endif
|
||||
|
||||
#ifdef __GHCJS__
|
||||
foreign import javascript unsafe
|
||||
"($1).clear()"
|
||||
js_clear :: JSVal -> IO ()
|
||||
#else
|
||||
js_clear :: JSVal -> IO ()
|
||||
js_clear = undefined
|
||||
#endif
|
||||
#ifdef __GHCJS__
|
||||
foreign import javascript unsafe
|
||||
"$($1).parent().children('input').remove()"
|
||||
js_clear_el :: JSVal -> IO ()
|
||||
#else
|
||||
js_clear_el :: JSVal -> IO ()
|
||||
js_clear_el = undefined
|
||||
#endif
|
||||
|
||||
|
||||
#ifdef __GHCJS__
|
||||
foreign import javascript unsafe
|
||||
"($1).circle($2, $3, $4)"
|
||||
js_circle :: JSVal -> Double -> Double -> Double -> IO JSVal
|
||||
#else
|
||||
js_circle :: JSVal -> Double -> Double -> Double -> IO JSVal
|
||||
js_circle = undefined
|
||||
#endif
|
||||
|
||||
#ifdef __GHCJS__
|
||||
foreign import javascript unsafe
|
||||
"($1).rect($2, $3, $4, $5, $6, $7)"
|
||||
js_rect :: JSVal -> Double -> Double -> Double -> Double -> Double -> Double -> IO JSVal
|
||||
#else
|
||||
js_rect :: JSVal -> Double -> Double -> Double -> Double -> Double -> Double -> IO JSVal
|
||||
js_rect = undefined
|
||||
#endif
|
||||
|
||||
|
||||
#ifdef __GHCJS__
|
||||
foreign import javascript unsafe
|
||||
"($1).text($2, $3, $4)"
|
||||
js_text :: JSVal -> Double -> Double -> JSVal -> IO JSVal
|
||||
#else
|
||||
js_text :: JSVal -> Double -> Double -> JSVal -> IO JSVal
|
||||
js_text = undefined
|
||||
#endif
|
||||
|
||||
#ifdef __GHCJS__
|
||||
foreign import javascript unsafe
|
||||
"($1).path($2)"
|
||||
js_path :: JSVal -> JSVal -> IO JSVal
|
||||
#else
|
||||
js_path :: JSVal -> JSVal -> IO JSVal
|
||||
js_path = undefined
|
||||
#endif
|
||||
|
||||
#ifdef __GHCJS__
|
||||
foreign import javascript unsafe
|
||||
"($1).getBBox()"
|
||||
js_getBBox :: JSVal -> IO JSVal
|
||||
#else
|
||||
js_getBBox :: JSVal -> IO JSVal
|
||||
js_getBBox = undefined
|
||||
#endif
|
||||
|
||||
#ifdef __GHCJS__
|
||||
foreign import javascript unsafe
|
||||
"($1).attr($2)"
|
||||
js_attr :: JSVal -> JSVal -> IO ()
|
||||
#else
|
||||
js_attr :: JSVal -> JSVal -> IO ()
|
||||
js_attr = undefined
|
||||
#endif
|
||||
|
||||
#ifdef __GHCJS__
|
||||
foreign import javascript unsafe
|
||||
"var attrs = {}; attrs[$2] = $3; ($1).attr(attrs)"
|
||||
js_setAttr :: JSVal -> JSVal -> JSVal -> IO ()
|
||||
#else
|
||||
js_setAttr :: JSVal -> JSVal -> JSVal -> IO ()
|
||||
js_setAttr = undefined
|
||||
#endif
|
||||
|
||||
#ifdef __GHCJS__
|
||||
foreign import javascript unsafe
|
||||
"var attrs = {}; attrs[$2] = $3; $($1).attr(attrs)"
|
||||
js_setAttrInt :: JSVal -> JSVal -> Double -> IO ()
|
||||
#else
|
||||
js_setAttrInt :: JSVal -> JSVal -> Double -> IO ()
|
||||
js_setAttrInt = undefined
|
||||
#endif
|
||||
#ifdef __GHCJS__
|
||||
foreign import javascript unsafe
|
||||
"$($1).val($2)"
|
||||
js_setAttrStr :: JSVal -> JSVal -> IO ()
|
||||
#else
|
||||
js_setAttrStr :: JSVal -> JSVal -> IO ()
|
||||
js_setAttrStr = undefined
|
||||
#endif
|
||||
#ifdef __GHCJS__
|
||||
foreign import javascript unsafe
|
||||
"($1).data($2, $3)"
|
||||
js_setData :: JSVal -> JSVal -> JSVal -> IO ()
|
||||
#else
|
||||
js_setData :: JSVal -> JSVal -> JSVal -> IO ()
|
||||
js_setData = undefined
|
||||
#endif
|
||||
|
||||
#ifdef __GHCJS__
|
||||
foreign import javascript unsafe
|
||||
"($1).after($2)"
|
||||
js_after :: JSVal -> JSVal -> IO ()
|
||||
#else
|
||||
js_after :: JSVal -> JSVal -> IO ()
|
||||
js_after = undefined
|
||||
#endif
|
||||
|
||||
#ifdef __GHCJS__
|
||||
foreign import javascript unsafe
|
||||
"(function(){ return ($1).group.apply($1,$2); })()"
|
||||
js_group :: JSVal -> JSVal -> IO JSVal
|
||||
#else
|
||||
js_group :: JSVal -> JSVal -> IO JSVal
|
||||
js_group = undefined
|
||||
#endif
|
||||
|
||||
#ifdef __GHCJS__
|
||||
foreign import javascript unsafe
|
||||
"(function(){ var dragged = false; ($1).drag(function(x,y){ ($2)(x,y); dragged = true},function(x,y,e){$3(e.offsetX,e.offsetY)},function(){ ($4)(dragged) }); })()"
|
||||
js_drag :: JSVal -> Callback (JSVal -> JSVal -> IO ()) -> Callback (JSVal -> JSVal -> IO ()) -> Callback (JSVal -> IO ()) -> IO ()
|
||||
#else
|
||||
js_drag :: JSVal -> Callback (JSVal -> JSVal -> IO ()) -> Callback (JSVal -> JSVal -> IO ()) -> Callback (JSVal -> IO ()) -> IO ()
|
||||
js_drag = undefined
|
||||
#endif
|
||||
|
||||
#ifdef __GHCJS__
|
||||
foreign import javascript unsafe
|
||||
"new Snap.Matrix()"
|
||||
js_newMatrix :: IO JSVal
|
||||
#else
|
||||
js_newMatrix :: IO JSVal
|
||||
js_newMatrix = undefined
|
||||
#endif
|
||||
|
||||
#ifdef __GHCJS__
|
||||
foreign import javascript unsafe
|
||||
"($1).translate($2,$3)"
|
||||
js_translate :: JSVal -> Double -> Double -> IO ()
|
||||
#else
|
||||
js_translate :: JSVal -> Double -> Double -> IO ()
|
||||
js_translate = undefined
|
||||
#endif
|
||||
|
||||
#ifdef __GHCJS__
|
||||
foreign import javascript unsafe
|
||||
"($1).transform($2)"
|
||||
js_transform :: JSVal -> JSVal -> IO ()
|
||||
#else
|
||||
js_transform :: JSVal -> JSVal -> IO ()
|
||||
js_transform = undefined
|
||||
#endif
|
||||
|
||||
#ifdef __GHCJS__
|
||||
foreign import javascript unsafe
|
||||
"($1).hover($2, $3)"
|
||||
js_hover :: JSVal -> Callback (IO ()) -> Callback (IO ()) -> IO ()
|
||||
#else
|
||||
js_hover :: JSVal -> Callback (IO ()) -> Callback (IO ()) -> IO ()
|
||||
js_hover = undefined
|
||||
#endif
|
||||
|
||||
#ifdef __GHCJS__
|
||||
foreign import javascript unsafe
|
||||
"Snap.path.getPointAtLength($1,$2)"
|
||||
js_getPointAtLength :: JSVal -> Double -> IO JSVal
|
||||
#else
|
||||
js_getPointAtLength :: JSVal -> Double -> IO JSVal
|
||||
js_getPointAtLength = undefined
|
||||
#endif
|
||||
|
||||
#ifdef __GHCJS__
|
||||
foreign import javascript unsafe
|
||||
"$1.getTotalLength()"
|
||||
js_getTotalLength :: JSVal -> IO Double
|
||||
#else
|
||||
js_getTotalLength :: JSVal -> IO Double
|
||||
js_getTotalLength = undefined
|
||||
#endif
|
||||
|
||||
#ifdef __GHCJS__
|
||||
foreign import javascript unsafe
|
||||
"$1.val()"
|
||||
js_val :: JSVal -> IO JSVal
|
||||
#else
|
||||
js_val :: JSVal -> IO JSVal
|
||||
js_val = undefined
|
||||
#endif
|
||||
|
||||
#ifdef __GHCJS__
|
||||
foreign import javascript unsafe
|
||||
"$1.keydown(function(e){ $2(e.which, $1.val()); })"
|
||||
js_keydown :: JSVal -> Callback (JSVal -> JSVal -> IO ()) -> IO ()
|
||||
#else
|
||||
js_keydown :: JSVal -> Callback (JSVal -> JSVal -> IO ()) -> IO ()
|
||||
js_keydown = undefined
|
||||
#endif
|
||||
|
||||
#ifdef __GHCJS__
|
||||
foreign import javascript unsafe
|
||||
"$1.change(function(e){ $2($1.val()); })"
|
||||
js_change :: JSVal -> Callback (JSVal -> IO ()) -> IO ()
|
||||
#else
|
||||
js_change :: JSVal -> Callback (JSVal -> IO ()) -> IO ()
|
||||
js_change = undefined
|
||||
#endif
|
||||
|
||||
#ifdef __GHCJS__
|
||||
foreign import javascript unsafe
|
||||
"($1).click(function(e){ $2(e, [e.offsetX, e.offsetY], e.altKey); })"
|
||||
js_click :: JSVal -> Callback (JSVal -> JSVal -> JSVal -> IO ()) -> IO ()
|
||||
#else
|
||||
js_click :: JSVal -> Callback (JSVal -> JSVal -> JSVal -> IO ()) -> IO ()
|
||||
js_click = undefined
|
||||
#endif
|
||||
|
||||
#ifdef __GHCJS__
|
||||
foreign import javascript unsafe
|
||||
"console.log('%o',$1)"
|
||||
js_console_log :: JSVal -> IO ()
|
||||
#else
|
||||
js_console_log :: JSVal -> IO ()
|
||||
js_console_log = undefined
|
||||
#endif
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- GHCJS compat
|
||||
|
||||
#ifndef __GHCJS__
|
||||
class ToJSVal a where toJSVal :: a -> IO JSVal
|
||||
instance ToJSVal JSVal where toJSVal = undefined
|
||||
instance ToJSVal Char where toJSVal = undefined
|
||||
instance ToJSVal Int where toJSVal = undefined
|
||||
instance ToJSVal Double where toJSVal = undefined
|
||||
instance (ToJSVal a) => ToJSVal [a] where toJSVal = undefined
|
||||
class FromJSVal a where fromJSVal :: JSVal -> IO a
|
||||
instance FromJSVal String where fromJSVal = undefined
|
||||
instance FromJSVal Int where fromJSVal = undefined
|
||||
instance FromJSVal Bool where fromJSVal = undefined
|
||||
instance FromJSVal (Maybe a) where fromJSVal = undefined
|
||||
toJSVal_aeson :: ToJSON a => a -> IO JSVal
|
||||
toJSVal_aeson = undefined
|
||||
data JSVal
|
||||
data Callback a
|
||||
asyncCallback :: (IO ()) -> IO (Callback (IO ()))
|
||||
asyncCallback = undefined
|
||||
asyncCallback2 :: (JSVal -> JSVal -> IO ()) -> IO (Callback (JSVal -> JSVal -> IO ()))
|
||||
asyncCallback2 = undefined
|
||||
asyncCallback3 :: (JSVal -> JSVal -> JSVal -> IO ()) -> IO (Callback (JSVal -> JSVal -> JSVal -> IO ()))
|
||||
asyncCallback3 = undefined
|
||||
asyncCallback1 :: (JSVal -> IO ()) -> IO (Callback (JSVal -> IO ()))
|
||||
asyncCallback1 = undefined
|
||||
#endif
|
408
web/Snappy.hs
Normal file
408
web/Snappy.hs
Normal file
@ -0,0 +1,408 @@
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE Rank2Types #-}
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ExistentialQuantification #-}
|
||||
|
||||
-- | A reactive Snap SVG interface.
|
||||
|
||||
module Snappy where
|
||||
|
||||
import Control.Concurrent
|
||||
import Control.Monad
|
||||
import Data.IORef
|
||||
import Data.Maybe
|
||||
import qualified Data.Text as T
|
||||
import qualified Snap
|
||||
import System.IO.Unsafe
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Event type
|
||||
|
||||
data Event a = forall origin s. Event
|
||||
{ eventSubscribers :: IORef [origin -> IO ()]
|
||||
, eventFromOrigin :: s -> origin -> (Maybe a,s)
|
||||
, eventState :: s
|
||||
}
|
||||
|
||||
instance Functor Event where
|
||||
fmap f (Event subscribers fromOrigin state) =
|
||||
Event
|
||||
subscribers
|
||||
(\s origin ->
|
||||
let (a', s') = fromOrigin s origin
|
||||
in (fmap f a', s'))
|
||||
state
|
||||
{-# INLINE fmap #-}
|
||||
|
||||
-- | Zip events that occur in tandem within the given time frame.
|
||||
zipEvents :: (a -> b -> c) -> Event a -> Event b -> Event c
|
||||
zipEvents f e1 e2 =
|
||||
unsafePerformIO
|
||||
(do subscribersRef <- newIORef mempty
|
||||
tvar1 <- newEmptyMVar
|
||||
tvar2 <- newEmptyMVar
|
||||
let !ev = Event subscribersRef (\s (a, b) -> (Just (f a b), s)) ()
|
||||
let listen e us them pair =
|
||||
bindEvent
|
||||
e
|
||||
(\a -> do
|
||||
result <- tryTakeMVar them
|
||||
case result of
|
||||
Nothing -> putMVar us a
|
||||
Just b -> do
|
||||
subscribers <- readIORef subscribersRef
|
||||
mapM_ ($ (pair a b)) subscribers)
|
||||
listen e1 tvar1 tvar2 (\a b -> (a, b))
|
||||
listen e2 tvar2 tvar1 (\a b -> (b, a))
|
||||
pure ev)
|
||||
{-# NOINLINE zipEvents #-}
|
||||
|
||||
scanEvent :: (s -> a -> s) -> s -> Event a -> Event s
|
||||
scanEvent f nil (Event subscribers fromOrigin oldState) =
|
||||
Event
|
||||
subscribers
|
||||
(\s origin ->
|
||||
let (a, _) = fromOrigin oldState origin
|
||||
s' = fmap (f s) a
|
||||
in (s', fromMaybe s s'))
|
||||
nil
|
||||
{-# INLINE scanEvent #-}
|
||||
|
||||
mapMaybeEvent :: (a -> Maybe b) -> Event a -> Event b
|
||||
mapMaybeEvent f (Event subscribers fromOrigin oldState) =
|
||||
Event
|
||||
subscribers
|
||||
(\s origin ->
|
||||
let (a, s') = fromOrigin s origin
|
||||
in (a >>= f, s'))
|
||||
oldState
|
||||
{-# INLINE mapMaybeEvent #-}
|
||||
|
||||
filterEvent :: (a -> Bool) -> Event a -> Event a
|
||||
filterEvent p =
|
||||
mapMaybeEvent
|
||||
(\a ->
|
||||
if p a
|
||||
then Just a
|
||||
else Nothing)
|
||||
|
||||
bindEvent :: Event a -> (a -> IO ()) -> IO ()
|
||||
bindEvent Event {..} m = do
|
||||
do stateRef <- newIORef eventState
|
||||
modifyIORef
|
||||
eventSubscribers
|
||||
(++ [ \v -> do
|
||||
s <- readIORef stateRef
|
||||
let (v', s') = eventFromOrigin s v
|
||||
case v' of
|
||||
Nothing -> return ()
|
||||
Just v'' -> m v''
|
||||
writeIORef stateRef s'
|
||||
])
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Dynamic type
|
||||
|
||||
data Dynamic a = Dynamic
|
||||
{ dynDefault :: a
|
||||
, dynEvent :: Maybe (Event a)
|
||||
}
|
||||
|
||||
instance Functor Dynamic where
|
||||
fmap f (Dynamic def event) =
|
||||
Dynamic (f def) (fmap (fmap f) event)
|
||||
{-# INLINE fmap #-}
|
||||
|
||||
instance Applicative Dynamic where
|
||||
pure a = Dynamic {dynDefault = a, dynEvent = Nothing}
|
||||
{-# INLINE pure #-}
|
||||
f <*> a =
|
||||
Dynamic
|
||||
{ dynDefault = dynDefault f (dynDefault a)
|
||||
, dynEvent =
|
||||
case (dynEvent f, dynEvent a) of
|
||||
(Nothing, Nothing) -> Nothing
|
||||
(Just fevent, Nothing) -> Just (fmap ($ dynDefault a) fevent)
|
||||
(Nothing, Just aevent) -> Just (fmap (dynDefault f) aevent)
|
||||
(Just fevent, Just aevent) -> Just (zipEvents ($) fevent aevent)
|
||||
}
|
||||
{-# INLINE (<*>) #-}
|
||||
|
||||
zipDynamics
|
||||
:: (a -> b -> c)
|
||||
-> Dynamic a
|
||||
-> Dynamic b
|
||||
-> Dynamic c
|
||||
zipDynamics f d1 d2 =
|
||||
Dynamic
|
||||
{ dynDefault = f (dynDefault d1) (dynDefault d2)
|
||||
, dynEvent =
|
||||
case (dynEvent d1, dynEvent d2) of
|
||||
(Nothing, Nothing) -> Nothing
|
||||
(Just d1event, Nothing) -> Just (fmap (\a -> f a (dynDefault d2)) d1event)
|
||||
(Nothing, Just d2event) -> Just (fmap (\a -> f (dynDefault d1) a) d2event)
|
||||
(Just d1event, Just d2event) -> Just (zipEvents f d1event d2event)
|
||||
}
|
||||
|
||||
scanDynamic :: (s -> a -> s) -> s -> Event a -> Dynamic s
|
||||
scanDynamic f nil e =
|
||||
Dynamic {dynDefault = nil
|
||||
,dynEvent = Just (scanEvent f nil e)}
|
||||
|
||||
bindDynamic :: Dynamic a -> (a -> IO ()) -> IO ()
|
||||
bindDynamic (Dynamic _ event) m =
|
||||
maybe
|
||||
(return ())
|
||||
(\e ->
|
||||
void
|
||||
(forkIO
|
||||
(do yield
|
||||
bindEvent e m)))
|
||||
event
|
||||
|
||||
dynamicDef :: Dynamic a -> a
|
||||
dynamicDef (Dynamic def _) = def
|
||||
|
||||
eventToDynamic :: a -> Event a -> Dynamic a
|
||||
eventToDynamic d e = Dynamic {dynDefault = d, dynEvent = Just e}
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Drag event
|
||||
|
||||
data DragEvent = DragStart Pos | Dragging Drag | DragStop
|
||||
|
||||
data Pos = Pos
|
||||
{ posX :: Double
|
||||
, posY :: Double
|
||||
}
|
||||
|
||||
data Drag = Drag
|
||||
{ dragDX :: Double
|
||||
, dragDY :: Double
|
||||
}
|
||||
|
||||
data Rec = Rec
|
||||
{ recX :: Double
|
||||
, recY :: Double
|
||||
, recW :: Double
|
||||
, recH :: Double
|
||||
}
|
||||
|
||||
dragEvent :: Snap.HasDrag d => d -> IO (Event DragEvent)
|
||||
dragEvent d = do
|
||||
subscribersRef <- newIORef mempty
|
||||
Snap.drag
|
||||
d
|
||||
(\dx dy -> do
|
||||
subscribers <- readIORef subscribersRef
|
||||
mapM_ (\subscriber -> do subscriber (Dragging (Drag dx dy))) subscribers)
|
||||
(\x y -> do
|
||||
subscribers <- readIORef subscribersRef
|
||||
mapM_ (\subscriber -> subscriber (DragStart (Pos x y))) subscribers)
|
||||
(\_ -> do
|
||||
subscribers <- readIORef subscribersRef
|
||||
mapM_ (\subscriber -> subscriber DragStop) subscribers)
|
||||
st <- newIORef ()
|
||||
pure
|
||||
(Event
|
||||
{ eventSubscribers = subscribersRef
|
||||
, eventFromOrigin = \s origin -> (Just origin, s)
|
||||
, eventState = st
|
||||
})
|
||||
|
||||
changeEvent :: Snap.Textbox -> IO (Event String)
|
||||
changeEvent d = do
|
||||
subscribersRef <- newIORef mempty
|
||||
Snap.change
|
||||
d
|
||||
(\text -> do
|
||||
subscribers <- readIORef subscribersRef
|
||||
mapM_ (\subscriber -> subscriber text) subscribers)
|
||||
st <- newIORef ()
|
||||
pure
|
||||
(Event
|
||||
{ eventSubscribers = subscribersRef
|
||||
, eventFromOrigin = \s origin -> (Just origin, s)
|
||||
, eventState = st
|
||||
})
|
||||
|
||||
-- | A dynamic which makes a draggable thing move around upon drag at
|
||||
-- the given axis.
|
||||
draggable
|
||||
:: Circle
|
||||
-> Double
|
||||
-> (Drag -> Double)
|
||||
-> Dynamic Double
|
||||
draggable c initial get =
|
||||
fmap
|
||||
snd
|
||||
(scanDynamic
|
||||
(\(origin, new) event ->
|
||||
case event of
|
||||
Dragging pos -> (origin, origin + get pos)
|
||||
_ -> (new, new))
|
||||
(initial, initial)
|
||||
(circleDrag c))
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Click event
|
||||
|
||||
data ClickEvent = ClickEvent
|
||||
{ clickX :: !Double
|
||||
, clickY :: !Double
|
||||
, clickModifier :: !Snap.Modifier
|
||||
} deriving (Show)
|
||||
|
||||
clickEvent :: Snap.HasClick d => d -> IO (Event ClickEvent)
|
||||
clickEvent d = do
|
||||
subscribersRef <- newIORef mempty
|
||||
Snap.singleClick
|
||||
d
|
||||
(\_event modifier x y -> do
|
||||
subscribers <- readIORef subscribersRef
|
||||
mapM_ (\subscriber -> subscriber (ClickEvent x y modifier)) subscribers)
|
||||
st <- newIORef ()
|
||||
pure
|
||||
(Event
|
||||
{ eventSubscribers = subscribersRef
|
||||
, eventFromOrigin = \s origin -> (Just origin, s)
|
||||
, eventState = st
|
||||
})
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Circle object
|
||||
|
||||
data Circle = Circle
|
||||
{ circleObject :: Snap.Circle
|
||||
, circleDrag :: Event DragEvent
|
||||
, circleX :: Dynamic Double
|
||||
, circleY :: Dynamic Double
|
||||
}
|
||||
|
||||
circle :: Snap.Snap -> Dynamic Double -> Dynamic Double -> Dynamic Double -> IO Circle
|
||||
circle snap xdynamic ydynamic rdynamic = do
|
||||
let x = dynamicDef xdynamic
|
||||
y = dynamicDef ydynamic
|
||||
c <- Snap.circle snap x y (dynamicDef rdynamic)
|
||||
drag <- dragEvent c
|
||||
t <- Snap.newMatrix
|
||||
xLast <- newIORef 0
|
||||
bindDynamic
|
||||
xdynamic
|
||||
(\x' -> do
|
||||
undo <- readIORef xLast
|
||||
Snap.translate t (-undo + (x' - x)) 0
|
||||
Snap.transform c t
|
||||
writeIORef xLast (x' - x))
|
||||
yLast <- newIORef 0
|
||||
bindDynamic
|
||||
ydynamic
|
||||
(\y' -> do
|
||||
undo <- readIORef yLast
|
||||
Snap.translate t 0 (-undo + (y' - y))
|
||||
Snap.transform c t
|
||||
writeIORef yLast (y' - y))
|
||||
pure (Circle c drag xdynamic ydynamic)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Rect object
|
||||
|
||||
data Rect = Rect
|
||||
{ rectObject :: Snap.Rect
|
||||
, rectDrag :: Event DragEvent
|
||||
}
|
||||
|
||||
rect
|
||||
:: Snap.Snap
|
||||
-> Dynamic Double
|
||||
-> Dynamic Double
|
||||
-> Dynamic Double
|
||||
-> Dynamic Double
|
||||
-> Dynamic String
|
||||
-> IO Rect
|
||||
rect snap xdynamic ydynamic wdynamic hdynamic fdynamic = do
|
||||
let x = dynamicDef xdynamic
|
||||
y = dynamicDef ydynamic
|
||||
c <- Snap.rect snap x y (dynamicDef wdynamic) (dynamicDef hdynamic) 0 0
|
||||
Snap.setAttr c "fill" (dynamicDef fdynamic)
|
||||
drag <- dragEvent c
|
||||
bindDynamic xdynamic (\x' -> Snap.setAttr c "x" x')
|
||||
bindDynamic ydynamic (\y' -> Snap.setAttr c "y" y')
|
||||
bindDynamic wdynamic (\w' -> Snap.setAttr c "width" w')
|
||||
bindDynamic hdynamic (\h' -> Snap.setAttr c "height" h')
|
||||
bindDynamic fdynamic (\f' -> Snap.setAttr c "fill" f')
|
||||
pure (Rect c drag)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Text object
|
||||
|
||||
data Text = Text
|
||||
{ textObject :: Snap.Text
|
||||
, textClicked :: Event ClickEvent
|
||||
}
|
||||
|
||||
text :: Snap.Snap -> Dynamic Double -> Dynamic Double -> Dynamic String -> IO Text
|
||||
text snap xdynamic ydynamic tdynamic = do
|
||||
let x = dynamicDef xdynamic
|
||||
y = dynamicDef ydynamic
|
||||
c <- Snap.text snap x y (dynamicDef tdynamic)
|
||||
t <- Snap.newMatrix
|
||||
xLast <- newIORef 0
|
||||
bindDynamic
|
||||
xdynamic
|
||||
(\x' -> do
|
||||
undo <- readIORef xLast
|
||||
Snap.translate t (-undo + (x' - x)) 0
|
||||
Snap.transform c t
|
||||
writeIORef xLast (x' - x))
|
||||
yLast <- newIORef 0
|
||||
bindDynamic
|
||||
ydynamic
|
||||
(\y' -> do
|
||||
undo <- readIORef yLast
|
||||
Snap.translate t 0 (-undo + (y' - y))
|
||||
Snap.transform c t
|
||||
writeIORef yLast (y' - y))
|
||||
bindDynamic tdynamic (\t' -> Snap.setAttr c "#text" t')
|
||||
clickev <- clickEvent c
|
||||
pure (Text c clickev)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Textbox object
|
||||
|
||||
data Textbox = Textbox
|
||||
{ textboxObject :: Snap.Textbox
|
||||
, textboxChange :: Event String
|
||||
}
|
||||
|
||||
textbox
|
||||
:: Snap.Snap
|
||||
-> Dynamic Double
|
||||
-> Dynamic Double
|
||||
-> Dynamic Double
|
||||
-> Dynamic Double
|
||||
-> Dynamic String
|
||||
-> IO Textbox
|
||||
textbox snap xdynamic ydynamic wdynamic hdynamic tdynamic = do
|
||||
let x = dynamicDef xdynamic
|
||||
y = dynamicDef ydynamic
|
||||
w = dynamicDef wdynamic
|
||||
h = dynamicDef hdynamic
|
||||
c <- Snap.textbox snap x y w h (dynamicDef tdynamic)
|
||||
t <- Snap.newMatrix
|
||||
bindDynamic
|
||||
xdynamic
|
||||
(\x' -> Snap.setAttrInt c "left" x')
|
||||
bindDynamic
|
||||
ydynamic
|
||||
(\x' -> Snap.setAttrInt c "top" x')
|
||||
bindDynamic
|
||||
wdynamic
|
||||
(\x' -> Snap.setAttrInt c "width" x')
|
||||
bindDynamic
|
||||
hdynamic
|
||||
(\x' -> Snap.setAttrInt c "height" x')
|
||||
bindDynamic tdynamic (\t' -> Snap.setAttrStr c t')
|
||||
ch <- changeEvent c
|
||||
pure (Textbox c ch)
|
Loading…
Reference in New Issue
Block a user