svgsym-0.1.2.0: src-exe/Main.hs

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

module Main (main) where

import Control.Monad (forM, when)
import Data.Array ((!))
import qualified Data.Array as Arr
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), Regex, RegexContext (match), RegexLike (matchAll, matchAllText), makeRegexM, (=~), (=~~))
import Text.Regex.TDFA.Common (Regex (regex_groups))
import Text.XML.Light (Attr (Attr), Element (Element, elContent, elName), QName (..), parseXMLDoc, ppTopElement, showElement)
import qualified Text.XML.Light as Xml

type Re = String

newtype Errorable a = Errorable (Either String a)
  deriving (Functor, Applicative, Monad)

instance MonadFail Errorable where
  fail = Errorable . Left

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 :: Regex -> String -> Set String
findSymbols regex = Set.fromList . concatMap go . lines
  where
    go :: String -> [String]
    go "" = []
    go s = map (fst . (! 1)) $ matchAllText regex s

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

findFileSymbols :: Regex -> [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

  symbolRegex <- case makeRegexM symbolPat of
    Errorable (Left err) -> do
      hPutStrLn stderr "Errorable parsing symbol regular expression:"
      hPutStrLn stderr err
      exitFailure
    Errorable (Right re) -> do
      let (_, n) = Arr.bounds $ regex_groups re
      when (n /= 1) do
        hPutStrLn stderr "Expect exactly one capture group in symbol regular expression."
        exitFailure
      pure re

  files <- findFiles contentPats

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

  symbols <- findFileSymbols symbolRegex files

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

  filterSvgFile svgFile symbols prettyPrint