reanimate-svg 0.8.2.0 → 0.9.0.0

raw patch · 7 files changed

+215/−52 lines, 7 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• changelog.md +5/−0
• reanimate-svg.cabal +3/−1
• src/Graphics/SvgTree/Memo.hs +83/−0
• src/Graphics/SvgTree/PathParser.hs +58/−45
• src/Graphics/SvgTree/Printer.hs +50/−0
• src/Graphics/SvgTree/Types.hs +13/−3
• src/Graphics/SvgTree/XmlParser.hs +3/−3

@@ -1,5 +1,10 @@ -*-change-log-*- +v0.9.0.0 April 2019++ * Performance optimizations.+ * Memo module and render cache.+ v0.8.2.0 March 2019   * Export parser and serializer.

@@ -1,5 +1,5 @@ name:                reanimate-svg-version:             0.8.2.0+version:             0.9.0.0 synopsis:            SVG file loader and serializer description:   reanimate-svg provides types representing a SVG document,@@ -34,6 +34,8 @@                  , Graphics.SvgTree.Types                  , Graphics.SvgTree.PathParser                  , Graphics.SvgTree.NamedColors+                 , Graphics.SvgTree.Memo+                 , Graphics.SvgTree.Printer    other-modules: Graphics.SvgTree.XmlParser                , Graphics.SvgTree.CssParser

@@ -0,0 +1,83 @@+module Graphics.SvgTree.Memo+  ( memo+  , preRender+  ) where++import           Control.Lens+import           Data.IORef+import           Data.Map                 (Map)+import qualified Data.Map                 as Map+import           Data.Maybe+import           Data.Typeable+import           Graphics.SvgTree.Printer+import           Graphics.SvgTree.Types   (Tree, preRendered)+import           System.IO.Unsafe++{-# NOINLINE intCache #-}+intCache :: IORef (Map Int Tree)+intCache = unsafePerformIO (newIORef Map.empty)++{-# NOINLINE doubleCache #-}+doubleCache :: IORef (Map Double Tree)+doubleCache = unsafePerformIO (newIORef Map.empty)++{-# NOINLINE anyCache #-}+anyCache :: IORef (Map (TypeRep,String) Tree)+anyCache = unsafePerformIO (newIORef Map.empty)++memo :: (Typeable a, Show a) => (a -> Tree) -> (a -> Tree)+memo fn =+  case listToMaybe (catMaybes caches) of+    Just ret -> ret+    Nothing  -> memoAny fn+  where+    caches = [try intCache, try doubleCache]+    try cache = cast . memoUsing cache =<< cast fn++memoUsing :: Ord a => IORef (Map a Tree) -> (a -> Tree) -> (a -> Tree)+memoUsing cache fn a = unsafePerformIO $+  atomicModifyIORef cache $ \m ->+    let newVal = preRender $ fn a+        notFound =+          (Map.insert a newVal m, newVal) in+    case Map.lookup a m of+      Nothing -> notFound+      Just t  -> (m, t)++memoAny :: (Typeable a, Show a) => (a -> Tree) -> (a -> Tree)+memoAny fn a = unsafePerformIO $+  atomicModifyIORef anyCache $ \m ->+    let newVal = preRender $ fn a+        notFound =+          (Map.insert (typeOf a, show a) newVal m, newVal) in+    case Map.lookup (typeOf a, show a) m of+      Nothing -> notFound+      Just t  -> (m, t)++preRender :: Tree -> Tree+preRender t = t & preRendered .~ Just (ppTree t)++-- {-# INLINE memo #-}+-- memo :: (a -> b) -> (a -> b)+-- memo fn = unsafePerformIO $ do+--   ref <- newIORef Map.empty+--   return $ \a -> unsafePerformIO $ do+--     stableA <- makeStableName a+--     let key = hashStableName stableA+--     atomicModifyIORef ref $ \m ->+--       case Map.lookup key m of+--         -- Just (s,b) | s == stableA ->+--         --   (m, b)+--         _Nothing -> let !b = fn a in+--           (Map.insert key (stableA, b) m, b)+-- memo fn = unsafePerformIO $ do+--   ht <- HT.new :: IO (HT.BasicHashTable (StableName Any) Any)+--   return $ \a -> unsafePerformIO $ do+--     stableA <- makeStableName $ unsafeCoerce a+--     mbB <- HT.lookup ht stableA+--     case mbB of+--       Just b -> return (unsafeCoerce b)+--       Nothing -> do+--         let !b = fn a+--         HT.insert ht stableA (unsafeCoerce b)+--         return b

@@ -25,6 +25,9 @@                                              string) import           Data.Scientific            (toRealFloat) +import Numeric+import Text.Show+import Data.List import qualified Data.Text                  as T import           Graphics.SvgTree.Types import           Linear                     hiding (angle, point)@@ -101,58 +104,68 @@                                    <*> (fmap (/= 0) numComma)                                    <*> point -serializePoint :: RPoint -> String-serializePoint (V2 x y) = printf "%g,%g" x y+unwordsS :: [ShowS] -> ShowS+unwordsS = foldr (.) id . intersperse (showChar ' ') -serializePoints :: [RPoint] -> String-serializePoints = unwords . fmap serializePoint+serializePoint :: RPoint -> ShowS+serializePoint (V2 x y) = showFFloat Nothing x . showChar ',' . showFFloat Nothing y -serializeCoords :: [Coord] -> String-serializeCoords = unwords . fmap (printf "%g")+serializePoints :: [RPoint] -> ShowS+serializePoints = unwordsS . map serializePoint -serializePointPair :: (RPoint, RPoint) -> String-serializePointPair (a, b) = serializePoint a ++ " " ++ serializePoint b+serializeCoords :: [Coord] -> ShowS+serializeCoords = unwordsS . fmap (showFFloat Nothing) -serializePointPairs :: [(RPoint, RPoint)] -> String-serializePointPairs = unwords . fmap serializePointPair+serializePointPair :: (RPoint, RPoint) -> ShowS+serializePointPair (a, b) = serializePoint a . showChar ' ' . serializePoint b -serializePointTriplet :: (RPoint, RPoint, RPoint) -> String+serializePointPairs :: [(RPoint, RPoint)] -> ShowS+serializePointPairs = unwordsS . fmap serializePointPair++serializePointTriplet :: (RPoint, RPoint, RPoint) -> ShowS serializePointTriplet (a, b, c) =-    serializePoint a ++ " " ++ serializePoint b ++ " " ++ serializePoint c+    serializePoint a . showChar ' ' . serializePoint b . showChar ' ' . serializePoint c -serializePointTriplets :: [(RPoint, RPoint, RPoint)] -> String-serializePointTriplets = unwords . fmap serializePointTriplet+serializePointTriplets :: [(RPoint, RPoint, RPoint)] -> ShowS+serializePointTriplets = unwordsS . fmap serializePointTriplet -serializeCommands :: [PathCommand] -> String-serializeCommands = unwords . fmap serializeCommand+serializeCommands :: [PathCommand] -> ShowS+serializeCommands = unwordsS . fmap serializeCommand -serializeCommand :: PathCommand -> String+serializeCommand :: PathCommand -> ShowS serializeCommand p = case p of-  MoveTo OriginAbsolute points -> "M" ++ serializePoints points-  MoveTo OriginRelative points -> "m" ++ serializePoints points-  LineTo OriginAbsolute points -> "L" ++ serializePoints points-  LineTo OriginRelative points -> "l" ++ serializePoints points+  MoveTo OriginAbsolute points -> showChar 'M' . serializePoints points+  MoveTo OriginRelative points -> showChar 'm' . serializePoints points+  LineTo OriginAbsolute points -> showChar 'L' . serializePoints points+  LineTo OriginRelative points -> showChar 'l' . serializePoints points -  HorizontalTo OriginAbsolute coords -> "H" ++ serializeCoords coords-  HorizontalTo OriginRelative coords -> "h" ++ serializeCoords coords-  VerticalTo OriginAbsolute coords -> "V" ++ serializeCoords coords-  VerticalTo OriginRelative coords -> "v" ++ serializeCoords coords+  HorizontalTo OriginRelative coords -> showChar 'h' . serializeCoords coords+  HorizontalTo OriginAbsolute coords -> showChar 'H' . serializeCoords coords+  VerticalTo OriginAbsolute coords   -> showChar 'V' . serializeCoords coords+  VerticalTo OriginRelative coords   -> showChar 'v' . serializeCoords coords -  CurveTo OriginAbsolute triplets -> "C" ++ serializePointTriplets triplets-  CurveTo OriginRelative triplets -> "c" ++ serializePointTriplets triplets-  SmoothCurveTo OriginAbsolute pointPairs -> "S" ++ serializePointPairs pointPairs-  SmoothCurveTo OriginRelative pointPairs -> "s" ++ serializePointPairs pointPairs-  QuadraticBezier OriginAbsolute pointPairs -> "Q" ++ serializePointPairs pointPairs-  QuadraticBezier OriginRelative pointPairs -> "q" ++ serializePointPairs pointPairs-  SmoothQuadraticBezierCurveTo OriginAbsolute points -> "T" ++ serializePoints points-  SmoothQuadraticBezierCurveTo OriginRelative points -> "t" ++ serializePoints points-  EllipticalArc OriginAbsolute args -> "A" ++ serializeArgs args-  EllipticalArc OriginRelative args -> "a" ++ serializeArgs args-  EndPath -> "Z"+  CurveTo OriginAbsolute triplets -> showChar 'C' . serializePointTriplets triplets+  CurveTo OriginRelative triplets -> showChar 'c' . serializePointTriplets triplets+  SmoothCurveTo OriginAbsolute pointPairs -> showChar 'S' . serializePointPairs pointPairs+  SmoothCurveTo OriginRelative pointPairs -> showChar 's' . serializePointPairs pointPairs+  QuadraticBezier OriginAbsolute pointPairs -> showChar 'Q' . serializePointPairs pointPairs+  QuadraticBezier OriginRelative pointPairs -> showChar 'q' . serializePointPairs pointPairs+  SmoothQuadraticBezierCurveTo OriginAbsolute points -> showChar 'T' . serializePoints points+  SmoothQuadraticBezierCurveTo OriginRelative points -> showChar 't' . serializePoints points+  EllipticalArc OriginAbsolute args -> showChar 'A' . serializeArgs args+  EllipticalArc OriginRelative args -> showChar 'a' . serializeArgs args+  EndPath -> showChar 'Z'   where     serializeArg (a, b, c, d, e, V2 x y) =-        printf "%g %g %g %d %d %g,%g" a b c (fromEnum d) (fromEnum e) x y-    serializeArgs = unwords . fmap serializeArg+        showFFloat Nothing a . showChar ' ' .+        showFFloat Nothing b . showChar ' ' .+        showFFloat Nothing c . showChar ' ' .+        shows (fromEnum d) . showChar ' ' .+        shows (fromEnum e) . showChar ' ' .+        showFFloat Nothing x . showChar ',' .+        showFFloat Nothing y+        -- printf "%g %g %g %d %d %g,%g" a b c (fromEnum d) (fromEnum e) x y+    serializeArgs = unwordsS . fmap serializeArg   @@ -242,15 +255,15 @@                  <*> (point <* commaWsp)                  <*> mayPoint -serializeGradientCommand :: GradientPathCommand -> String+serializeGradientCommand :: GradientPathCommand -> ShowS serializeGradientCommand p = case p of-  GLine OriginAbsolute points -> "L" ++ smp points-  GLine OriginRelative points -> "l" ++ smp points-  GClose                      -> "Z"+  GLine OriginAbsolute points -> showChar 'L' . smp points+  GLine OriginRelative points -> showChar 'l' . smp points+  GClose                      -> showChar 'Z' -  GCurve OriginAbsolute a b c -> "C" ++ sp a ++ sp b ++ smp c-  GCurve OriginRelative a b c -> "c" ++ sp a ++ sp b ++ smp c+  GCurve OriginAbsolute a b c -> showChar 'C' . sp a . sp b . smp c+  GCurve OriginRelative a b c -> showChar 'c' . sp a . sp b . smp c   where     sp = serializePoint-    smp Nothing   = ""+    smp Nothing   = id     smp (Just pp) = serializePoint pp

@@ -0,0 +1,50 @@+module Graphics.SvgTree.Printer+  ( ppTree+  , ppDocument+  ) where++import           Control.Lens+import           Data.Char+import           Data.List+import           Graphics.SvgTree.Types     (DrawAttributes, Tree (..),+                                             groupChildren,+                                             preRendered, Document(..))+import           Graphics.SvgTree.XmlParser+import           Text.XML.Light++ppDocument :: Document -> String+ppDocument doc =+  ppElementS_ (_elements doc) (xmlOfDocument doc) ""++ppTree :: Tree -> String+ppTree t = ppTreeS t ""++ppTreeS :: Tree -> ShowS+ppTreeS tree =+  case tree ^. preRendered of+    Nothing ->+      case xmlOfTree tree of+        Just x  -> ppElementS_ (treeChildren tree) x+        Nothing -> id+    Just s -> showString s++treeChildren :: Tree -> [Tree]+treeChildren (GroupTree g)      = g^.groupChildren+treeChildren (SymbolTree g)     = g^.groupChildren+treeChildren (DefinitionTree g) = g^.groupChildren+treeChildren _                  = []++ppElementS_         :: [Tree] -> Element -> ShowS+ppElementS_ children e xs = tagStart name (elAttribs e) $+  case children of+    [] | "?" `isPrefixOf` qName name -> showString " ?>" xs+       | True  -> showString " />" xs+    _ -> showChar '>' (foldr ppTreeS (tagEnd name xs) children)+  where name = elName e++--------------------------------------------------------------------------------+tagStart           :: QName -> [Attr] -> ShowS+tagStart qn as rs   = '<':showQName qn ++ as_str ++ rs+ where as_str       = if null as then "" else ' ' : unwords (map showAttr as)+       showAttr           :: Attr -> String+       showAttr (Attr qn v) = showQName qn ++ '=' : '"' : v ++ "\""

@@ -564,6 +564,7 @@       -- Correspond to the `marker-end` attribute.     , _markerEnd        :: !(Last ElementRef)     , _filterRef        :: !(Last ElementRef)+    , _preRendered      :: !(Maybe String)     }     deriving (Eq, Show) @@ -889,6 +890,9 @@     Symbol { _groupOfSymbol :: Group a }   deriving (Eq, Show) +instance HasGroup (Symbol a) a where+  group = groupOfSymbol+ -- makeLenses ''Symbol -- | Lenses associated with the Symbol type. groupOfSymbol :: Lens (Symbol s) (Symbol t) (Group s) (Group t)@@ -907,6 +911,9 @@     Definitions { _groupOfDefinitions :: Group a }   deriving (Eq, Show) +instance HasGroup (Definitions a) a where+  group = groupOfDefinitions+ -- makeLenses ''Definitions -- | Lenses associated with the Definitions type. groupOfDefinitions :: Lens (Definitions s) (Definitions t) (Group s) (Group t)@@ -2031,12 +2038,12 @@   ClipPathTree e       -> e ^. drawAttributes  setDrawAttrOfTree :: Tree -> DrawAttributes -> Tree-setDrawAttrOfTree v attr = case v of+setDrawAttrOfTree v attr' = case v of   None                 -> None   UseTree e m          -> UseTree (e & drawAttributes .~ attr) m   GroupTree e          -> GroupTree $ e & drawAttributes .~ attr   SymbolTree e         -> SymbolTree $ e & drawAttributes .~ attr-  DefinitionTree e     -> DefinitionTree e & drawAttributes .~ attr+  DefinitionTree e     -> DefinitionTree $ e & drawAttributes .~ attr   FilterTree e         -> FilterTree $ e & drawAttributes .~ attr   PathTree e           -> PathTree $ e & drawAttributes .~ attr   CircleTree e         -> CircleTree $ e & drawAttributes .~ attr@@ -2054,7 +2061,8 @@   MarkerTree e         -> MarkerTree $ e & drawAttributes .~ attr   MaskTree e           -> MaskTree $ e & drawAttributes .~ attr   ClipPathTree e       -> ClipPathTree $ e & drawAttributes .~ attr-+  where+    attr = attr'{_preRendered = Nothing}  instance HasDrawAttributes Tree where   drawAttributes = lens drawAttrOfTree setDrawAttrOfTree@@ -2599,6 +2607,7 @@         , _markerMid = (mappend `on` _markerMid) a b         , _markerEnd = (mappend `on` _markerEnd) a b         , _filterRef = (mappend `on` _filterRef) a b+        , _preRendered = Nothing         }       where         opacityMappend Nothing Nothing    = Nothing@@ -2636,6 +2645,7 @@         , _markerMid        = Last Nothing         , _markerEnd        = Last Nothing         , _filterRef        = Last Nothing+        , _preRendered      = Nothing         }  instance WithDefaultSvg DrawAttributes where

@@ -99,15 +99,15 @@  instance ParseableAttribute [PathCommand] where   aparse = parse pathParser-  aserialize = Just . serializeCommands+  aserialize v = Just $ serializeCommands v ""  instance ParseableAttribute GradientPathCommand where   aparse = parse gradientCommand-  aserialize = Just . serializeGradientCommand+  aserialize v = Just $ serializeGradientCommand v ""  instance ParseableAttribute [RPoint] where   aparse = parse pointData-  aserialize = Just . serializePoints+  aserialize v = Just $ serializePoints v ""  instance ParseableAttribute Double where   aparse = parseMayStartDot num