module Data.Renderable (
RenderStrategy(..),
Renderer,
Rendering,
CleanOp,
Cache,
CacheStats(..),
renderPrims,
renderPrimsDebug,
renderPrimsWithStats,
emptyRenderer,
appendRenderer
) where
import Prelude hiding (lookup)
import Control.Applicative
import Control.Monad
import Control.Monad.IO.Class
import Data.Monoid
import Data.Hashable
import qualified Data.Traversable as T
import Data.IntMap (IntMap)
import Data.Foldable (foldl')
import qualified Data.IntMap as IM
data RenderStrategy m t r a = RenderStrategy
{ canAllocPrimitive :: r -> a -> Bool
, compilePrimitive :: r -> a -> m (Renderer m t)
}
type Rendering m t = t -> m ()
type CleanOp m = m ()
type Renderer m t = (CleanOp m, Rendering m t)
emptyRenderer :: Monad m => Renderer m t
emptyRenderer = (return (), const $ return ())
appendRenderer :: Monad m => Renderer m t -> Renderer m t -> Renderer m t
appendRenderer (c1,r1) (c2,r2) = (c1 >> c2, \t -> r1 t >> r2 t)
type Cache m t = IntMap (Renderer m t)
findRenderer :: (Monad m, Hashable a)
=> Cache m t -> (Cache m t, IntMap a) -> a -> (Cache m t, IntMap a)
findRenderer cache (found, missing) a =
let k = hash a in
case IM.lookup k cache of
Nothing -> (found, IM.insert k a missing)
Just r -> (IM.insert k r found, missing)
getRenderer :: (Hashable a, Monad m)
=> RenderStrategy m t r a -> r -> Cache m t -> a -> m (Cache m t)
getRenderer s rez cache a =
if canAllocPrimitive s rez a
then do r <- compilePrimitive s rez a
return $ IM.insert (hash a) r cache
else return cache
clean :: Renderer m t -> m ()
clean = fst
render :: Renderer m t -> t -> m ()
render = snd
renderElement :: (Hashable a, Monad m) => Cache m t -> t -> a -> m ()
renderElement cache t a = do
let k = hash a
case IM.lookup k cache of
Nothing -> return ()
Just r -> render r t
data CacheStats a = CacheStats { cachedPrev :: [Int]
, cachedFound :: [Int]
, cachedMissing :: [Int]
, cachedStale :: [Int]
, cachedNext :: [Int]
}
showCacheStats :: CacheStats a -> String
showCacheStats (CacheStats cache found missing stale next) = unlines
[ "Prev: " ++ show cache
, "Found: " ++ show found
, "Missing: " ++ show missing
, "Stale: " ++ show stale
, "Next: " ++ show next
]
renderPrimsWithStats :: (Functor m, Monad m, Monoid t, Hashable a)
=> RenderStrategy m t r a -> r -> Cache m t -> [(t, a)]
-> m (Cache m t, CacheStats a)
renderPrimsWithStats s rez cache prims = do
let (found, missing) = foldl' (findRenderer cache)
(mempty, mempty)
(map snd prims)
stale = cache `IM.difference` found
void $ T.sequence $ fmap clean stale
new <- foldM (getRenderer s rez) mempty $ IM.elems missing
let next = IM.union found new
stats = CacheStats { cachedPrev = IM.keys cache
, cachedFound = IM.keys found
, cachedMissing = IM.keys missing
, cachedStale = IM.keys stale
, cachedNext = IM.keys next
}
mapM_ (uncurry $ renderElement next) prims
return (next,stats)
renderPrimsDebug :: (Functor m, MonadIO m, Monoid t, Hashable a)
=> Bool -> RenderStrategy m t r a -> r -> Cache m t -> [(t, a)]
-> m (Cache m t)
renderPrimsDebug debug s rez cache prims = do
(next, stats) <- renderPrimsWithStats s rez cache prims
when debug $ liftIO $ putStrLn $ showCacheStats stats
return next
renderPrims :: (Functor m, Monad m, Monoid t, Hashable a)
=> RenderStrategy m t r a -> r -> Cache m t -> [(t, a)]
-> m (Cache m t)
renderPrims s rez cache prims = fst <$> renderPrimsWithStats s rez cache prims