updating the other examples to compile

hgeometry-examples/convexHull/Main.hs

@@ -84,7 +84,6 @@ viewModel m = div_ [ ]
                    [ either CanvasAction id <$>
                      Canvas.svgCanvas_ (m^.canvas)
                                        [ onClick AddPoint
-                                       , id_ "mySvg"
                                        , styleInline_ "border: 1px solid black"
                                        ]
                                        canvasBody
@@ -109,7 +108,7 @@ viewModel m = div_ [ ]
                          , textAt p [] (ms i)
                          ]
                  | (i,p) <- m^..points.ifolded.withIndex ]
-              <> [ draw p [ fill_ "blue" ]  | Just p <- [m^.canvas.mouseCoordinates] ]
+              -- <> [ draw p [ fill_ "blue" ]  | Just p <- [m^.canvas.mouseCoordinates] ]
 
 --------------------------------------------------------------------------------
 
@@ -119,11 +118,8 @@ main = JSaddle.run 8080 $
             App { model         = initialModel
                 , update        = flip updateModel
                 , view          = viewModel
-                , subs          = Canvas.subs "mySvg" CanvasAction
-                , events        = Map.insert "touchstart" False
-                                  . Map.insert "touchmove" False
-                                  . Map.insert "mousemove" False
-                                  $ defaultEvents
+                , subs          = mempty
+                , events        = Canvas.withCanvasEvents defaultEvents
                 , initialAction = Id
                 , mountPoint    = Nothing
                 , logLevel      = Off

hgeometry-examples/duality/Main.hs

@@ -106,14 +106,12 @@ viewModel m = div_ [ ]
                    [ either PrimalCanvasAction id <$>
                      Canvas.svgCanvas_ (m^.primalCanvas)
                                        [ onClick PrimalClick
-                                       , id_ "primalSvg"
                                        , styleInline_ "border: 1px solid black"
                                        ]
                                        primalBody
                    , either DualCanvasAction id <$>
                      Canvas.svgCanvas_ (m^.dualCanvas)
                                        [ onClick DualClick
-                                       , id_ "dualSvg"
                                        , styleInline_ "border: 1px solid black"
                                        ]
                                        dualBody
@@ -142,7 +140,7 @@ viewModel m = div_ [ ]
                           ]
                  ]
          | l :+ color <- m^..lines.folded ]
-      <> [ draw p [ fill_ "blue" ]  | Just p <- [mousePos] ]
+      -- <> [ draw p [ fill_ "blue" ]  | Just p <- [mousePos] ]
 
 instance Drawable (LineEQ R) where
   draw l = let maxP = Point2 large large
@@ -161,12 +159,8 @@ main = JSaddle.run 8080 $
             App { model         = initialModel
                 , update        = flip updateModel
                 , view          = viewModel
-                , subs          =    Canvas.subs "primalSvg" PrimalCanvasAction
-                                  <> Canvas.subs "dualSvg"   DualCanvasAction
-                , events        = Map.insert "touchstart" False
-                                  . Map.insert "touchmove" False
-                                  . Map.insert "mousemove" False
-                                  $ defaultEvents
+                , subs          = mempty
+                , events        = Canvas.withCanvasEvents defaultEvents
                 , initialAction = Id
                 , mountPoint    = Nothing
                 , logLevel      = Off

hgeometry-examples/lineSegmentIntersection/Main.hs

@@ -4,7 +4,6 @@ module Main(main) where
 
 import           Control.Lens hiding (view, element)
 import qualified Data.IntMap as IntMap
-import qualified Data.Map as Map
 import           GHC.TypeNats
 import           HGeometry.Ext
 import           HGeometry.LineSegment
@@ -111,7 +110,7 @@ viewModel m = div_ [ ]
               <> [ g_ [] [ draw p [ fill_ "red"]
                          ]
                  | p <- m^..intersections.to intersectionPoints.folded ]
-              <> [ draw p [ fill_ "blue" ]  | Just p <- [m^.canvas.mouseCoordinates] ]
+              -- <> [ draw p [ fill_ "blue" ]  | Just p <- [m^.canvas.mouseCoordinates] ]
 
     partialSegment p q = [ClosedLineSegment <$> p <*> q ]
 
@@ -126,14 +125,8 @@ mainJSM = do
     let myApp = App { model         = initialModel
                     , update        = flip updateModel
                     , view          = viewModel
-                    , subs          = Canvas.subs "mySvg" CanvasAction
-                                      <> [
-                                        -- arrowsSub (CanvasAction . ArrowPress)
-                                      ]
-                    , events        = Map.insert "touchstart" False
-                                    . Map.insert "touchmove" False
-                                    . Map.insert "mousemove" False
-                                    $ defaultEvents
+                    , subs          = mempty
+                    , events        = Canvas.withCanvasEvents defaultEvents
                     , initialAction = Id
                     , mountPoint    = Nothing
                     , logLevel      = Off

hgeometry-examples/polyLineDrawing/Main.hs

@@ -185,6 +185,7 @@ viewModel m = div_ [ ]
                         [ "html { overscroll-behavior: none; }"
                         , "html body { overflow: hidden; }"
                         ]
+                        -- these two lines prevent weird janky scrolling on ipad
                    ]
   where
     unlines' = mconcat . List.intersperse "\n"

hgeometry-examples/polygonTriangulation/Main.hs

@@ -107,7 +107,7 @@ viewModel m = div_ [ ]
                          , textAt p [] (ms i)
                          ]
                  | (i,p) <- m^..points.ifolded.withIndex ]
-              <> [ draw p [ fill_ "blue" ]  | Just p <- [m^.canvas.mouseCoordinates] ]
+              -- <> [ draw p [ fill_ "blue" ]  | Just p <- [m^.canvas.mouseCoordinates] ]
 
 --------------------------------------------------------------------------------
 
@@ -117,11 +117,8 @@ main = JSaddle.run 8080 $
             App { model         = initialModel
                 , update        = flip updateModel
                 , view          = viewModel
-                , subs          = Canvas.subs "mySvg" CanvasAction
-                , events        = Map.insert "touchstart" False
-                                  . Map.insert "touchmove" False
-                                  . Map.insert "mousemove" False
-                                  $ defaultEvents
+                , subs          = mempty
+                , events        = Canvas.withCanvasEvents defaultEvents
                 , initialAction = Id
                 , mountPoint    = Nothing
                 , logLevel      = Off

hgeometry-examples/voronoiDiagram/Main.hs

@@ -87,7 +87,6 @@ viewModel m = div_ [ ]
                    [ either CanvasAction id <$>
                      Canvas.svgCanvas_ (m^.canvas)
                                        [ onClick AddPoint
-                                       , id_ "mySvg"
                                        , styleInline_ "border: 1px solid black"
                                        ]
                                        canvasBody
@@ -108,7 +107,7 @@ viewModel m = div_ [ ]
                          , textAt p [] (ms i)
                          ]
                  | (i,p) <- m^..points.ifolded.withIndex ]
-              <> [ draw p [ fill_ "blue" ]  | Just p <- [m^.canvas.mouseCoordinates] ]
+              -- <> [ draw p [ fill_ "blue" ]  | Just p <- [m^.canvas.mouseCoordinates] ]
 
 --------------------------------------------------------------------------------
 
@@ -118,11 +117,8 @@ main = JSaddle.run 8080 $
             App { model         = initialModel
                 , update        = flip updateModel
                 , view          = viewModel
-                , subs          = Canvas.subs "mySvg" CanvasAction
-                , events        = Map.insert "touchstart" False
-                                  . Map.insert "touchmove" False
-                                  . Map.insert "mousemove" False
-                                  $ defaultEvents
+                , subs          = mempty
+                , events        = Canvas.withCanvasEvents defaultEvents
                 , initialAction = Id
                 , mountPoint    = Nothing
                 , logLevel      = Off

hgeometry/hgeometry.cabal

@@ -467,9 +467,8 @@ library svg
         HGeometry.Miso.Svg.Canvas
         HGeometry.Svg
 
-        Miso.Subscription.MouseExtra
-
     other-modules:
+        Miso.Subscription.MouseExtra
         HGeometry.Miso.Svg.Writer
         Miso.String.Util
         Miso.FFI.Extra

hgeometry/web/src/Miso/Subscription/MouseExtra.hs

@@ -2,12 +2,9 @@
 {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
 {-# HLINT ignore "Redundant lambda" #-}
 module Miso.Subscription.MouseExtra
-  ( relativeMouseSub
-  , relativeTouchedSub
-  , onMouseEnterAt
+  ( onMouseEnterAt
   , onMouseMoveAt
   , onMouseClickAt
-
   , onTouchStartAt
   , onTouchMoveAt
   , onTouchEnd
@@ -26,8 +23,6 @@ import           Miso
 import           Miso.FFI.Extra
 import           Miso.String (MisoString)
 
-import           Debug.Trace
-
 --------------------------------------------------------------------------------
 
 -- | onMouseMove event, the position is relative to the target of the event
@@ -52,15 +47,19 @@ mousePositionDecoder = Decoder dec dt
 
 --------------------------------------------------------------------------------
 
+-- | On start of a touch event,
 onTouchStartAt :: (Point 2 Int -> action) -> Attribute action
 onTouchStartAt = on "touchstart" touchDecoder
 
+-- | On touchMove event
 onTouchMoveAt :: (Point 2 Int -> action) -> Attribute action
 onTouchMoveAt = on "touchmove" touchDecoder
 
+-- | onTouchEnd event
 onTouchEnd     :: action -> Attribute action
 onTouchEnd act = on "touchend" emptyDecoder (const act)
 
+-- | The decoder of touch events, gets the touchTarget of the input
 touchDecoder :: Decoder (Point 2 Int)
 touchDecoder = Decoder dec dt
   where
@@ -70,109 +69,3 @@ touchDecoder = Decoder dec dt
       (tv:_) -> withObject "touch" (\o ->
                   Point2 <$> o .: "pageX"   <*> o .: "pageY") tv
       _      -> fail "touchDecoder: expected at least one targetTouches"
-
-
--- -- | touchmove event
--- onTouchMove :: (TouchEvent -> action) -> Attribute action
--- onTouchMove = on "touchmove" touchDecoder
-
-
-
-
-
---------------------------------------------------------------------------------
-
--- | Gets the mouse position relative to the element named by the first argument
-relativeMouseSub          :: MisoString -> (Maybe (Point 2 Int) -> action) -> Sub action
-relativeMouseSub elemId f = \sink -> do
-    windowAddEventListener "mousemove" $ relativeMouseSubImpl elemId f sink
-
--- | the implementation of the relative Mouse sub
-relativeMouseSubImpl               :: MisoString -> (Maybe (Point 2 Int) -> action)
-                                   -> Sink action
-                                   -> JSVal -> JSM ()
-relativeMouseSubImpl elemId f sink = \mouseEvent -> do
-        elem'  <- getElementById elemId
-        rect   <- getInnerRect elem'
-        Just x <- fromJSVal =<< getProp "clientX" (Object mouseEvent)
-        Just y <- fromJSVal =<< getProp "clientY" (Object mouseEvent)
-        let mp = inDOMRect (Point2 x y) rect
-        -- see https://stackoverflow.com/questions/10298658/mouse-position-inside-autoscaled-svg
-        liftIO (sink $ f mp)
-
--- | Get touchmove events on the given elementId, in coordinates relative to the
--- element.
-relativeTouchedSub          :: MisoString -> (Maybe (Point 2 Int) -> action) -> Sub action
-relativeTouchedSub elemId f = \sink -> do
-    windowAddEventListener "touchmove" $ relativeTouchSubImpl elemId f sink
-
-
--- | the implementation of the relative Mouse sub
-relativeTouchSubImpl               :: MisoString -> (Maybe (Point 2 Int) -> action)
-                                   -> Sink action
-                                   -> JSVal -> JSM ()
-relativeTouchSubImpl elemId f sink = \mouseEvent -> do
-        elem'  <- getElementById elemId
-        rect   <- getInnerRect elem'
-        Just (x :: Double) <- fromJSVal =<< getProp "pageX" (Object mouseEvent)
-        Just (y :: Double) <- fromJSVal =<< getProp "pageY" (Object mouseEvent)
-        let mp = inDOMRect (Point2 (round x) (round y)) rect
-        -- liftIO (print (rect,x,y,px,py,mp))
-        -- see https://stackoverflow.com/questions/10298658/mouse-position-inside-autoscaled-svg
-        liftIO (sink $ f mp)
-
---------------------------------------------------------------------------------
-
--- | A DOMRect
-data DOMRect = DOMRect { top    :: {-# UNPACK #-} !Int
-                       , left   :: {-# UNPACK #-} !Int
-                       , width  :: {-# UNPACK #-} !Int
-                       , height :: {-# UNPACK #-} !Int
-                       } deriving (Show,Eq)
-
--- | Given a point and a rect, both in global coordinates, returns the relative
--- coordinates of the point inside the rect (if the point lies inside the rectangle) (with
--- respect to the top-left corner of the rectangle).
-inDOMRect :: Point 2 Int -> DOMRect -> Maybe (Point 2 Int)
-inDOMRect (Point2 x y) (DOMRect t l w h)
-  | inInterval x l w && inInterval y t h = Just $ Point2 (x-l) (y-t)
-  | otherwise                            = Nothing
-  where
-    inInterval q s len = s <= q && q <= s+len
-
-
--- -- | Get the bounding rectangle of the given element, relative to the viewport
--- getBoundingBoxOf        :: MisoString -> JSM DOMRect
--- getBoundingBoxOf elemId = do
---     elem' <- getElementById elemId
---     getBoundingRect elem'
-
--- | Get the bounding rectangle of the given element, relative to the viewport
-
-getBoundingRect       :: JSVal -> JSM DOMRect
-getBoundingRect elem' = do
-    rect  <- getBoundingClientRect elem'
-    Just l <- fromJSVal =<< getProp "left"    (Object rect)
-    Just t <- fromJSVal =<< getProp "top"     (Object rect)
-    Just w <- fromJSVal =<< getProp "width"   (Object rect)
-    Just h <- fromJSVal =<< getProp "height"  (Object rect)
-    pure $ DOMRect l t w h
-
--- | Get the inner rectangle of an element (i.e. without its border) relative to the
--- viewport.
-getInnerRect       :: JSVal -> JSM DOMRect
-getInnerRect elem' = do
-  Just cl <- fromJSVal =<< getProp "clientLeft"   (Object elem')
-  Just ct <- fromJSVal =<< getProp "clientTop"    (Object elem')
-  Just cr <- fromJSVal =<< getProp "clientRight"  (Object elem')
-  Just cb <- fromJSVal =<< getProp "clientBottom" (Object elem')
-  DOMRect l t w h <- getBoundingRect elem'
-  pure $ DOMRect (l-cl) (t-ct) (w - cr) (h - cb)
-
-
---  relativePositionIn          :: MisoString
---                             ->
--- relativePositionIn elemId f =
-
-
---------------------------------------------------------------------------------