Add ghcjs to build

2024-10-06 14:17:45 +03:00 · 2017-04-27 15:38:27 +01:00 · 2017-04-27 15:38:27 +01:00 · 357ae94690
commit 357ae94690
parent 59f0b2623e
7 changed files with 1257 additions and 0 deletions
--- a/build.sh
+++ b/build.sh
@ -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/
--- a/duet.cabal
+++ b/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
--- a/stack-ghcjs.yaml
+++ b/stack-ghcjs.yaml
@ -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
--- a/static/index.html
+++ b/static/index.html
@ -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>
--- a/web/Main.hs
+++ b/web/Main.hs
@ -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 ()
--- a/web/Snap.hs
+++ b/web/Snap.hs
@ -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
--- a/web/Snappy.hs
+++ b/web/Snappy.hs
@ -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)
				`@ -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/`