Main.hs

{-# LANGUAGE FlexibleContexts          #-}
{-# LANGUAGE FlexibleInstances         #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE OverloadedStrings         #-}
{-# LANGUAGE ScopedTypeVariables       #-}
{-# LANGUAGE TypeFamilies              #-}
{-# LANGUAGE UnicodeSyntax             #-}

module Entrypoint
       ( runMain
       ) where

import           Diagrams.Prelude
import           GHCJS.DOM          (runWebGUI, webViewGetDomDocument)
import           GHCJS.DOM.Document (createElement, getBody)
import           GHCJS.DOM.Element  (setAttribute)
import           GHCJS.DOM.Node     (appendChild)

diagram :: Diagram SVG
diagram = undefined

main = runMain \w h domEl -> domEl `setInnerHTML` Just (renderSVGToString diagram)

runMain program = runWebGUI $ \webView -> do
  Just doc <- webViewGetDomDocument webView
  Just body <- getBody doc

  Just divEl <- doc `createElement` Just ("div"::String)
  body `appendChild` Just divEl
  divEl `setAttribute` ("style"::String) $ ("border: 1px solid gray; width: 880px; height 580px"::String)

  program 880 580 divEl

SVG.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE UnicodeSyntax     #-}

module Rendering.SVG
       ( renderSVGToString
       ) where

import           Data.List             (isPrefixOf, stripPrefix)
import qualified Data.Text.Lazy        as T
import           Diagrams.Backend.SVG  as SVG
import           Diagrams.Prelude
import           Diagrams.TwoD.Size    (mkSizeSpec2D)
import           Lucid.Base            (renderText)

renderSVGToString ∷ Double → Double → Diagram SVG → String
renderSVGToString w h d = ret
  where size = mkSizeSpec2D (Just w) (Just h)
        Just ret = stripUntil "<svg " . T.unpack . renderText $ d'
        d' = renderDia SVG (SVG.SVGOptions size Nothing "") d

stripSvgWrap ∷ String → Maybe String
stripSvgWrap svgHtml = (reverse <$>) . stripPrefix (reverse "</svg>") . reverse =<< drop 1 <$> stripUntil "><" svgHtml

stripUntil ∷ Eq a ⇒ [a] → [a] → Maybe [a]
stripUntil _      []                                  = Nothing
stripUntil needle xs@(_:xs') | needle `isPrefixOf` xs = Just xs
                             | otherwise              = stripUntil needle xs'