-- | Module providing basic input/output for the SVG document,
-- for document building, please refer to Graphics.Svg.Types.
module Graphics.SvgTree
  ( -- * Saving/Loading functions
    loadSvgFile,
    parseSvgFile,
    parseSvg,
    unparse,
    xmlOfDocument,
    xmlOfTree,
    saveXmlFile,

    -- * Manipulation functions
    cssApply,
    cssRulesOfText,
    -- , applyCSSRules
    -- , resolveUses

    -- * Type definitions
    module Graphics.SvgTree.Types,
  )
where

import Control.Lens
import Data.List (foldl')
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Graphics.SvgTree.CssParser (cssRulesOfText)
import Graphics.SvgTree.CssTypes
import Graphics.SvgTree.Types
import Graphics.SvgTree.XmlParser
import Text.XML.Light.Input (parseXMLDoc)
import Text.XML.Light.Output (ppcTopElement, prettyConfigPP)

-- | Try to load an svg file on disc and parse it as
-- a SVG Document.
loadSvgFile :: FilePath -> IO (Maybe Document)
loadSvgFile :: FilePath -> IO (Maybe Document)
loadSvgFile FilePath
filename =
  FilePath -> Text -> Maybe Document
parseSvgFile FilePath
filename (Text -> Maybe Document) -> IO Text -> IO (Maybe Document)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO Text
T.readFile FilePath
filename

-- | Parse an in-memory SVG file
parseSvgFile ::
  -- | Source path/URL of the document, used
  -- to resolve relative links.
  FilePath ->
  T.Text ->
  Maybe Document
parseSvgFile :: FilePath -> Text -> Maybe Document
parseSvgFile FilePath
filename Text
fileContent =
  Text -> Maybe Element
forall s. XmlSource s => s -> Maybe Element
parseXMLDoc Text
fileContent Maybe Element -> (Element -> Maybe Document) -> Maybe Document
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FilePath -> Element -> Maybe Document
unparseDocument FilePath
filename

parseSvg :: T.Text -> Tree
parseSvg :: Text -> Tree
parseSvg Text
inp =
  case Text -> Maybe Element
forall s. XmlSource s => s -> Maybe Element
parseXMLDoc Text
inp of
    Maybe Element
Nothing -> FilePath -> Tree
forall a. HasCallStack => FilePath -> a
error FilePath
"Invalid XML"
    Just Element
xml -> Element -> Tree
unparse Element
xml

-- | Save a svg Document to a file on disk.
saveXmlFile :: FilePath -> Document -> IO ()
saveXmlFile :: FilePath -> Document -> IO ()
saveXmlFile FilePath
filePath =
  FilePath -> FilePath -> IO ()
writeFile FilePath
filePath (FilePath -> IO ()) -> (Document -> FilePath) -> Document -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConfigPP -> Element -> FilePath
ppcTopElement ConfigPP
prettyConfigPP (Element -> FilePath)
-> (Document -> Element) -> Document -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Document -> Element
xmlOfDocument

cssDeclApplyer ::
  DrawAttributes ->
  CssDeclaration ->
  DrawAttributes
cssDeclApplyer :: DrawAttributes -> CssDeclaration -> DrawAttributes
cssDeclApplyer DrawAttributes
value (CssDeclaration Text
txt [[CssElement]]
elems) =
  case Text
-> [(Text, CssUpdater DrawAttributes)]
-> Maybe (CssUpdater DrawAttributes)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
txt [(Text, CssUpdater DrawAttributes)]
cssUpdaters of
    Maybe (CssUpdater DrawAttributes)
Nothing -> DrawAttributes
value
    Just CssUpdater DrawAttributes
f -> CssUpdater DrawAttributes
f DrawAttributes
value [[CssElement]]
elems
  where
    cssUpdaters :: [(Text, CssUpdater DrawAttributes)]
cssUpdaters =
      [ (FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ SvgAttributeLens DrawAttributes -> FilePath
forall t. SvgAttributeLens t -> FilePath
_attributeName SvgAttributeLens DrawAttributes
n, CssUpdater DrawAttributes
u)
        | (SvgAttributeLens DrawAttributes
n, CssUpdater DrawAttributes
u) <- [(SvgAttributeLens DrawAttributes, CssUpdater DrawAttributes)]
drawAttributesList
      ]

-- | Rewrite a SVG Tree using some CSS rules.
--
-- This action will propagate the definition of the
-- css directly in each matched element.
cssApply :: [CssRule] -> Tree -> Tree
cssApply :: [CssRule] -> Tree -> Tree
cssApply [CssRule]
rules = ([[Tree]] -> Tree) -> Tree -> Tree
zipTree [[Tree]] -> Tree
forall p.
(WithDefaultSvg p, HasDrawAttributes p, CssMatcheable p) =>
[[p]] -> p
go
  where
    go :: [[p]] -> p
go [] = p
forall a. WithDefaultSvg a => a
defaultSvg
    go ([] : [[p]]
_) = p
forall a. WithDefaultSvg a => a
defaultSvg
    go context :: [[p]]
context@((p
t : [p]
_) : [[p]]
_) = p
t p -> (p -> p) -> p
forall a b. a -> (a -> b) -> b
& (DrawAttributes -> Identity DrawAttributes) -> p -> Identity p
forall c. HasDrawAttributes c => Lens' c DrawAttributes
drawAttributes ((DrawAttributes -> Identity DrawAttributes) -> p -> Identity p)
-> DrawAttributes -> p -> p
forall s t a b. ASetter s t a b -> b -> s -> t
.~ DrawAttributes
attr'
      where
        matchingDeclarations :: [CssDeclaration]
matchingDeclarations =
          [CssRule] -> [[p]] -> [CssDeclaration]
forall a.
CssMatcheable a =>
[CssRule] -> CssContext a -> [CssDeclaration]
findMatchingDeclarations [CssRule]
rules [[p]]
context
        attr :: DrawAttributes
attr = Getting DrawAttributes p DrawAttributes -> p -> DrawAttributes
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting DrawAttributes p DrawAttributes
forall c. HasDrawAttributes c => Lens' c DrawAttributes
drawAttributes p
t
        attr' :: DrawAttributes
attr' = (DrawAttributes -> CssDeclaration -> DrawAttributes)
-> DrawAttributes -> [CssDeclaration] -> DrawAttributes
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' DrawAttributes -> CssDeclaration -> DrawAttributes
cssDeclApplyer DrawAttributes
attr [CssDeclaration]
matchingDeclarations

-- For every 'use' tag, try to resolve the geometry associated
-- with it and place it in the scene Tree. It is important to
-- resolve the 'use' tag before applying the CSS rules, as some
-- rules may apply some elements matching the children of "use".
-- resolveUses :: Document -> Document
-- resolveUses doc =
--   doc { _elements = mapTree fetchUses <$> _elements doc }
--   where
--     fetchUses (UseTree useInfo _) = UseTree useInfo $ search useInfo
--     fetchUses a                   = a
--
--     search nfo = M.lookup (_useName nfo) $ _definitions doc

-- -- | Rewrite the document by applying the CSS rules embedded
-- -- inside it.
-- applyCSSRules :: Document -> Document
-- applyCSSRules doc = doc
--     { _elements = cssApply (_styleRules doc) <$> _elements doc }