svgsym-0.1.0.0: src-exe/Main.hs

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Main where

import Control.Monad (forM, when)
import qualified Data.ByteString.Lazy as LB
import Data.Foldable (Foldable (fold), find, for_)
import Data.List (isPrefixOf)
import Data.Maybe (isJust, mapMaybe)
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Version (showVersion)
import Options.Applicative (execParser)
import qualified Svgsym.Options as Opts
import System.Directory (findFile, getCurrentDirectory, makeAbsolute)
import System.Exit (exitFailure)
import qualified System.Exit as System
import System.FilePath ((</>))
import System.FilePattern.Directory (FilePattern, getDirectoryFiles)
import System.IO (hPutStrLn, stderr)
import Text.Regex.TDFA (AllTextMatches (getAllTextMatches), (=~))
import Text.XML.Light (Attr (Attr), Element (Element, elContent, elName), QName (..), parseXMLDoc, ppTopElement, showElement)
import qualified Text.XML.Light as Xml

qnSvg :: QName
qnSvg = QName {qName = "svg", qURI = Just "http://www.w3.org/2000/svg", qPrefix = Nothing}

qnSymbol :: QName
qnSymbol = QName {qName = "symbol", qURI = Just "http://www.w3.org/2000/svg", qPrefix = Nothing}

qnId :: QName
qnId = QName {qName = "id", qURI = Nothing, qPrefix = Nothing}

-- | Filters the root SVG element such that only symbols in the given set
-- remain.
filterDoc :: Set String -> Element -> Element
filterDoc symbols doc =
  doc
    { elContent =
        let isUsed = isJust . find (\(Attr k v) -> k == qnId && Set.member v symbols)
            f = \case
              Xml.Text _ -> Nothing
              Xml.CRef _ -> Nothing
              Xml.Elem e@(Element qName attrs symbol _)
                | qName == qnSymbol ->
                  if isUsed attrs
                    then Just $ Xml.Elem e
                    else Nothing
                | otherwise -> Nothing
         in mapMaybe f (elContent doc)
    }

-- | Find all symbols using the given pattern
findSymbols :: String -> String -> Set String
findSymbols pat haystack = Set.fromList $ go haystack
  where
    go "" = []
    go s =
      let (_, _, rest, match) = s =~ pat :: (String, String, String, [String])
       in match <> go rest

findFiles :: [FilePattern] -> IO [FilePath]
findFiles patterns = do
  curDir <- getCurrentDirectory
  let makeAbsolute s
        | "/" `isPrefixOf` s = s
        | otherwise = curDir </> s
      absPats = makeAbsolute <$> patterns
  getDirectoryFiles "/" absPats

findFileSymbols :: String -> [FilePath] -> IO (Set String)
findFileSymbols regex files = do
  fmap fold . forM files $ \f -> do
    s <- readFile f
    pure $ findSymbols regex s

filterSvgFile :: FilePath -> Set String -> Bool -> IO ()
filterSvgFile svgPath symbols prettyPrint = do
  input <- LB.readFile svgPath
  case parseXMLDoc input of
    Nothing -> do
      hPutStrLn stderr "Failed to read SVG file"
      exitFailure
    Just doc
      | elName doc == qnSvg -> do
        let doc' = filterDoc symbols doc
        putStrLn $
          if prettyPrint
            then ppTopElement doc'
            else showElement doc'
      | otherwise -> do
        hPutStrLn stderr "The XML file is not an SVG document"
        exitFailure

main :: IO ()
main = do
  Opts.Options {..} <- execParser Opts.parser
  files <- findFiles contentPats

  when debug do
    hPutStrLn stderr "Matched content files:"
    for_ files \f -> hPutStrLn stderr ("  " <> f)

  symbols <- findFileSymbols symbolPat files

  when debug do
    hPutStrLn stderr "Matched symbols:"
    for_ symbols \s -> hPutStrLn stderr ("  " <> s)

  filterSvgFile svgFile symbols prettyPrint