{-# LANGUAGE QuasiQuotes #-}
module DarkModeSVG
( writeDarkModeSVG
) where

import qualified Waterfall.SVG
import qualified Waterfall
import qualified Graphics.Svg as Svg
import qualified Text.XML.Light.Types as XML
import qualified Text.XML.Light.Proc as XML.Proc
import qualified Text.XML.Light.Cursor as XML.Cursor
import qualified Text.XML.Light.Output as XML.Output
import Text.RawString.QQ
import Data.Function ((&))
import Data.Foldable (toList)
import Data.Maybe (listToMaybe, fromMaybe)
import Control.Monad (join)
styles :: String
styles :: String
styles = String
[r|
.edge {
  fill: None;
}
.edge.visible {
  stroke: #000000;
}
.edge.hidden {
  stroke: #C8C8FF;
}
@media (prefers-color-scheme: dark) {
    .edge.visible {
      stroke: #FFFFFF;
    }
    .edge.hidden {
      stroke: #A00000;
    }
}
|]

writeDarkModeSVG :: FilePath -> Waterfall.Diagram -> IO ()
writeDarkModeSVG :: String -> Diagram -> IO ()
writeDarkModeSVG String
path Diagram
diagram =
    let svgAsXML :: Element
svgAsXML = 
            Diagram
diagram 
                Diagram -> (Diagram -> Document) -> Document
forall a b. a -> (a -> b) -> b
& Diagram -> Document
Waterfall.SVG.diagramToSvg
                Document -> (Document -> Element) -> Element
forall a b. a -> (a -> b) -> b
& Document -> Element
Svg.xmlOfDocument
        nameIsStyle :: Content -> Bool
nameIsStyle (XML.Elem Element
e) = (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"style") (String -> Bool) -> (Element -> String) -> Element -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> String
XML.qName (QName -> String) -> (Element -> QName) -> Element -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> QName
XML.elName (Element -> Bool) -> Element -> Bool
forall a b. (a -> b) -> a -> b
$ Element
e
        nameIsStyle Content
_ = Bool
False
    in Element
svgAsXML 
            Element -> (Element -> Cursor) -> Cursor
forall a b. a -> (a -> b) -> b
& Element -> Cursor
XML.Cursor.fromElement
            Cursor -> (Cursor -> Maybe Cursor) -> Maybe Cursor
forall a b. a -> (a -> b) -> b
& (Cursor -> Bool) -> Cursor -> Maybe Cursor
XML.Cursor.findChild (Content -> Bool
nameIsStyle (Content -> Bool) -> (Cursor -> Content) -> Cursor -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cursor -> Content
XML.Cursor.current)
            Maybe Cursor
-> (Maybe Cursor -> Maybe (Maybe Cursor)) -> Maybe (Maybe Cursor)
forall a b. a -> (a -> b) -> b
& (Cursor -> Maybe Cursor) -> Maybe Cursor -> Maybe (Maybe Cursor)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Cursor -> Maybe Cursor
XML.Cursor.firstChild 
            Maybe (Maybe Cursor)
-> (Maybe (Maybe Cursor) -> Maybe Cursor) -> Maybe Cursor
forall a b. a -> (a -> b) -> b
& Maybe (Maybe Cursor) -> Maybe Cursor
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join
            Maybe Cursor -> (Maybe Cursor -> Maybe Cursor) -> Maybe Cursor
forall a b. a -> (a -> b) -> b
& (Cursor -> Cursor) -> Maybe Cursor -> Maybe Cursor
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Content -> Cursor -> Cursor
XML.Cursor.setContent (CData -> Content
XML.Text (CDataKind -> String -> Maybe Line -> CData
XML.CData CDataKind
XML.CDataText String
styles Maybe Line
forall a. Maybe a
Nothing)))
            Maybe Cursor -> (Maybe Cursor -> Maybe Cursor) -> Maybe Cursor
forall a b. a -> (a -> b) -> b
& (Cursor -> Cursor) -> Maybe Cursor -> Maybe Cursor
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Cursor -> Cursor
XML.Cursor.root)
            Maybe Cursor -> (Maybe Cursor -> Maybe Content) -> Maybe Content
forall a b. a -> (a -> b) -> b
& (Cursor -> Content) -> Maybe Cursor -> Maybe Content
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Cursor -> Content
XML.Cursor.current
            Maybe Content -> (Maybe Content -> [Content]) -> [Content]
forall a b. a -> (a -> b) -> b
& Maybe Content -> [Content]
forall a. Maybe a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
            [Content] -> ([Content] -> [Element]) -> [Element]
forall a b. a -> (a -> b) -> b
& [Content] -> [Element]
XML.Proc.onlyElems
            [Element] -> ([Element] -> Maybe Element) -> Maybe Element
forall a b. a -> (a -> b) -> b
& [Element] -> Maybe Element
forall a. [a] -> Maybe a
listToMaybe
            Maybe Element -> (Maybe Element -> Element) -> Element
forall a b. a -> (a -> b) -> b
& Element -> Maybe Element -> Element
forall a. a -> Maybe a -> a
fromMaybe Element
svgAsXML
            Element -> (Element -> String) -> String
forall a b. a -> (a -> b) -> b
& Element -> String
XML.Output.ppTopElement
            String -> (String -> IO ()) -> IO ()
forall a b. a -> (a -> b) -> b
& String -> String -> IO ()
writeFile String
path