Setting up Leaflet.js with Reflex.Dom

leaf.hs

{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI #-}
import Reflex.Dom
import Data.Monoid
import GHCJS.Types
import GHCJS.Foreign
import GHCJS.DOM.Element
import GHCJS.DOM.Types
import Control.Monad.IO.Class

newtype LeafletMap = LeafletMap { unLeafletMap :: JSRef LeafletMap }

newtype LeafletTileLayer = LeafletTileLayer { unLeafletTileLayer :: JSRef LeafletTileLayer }

foreign import javascript unsafe "L['map']($1)" leafletMap_ :: JSRef Element -> IO (JSRef LeafletMap)

foreign import javascript unsafe "$1['setView']([$2, $3], $4)" leafletMapSetView_ :: JSRef LeafletMap -> Double -> Double -> Int -> IO ()

foreign import javascript unsafe "L['tileLayer']($1, { maxZoom: $2, attribution: $3})" leafletTileLayer_ :: JSString -> Int -> JSString -> IO (JSRef LeafletTileLayer)

foreign import javascript unsafe "$1['addTo']($2)" leafletTileLayerAddToMap_ :: JSRef LeafletTileLayer -> JSRef LeafletMap -> IO ()

foreign import javascript unsafe "$1['invalidateSize']()" leafletMapInvalidateSize_ :: JSRef LeafletMap -> IO ()

leafletMap :: IsElement e => e -> IO LeafletMap
leafletMap e = do
  lm <- leafletMap_ $ unElement $ toElement e
  return $ LeafletMap lm

leafletMapSetView :: LeafletMap -> (Double, Double) -> Int -> IO ()
leafletMapSetView lm (lat, lng) zoom =
  leafletMapSetView_ (unLeafletMap lm) lat lng zoom

leafletTileLayer :: String -> Int -> String -> IO LeafletTileLayer
leafletTileLayer src maxZoom attribution = do
  ltl <- leafletTileLayer_ (toJSString src) maxZoom (toJSString attribution)
  return $ LeafletTileLayer ltl

leafletTileLayerAddToMap :: LeafletTileLayer -> LeafletMap -> IO ()
leafletTileLayerAddToMap ltl lm = leafletTileLayerAddToMap_ (unLeafletTileLayer ltl) (unLeafletMap lm)

main :: IO ()
main = mainWidget bodyTag

bodyTag = do
  (e, _) <- elAttr' "div" ("style" =: "height: 300px;") $ return ()
  lm <- liftIO $ do
    lm <- leafletMap $ _el_element e
    leafletMapSetView lm (40.769, -73.9655) 13
    ltl <- leafletTileLayer "http://{s}.tile.openstreetmap.org/{z}/{x}/{y}.png" 19 "&copy; <a href='http://www.openstreetmap.org/copyright'>OpenStreetMap</a>"
    leafletTileLayerAddToMap ltl lm
    return lm
  -- The call to invalidateSize below works around the issue described in this post:
  -- http://stackoverflow.com/questions/17863904/leaflet-mapbox-rendering-issue-grey-area
  postBuild <- getPostBuild
  performEvent_ $ fmap (\_ -> liftIO $ leafletMapInvalidateSize_ $ unLeafletMap lm) postBuild
  return ()