From a4eeb3d9d55935f89a8e9d7920efc0066a7f3dd9 Mon Sep 17 00:00:00 2001 From: sternenseemann <0rpkxez4ksa01gb3typccl0i@systemli.org> Date: Mon, 31 Aug 2020 20:56:11 +0200 Subject: feat(tools/emoji-poster): generate a A0 poster from emoji-test.txt TODO: * Fix strange svg issues with noto * Support noto's flags * Decide emoji size dynamically based on available space and number of emojis to place on the canvas * Investigate alternatives to svg wrangling, maybe based on actual font rendering? --- emoji-generic.cabal | 14 ++++ emoji-generic.nix | 12 +++- tools/Poster.hs | 203 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 227 insertions(+), 2 deletions(-) create mode 100644 tools/Poster.hs diff --git a/emoji-generic.cabal b/emoji-generic.cabal index 4f2c976..a9b8c96 100644 --- a/emoji-generic.cabal +++ b/emoji-generic.cabal @@ -45,3 +45,17 @@ test-suite test , attoparsec ^>=0.13.2.0 , text ^>=1.2.4.0 default-language: Haskell2010 + +executable emoji-poster + main-is: Poster.hs + hs-source-dirs: tools + build-depends: base >=4.13 && <4.14 + , emoji-generic + , conduit^>=1.3.2 + , xml-conduit^>=1.9.0 + , xml-types^>=0.3.8 + , text^>=1.2.4 + , attoparsec^>=0.13.2 + , filepath^>=1.4.2 + , directory^>=1.3.6 + , optparse-applicative^>=0.15.0 diff --git a/emoji-generic.nix b/emoji-generic.nix index 4bedfc7..41a8b06 100644 --- a/emoji-generic.nix +++ b/emoji-generic.nix @@ -1,13 +1,21 @@ -{ mkDerivation, attoparsec, base, file-embed, smallcheck, stdenv -, tasty, tasty-hunit, tasty-smallcheck, text, utf8-light +{ mkDerivation, attoparsec, base, conduit, directory, file-embed +, filepath, optparse-applicative, smallcheck, stdenv, tasty +, tasty-hunit, tasty-smallcheck, text, utf8-light, xml-conduit +, xml-types }: mkDerivation { pname = "emoji-generic"; version = "0.2.0.0"; src = ./.; + isLibrary = true; + isExecutable = true; libraryHaskellDepends = [ attoparsec base file-embed text utf8-light ]; + executableHaskellDepends = [ + attoparsec base conduit directory filepath optparse-applicative + text xml-conduit xml-types + ]; testHaskellDepends = [ attoparsec base smallcheck tasty tasty-hunit tasty-smallcheck text ]; diff --git a/tools/Poster.hs b/tools/Poster.hs new file mode 100644 index 0000000..069d90a --- /dev/null +++ b/tools/Poster.hs @@ -0,0 +1,203 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main where +import Text.Emoji.Types +import Text.Emoji.DataFiles.EmojiTest + +import Control.Applicative ((<|>)) +import Control.Exception +import Control.Monad (join) +import Data.Attoparsec.Text (parse, feed, IResult (..)) +import Data.Maybe (fromJust) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.IO as T +import Data.Ratio +import Data.Word +import Numeric (showHex, fromRat, showFFloat) + +import Conduit + +import qualified Data.XML.Types as XT +import qualified Text.XML.Stream.Parse as XML +import qualified Text.XML.Stream.Render as XML + +import qualified Options.Applicative as O + +import System.Environment +import System.Exit +import System.Directory (doesFileExist) +import System.FilePath (()) +import System.IO + +flattenFilter :: EmojiTestEntry -> [EmojiTestEntry] +flattenFilter x@(Entry _ _ _ _) = [x] +flattenFilter (Group _ _ gs) = concatMap flattenFilter gs +flattenFilter (Comment _) = [] + +data PosterException + = ParseError String + deriving Show + +instance Exception PosterException where + displayException (ParseError e) = "Parse Error: " ++ e + +parseEmojiTest :: MonadThrow m => ConduitT T.Text EmojiTestEntry m () +parseEmojiTest = do + parseResult <- (flip feed) T.empty <$> -- send end of input + foldlC updateParser (Partial (parse emojiTestFile)) + case parseResult of + Partial _ -> throwM $ ParseError "Not enough input" + Fail _ _ m -> throwM $ ParseError m + Done _ r -> yieldMany r + where updateParser r t = + case r of + Partial _ -> feed r t + _ -> r + +svgPath :: Config -> EmojiTestEntry -> FilePath +svgPath cfg (Entry codes _ _ _) = cfgSvgPath cfg filename + where filename = prefix ++ codes_string ++ ".svg" + (prefix, con) = case cfgFontType cfg of + Twemoji -> ("", '-') + Noto -> ("emoji_u", '_') + codes_string = tail . foldr (\f acc -> con:(f acc)) "" $ + map showHex codes +svgPath _ _ = error "svgPath should receive only entries" + +badElement :: XT.Name -> Bool +badElement n = XT.nameLocalName n == "image" + +filterXMLEvent :: XT.Event -> Bool +filterXMLEvent ev = + case ev of + XT.EventBeginDocument -> False + XT.EventEndDocument -> False + XT.EventBeginDoctype _ _ -> False + XT.EventEndDoctype -> False + XT.EventInstruction _ -> False + XT.EventComment _ -> False + -- no image inclusions (only 4 times in noto or something) + XT.EventBeginElement n _ -> not (badElement n) + XT.EventEndElement n -> not (badElement n) + _ -> True + +data SVGState + = SVGState + { svgEmojiWidth :: Rational -- ^ width in cm + , svgEmojiHeight :: Rational -- ^ height in cm + , svgXEmojiCount :: Integer + , svgXIndex :: Integer + , svgYIndex :: Integer + } + +advance :: SVGState -> SVGState +advance st = + if svgXEmojiCount st == svgXIndex st + 1 + then st { svgXIndex = 0 + , svgYIndex = svgYIndex st + 1 } + else st { svgXIndex = svgXIndex st + 1 } + + +type XMLAttrs = [(XT.Name, [XT.Content])] +setAttribute :: XT.Name -> XT.Content -> XMLAttrs -> XMLAttrs +setAttribute n c [] = [(n, [c])] +setAttribute n c ((name,content):xs) = + if name == n + then (n, [c]) : xs + else (name, content) : setAttribute n c xs + +ratC :: Rational -> XT.Content +ratC r = XT.ContentText . + (<> "cm") . T.pack $ (showFFloat (Just 2) . fromRat) r "" + +svgPosition :: SVGState -> XT.Event -> XT.Event +svgPosition st ev = + case ev of + XT.EventBeginElement n attrs -> + let w = svgEmojiWidth st + h = svgEmojiHeight st + x = w * fromIntegral (svgXIndex st) + y = h * fromIntegral (svgYIndex st) + in if XT.nameLocalName n == "svg" + then XT.EventBeginElement n + $ setAttribute "width" (ratC w) + . setAttribute "height" (ratC h) + . setAttribute "x" (ratC x) + . setAttribute "y" (ratC y) + $ attrs + else ev + _ -> ev + +concatXMLEvs :: Monad m => Config -> ConduitT [XT.Event] XT.Event m () +concatXMLEvs cfg = + let a0Width = 841 % 10 + a0Height = 1189 % 10 + emojiPerRow = cfgEmojiPerRow cfg + emojiSide = a0Width / fromIntegral emojiPerRow + initialState = SVGState + { svgEmojiWidth = emojiSide + , svgEmojiHeight = emojiSide + , svgXEmojiCount = emojiPerRow + , svgXIndex = 0 + , svgYIndex = 0 + } + addSVG :: [XT.Event] -> SVGState -> (SVGState, [XT.Event]) + addSVG els st = (advance st, map (svgPosition st) els) + in do + yield XT.EventBeginDocument + yield $ XT.EventBeginElement "{http://www.w3.org/2000/svg}svg" + [ ("width", [ ratC a0Width ]) + , ("height", [ ratC a0Height ]) ] + concatMapAccumC addSVG initialState + yield $ XT.EventEndElement "{http://www.w3.org/2000/svg}svg" + yield XT.EventEndDocument + +buildSVG :: Config -> IO () +buildSVG cfg = withSourceFile (cfgEmojiTest cfg) $ \source -> do + runConduit + $ source + .| decodeUtf8C + .| parseEmojiTest + .| concatMapC flattenFilter + .| mapC (svgPath cfg) + .| filterMC doesFileExist + .| mapMC (\f -> withSourceFile f $ \xml -> runConduit $ xml + .| XML.detectUtf + .| XML.parseText XML.def + .| filterC filterXMLEvent + .| sinkList) + .| concatXMLEvs cfg + .| XML.renderBytes XML.def + .| stdoutC + +data FontType = Twemoji | Noto + +data Config + = Config + { cfgSvgPath :: FilePath + , cfgEmojiTest :: FilePath + , cfgEmojiPerRow :: Integer + , cfgFontType :: FontType + } + +config :: O.Parser Config +config = Config + <$> O.strOption + (O.long "svg-path" + <> O.metavar "PATH" + <> O.help "Directory containing the font's svgs") + <*> O.strOption + (O.long "emoji-test" + <> O.metavar "PATH" + <> O.help "Path to emoji-test.txt") + <*> O.option O.auto + (O.long "per-row" + <> O.metavar "INT" + <> O.value 100 + <> O.help "how many emojis per row") + <*> (O.flag' Twemoji (O.long "twemoji" <> O.help "SVGs are from twemoji") <|> + O.flag' Noto (O.long "noto" <> O.help "SVGs are from noto-emoji")) + +main :: IO () +main = O.execParser opts >>= buildSVG + where opts = O.info config O.fullDesc -- cgit 1.4.1