{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Data.Renderable (
Primitive(..),
Element(..),
Composite(..),
Rendering,
Cache,
renderData
) where
import Prelude hiding (lookup)
import Control.Arrow (first)
import Control.Monad
import Data.Hashable
import Data.IntMap (IntMap)
import qualified Data.IntMap as IM
class Primitive a where
type PrimM a :: * -> *
type PrimT a :: *
type PrimR a :: *
compilePrimitive :: Monad (PrimM a)
=> PrimR a
-> a
-> (PrimM a) (Rendering (PrimM a) (PrimT a))
data Element m r t where
Element :: ( Monad m, Hashable a, Primitive a
, m ~ PrimM a
, r ~ PrimR a
, t ~ PrimT a)
=> a -> Element m r t
instance Hashable (Element m r t) where
hashWithSalt s (Element a) = s `hashWithSalt` "Element" `hashWithSalt` a
instance Eq (Element m r t) where
a == b = hash a == hash b
class Composite a m r t where
composite :: a -> [(t, Element m r t)]
type Rendering m t = (m (), t -> m ())
type Cache m t = IntMap (Rendering m t)
instance Monad m => Monoid (Rendering m t) where
(ca, fa) `mappend` (cb, fb) = (ca >> cb, \t -> fa t >> fb t)
mempty = (return (), const $ return ())
findRenderer :: Monad m
=> Cache m t
-> (Cache m t, IntMap (Element m r t))
-> Element m r t
-> (Cache m t, IntMap (Element m r t))
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 :: (Primitive a, Hashable a, Monad (PrimM a))
=> PrimR a
-> Cache (PrimM a) (PrimT a)
-> a
-> (PrimM a) (Cache (PrimM a) (PrimT a))
getRenderer rez cache a = do
r <- compilePrimitive rez a
return $ IM.insert (hash a) r cache
getElementRenderer :: r -> Cache m t -> Element m r t -> m (Cache m t)
getElementRenderer rez cache (Element a) = getRenderer rez cache a
clean :: Rendering m t -> m ()
clean = fst
render :: Rendering m t -> t -> m ()
render = snd
renderElement :: Monad m => Cache m t -> t -> Element m r t -> m ()
renderElement cache t (Element a) = do
let k = hash a
case IM.lookup k cache of
Nothing -> return ()
Just r -> render r t
renderData :: (Composite a m r t, Hashable a, Monad m, Monoid t)
=> r -> Cache m t -> a -> m (Cache m t)
renderData rez cache a = do
let comp = composite a
(found, missing) = foldl (findRenderer cache) (mempty, mempty) $ map snd comp
stale = cache `IM.difference` found
sequence_ $ fmap clean stale
new <- foldM (getElementRenderer rez) mempty $ IM.elems missing
let next = IM.union found new
mapM_ (uncurry $ renderElement next) comp
return next
instance Monoid t => Composite (Element m r t) m r t where
composite e = [(mempty, e)]
instance (Monoid t, Composite a m r t) => Composite (t,a) m r t where
composite (t, a) = map (first (mappend t)) $ composite a
instance Composite a m r t => Composite (Maybe a) m r t where
composite (Just a) = composite a
composite _ = []
instance Composite a m r t => Composite [a] m r t where
composite = concatMap composite