{-# LANGUAGE OverloadedStrings #-}
module DarkModeSVG
( darkModeSVG
, writeDarkModeSVG
) where

import qualified Waterfall.SVG
import qualified Waterfall
import qualified Graphics.Svg as Svg
import qualified Graphics.Svg.CssTypes as Svg.Css
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 Data.Function ((&))
import Data.Foldable (toList)
import Data.Maybe (listToMaybe, fromMaybe)
import Control.Monad (join)
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TextBuilder

combineStyles :: [Svg.Css.CssRule] -> [Svg.Css.CssRule] -> String
combineStyles :: [CssRule] -> [CssRule] -> String
combineStyles [CssRule]
lightModeRules [CssRule]
darkModeRules = Text -> String
TL.unpack (Text -> String) -> (Builder -> Text) -> Builder -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Text
TextBuilder.toLazyText (Builder -> String) -> Builder -> String
forall a b. (a -> b) -> a -> b
$
  ( (CssRule -> Builder) -> [CssRule] -> Builder
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap CssRule -> Builder
forall a. TextBuildable a => a -> Builder
Svg.Css.tserialize [CssRule]
lightModeRules 
    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"\n @media (prefers-color-scheme: dark) {\n"
    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (CssRule -> Builder) -> [CssRule] -> Builder
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap CssRule -> Builder
forall a. TextBuildable a => a -> Builder
Svg.Css.tserialize [CssRule]
darkModeRules
    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"\n}"
  )
darkModeSVG :: Waterfall.Diagram -> XML.Element
darkModeSVG :: Diagram -> Element
darkModeSVG 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
        hasColour :: Bool
hasColour = Bool -> Bool
not (Bool -> Bool) -> (Diagram -> Bool) -> Diagram -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Paint, Shape)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([(Paint, Shape)] -> Bool)
-> (Diagram -> [(Paint, Shape)]) -> Diagram -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Diagram -> [(Paint, Shape)]
Waterfall.getDiagramFills (Diagram -> Bool) -> Diagram -> Bool
forall a b. (a -> b) -> a -> b
$ Diagram
diagram

        lightModeStyle :: DiagramStyle
lightModeStyle =
          LineStyle -> DiagramStyle
Waterfall.SVG.diagramWithVisibleLine 
            ( Colour -> LineStyle
Waterfall.SVG.lineWithColour Colour
Waterfall.black
            ) 
          DiagramStyle -> DiagramStyle -> DiagramStyle
forall a. Semigroup a => a -> a -> a
<> LineStyle -> DiagramStyle
Waterfall.SVG.diagramWithHiddenLine 
            ( Colour -> LineStyle
Waterfall.SVG.lineWithColour 
              ( if Bool
hasColour
                  then Colour
Waterfall.black
                  else Word32 -> Colour
Waterfall.rgb24 Word32
0xC8C8FF
              )
              LineStyle -> LineStyle -> LineStyle
forall a. Semigroup a => a -> a -> a
<> Double -> LineStyle
Waterfall.SVG.lineWithOpacity
                ( if Bool
hasColour 
                    then Double
0.2
                    else Double
1
                )
            )
        darkModeStyle :: DiagramStyle
darkModeStyle = 
          LineStyle -> DiagramStyle
Waterfall.SVG.diagramWithVisibleLine 
            ( Colour -> LineStyle
Waterfall.SVG.lineWithColour Colour
Waterfall.white
            ) 
          DiagramStyle -> DiagramStyle -> DiagramStyle
forall a. Semigroup a => a -> a -> a
<> LineStyle -> DiagramStyle
Waterfall.SVG.diagramWithHiddenLine 
            ( Colour -> LineStyle
Waterfall.SVG.lineWithColour 
              ( if Bool
hasColour
                  then Colour
Waterfall.white
                  else Word32 -> Colour
Waterfall.rgb24 Word32
0xA00000
              )
              LineStyle -> LineStyle -> LineStyle
forall a. Semigroup a => a -> a -> a
<> Double -> LineStyle
Waterfall.SVG.lineWithOpacity
                ( if Bool
hasColour 
                    then Double
0.2
                    else Double
1
                )
            )
        styles :: String
styles = [CssRule] -> [CssRule] -> String
combineStyles (DiagramStyle -> [CssRule]
Waterfall.SVG.lineStyleCss DiagramStyle
lightModeStyle) (DiagramStyle -> [CssRule]
Waterfall.SVG.lineStyleCss DiagramStyle
darkModeStyle)
    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

writeDarkModeSVG :: FilePath -> Waterfall.Diagram -> IO ()
writeDarkModeSVG :: String -> Diagram -> IO ()
writeDarkModeSVG String
path Diagram
diagram =
  Diagram
diagram 
    Diagram -> (Diagram -> Element) -> Element
forall a b. a -> (a -> b) -> b
& Diagram -> Element
darkModeSVG
    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