feat(tools/emoji-poster): generate a A0 poster from emoji-test.txt emoji-poster

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?

3 files changed, 227 insertions, 2 deletions

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