{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Data.Renderable where
import Prelude hiding (lookup)
import Control.Monad
import Data.Hashable
import Data.IntMap (IntMap)
import Data.Maybe
import Data.Monoid
import Data.List (intercalate)
import qualified Data.IntSet as S
import qualified Data.IntMap as IM
import GHC.Stack
instance Decomposable (Element m r t) m r t where
decompose e = [e]
instance Renderable (Element m r t) where
type RenderMonad (Element m r t) = m
type RenderRsrc (Element m r t) = r
type RenderTfrm (Element m r t) = t
cache rz rs (Element a) = attachIfNeeded rz rs a
nameOf (Element a) = "Element " ++ nameOf a
composite (Element a) = composite a
instance ( t ~ RenderTfrm a, Show t, Monoid t
, Hashable a, Renderable a) => Renderable (t,a) where
type RenderMonad (t,a) = RenderMonad a
type RenderTfrm (t,a) = RenderTfrm a
type RenderRsrc (t,a) = RenderRsrc a
cache rz rs (_,a) = attachIfNeeded rz rs a
nameOf (t,a) = "(" ++ show t ++ ", " ++ nameOf a ++ ")"
composite (t,a) = map (fmap $ fmap (t <>)) $ composite a
instance (Renderable a, Hashable a, Show a) => Renderable (Maybe a) where
type RenderMonad (Maybe a) = RenderMonad a
type RenderTfrm (Maybe a) = RenderTfrm a
type RenderRsrc (Maybe a) = RenderRsrc a
cache rz rs (Just a) = attachIfNeeded rz rs a
cache _ rs _ = return rs
nameOf (Just a) = "Just " ++ nameOf a
nameOf _ = "Nothing"
composite (Just a) = composite a
composite _ = []
instance (Renderable a, Hashable a) => Renderable [a] where
type RenderMonad [a] = RenderMonad a
type RenderTfrm [a] = RenderTfrm a
type RenderRsrc [a] = RenderRsrc a
cache = foldM . attachIfNeeded
nameOf as = "[ " ++ (intercalate ", " names) ++ " ]"
where names = map nameOf as
composite = concatMap composite
renderData :: (Monad m, Renderable a, Monoid (RenderTfrm a))
=> Cache m (RenderTfrm a) -> a -> m ()
renderData c = renderComposite c mempty . composite
renderDataHidden :: (Renderable a, Monad m, Monoid (RenderTfrm a))
=> Cache m (RenderTfrm a) -> (RenderTfrm a) -> a -> m ()
renderDataHidden c t = renderComposite c t . catMaybes . map f . composite
where f (i, Nothing) = Just (i, Just mempty)
f _ = Nothing
renderComposite :: (Monad m, Monoid t) => Cache m t -> t -> Composite t -> m ()
renderComposite rs t = mapM_ (uncurry go)
where go k (Just t') = maybe (err k) (rend t') $ IM.lookup k rs
go _ _ = return ()
rend t' (Rendering f _) = f $ t <> t'
err k = errorWithStackTrace $ unwords [ "Fatal error! Could not find"
, "rendering (from a layer)"
, show k
]
attachIfNeeded :: ( Renderable a, Monad (RenderMonad a)
, Monoid (RenderTfrm a), Hashable a)
=> RenderRsrc a -> Cache (RenderMonad a) (RenderTfrm a)
-> a -> (RenderMonad a) (Cache (RenderMonad a) (RenderTfrm a))
attachIfNeeded rz cache' a =
maybe (cache rz cache' a) (const $ return cache') $ IM.lookup (hash a) cache'
detachUnused :: (Monad m, Renderable a) => Cache m t -> a -> m (Cache m t)
detachUnused c a =
let hashes = S.fromList $ map fst $ composite a
keys = IM.keysSet c
diff = S.difference keys hashes
in foldM detach c $ S.toList diff
detach :: Monad m => Cache m t -> Int -> m (Cache m t)
detach c k = do
case IM.lookup k c of
Nothing -> let s = "Could not find rendering for " ++ show k
in errorWithStackTrace s
Just rendering -> clean rendering
return $ IM.delete k c
class Decomposable a m r t where
decompose :: 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
instance Show (Element m r t) where
show (Element a) = "Element{ " ++ show a ++ " }"
data Element m r t where
Element :: ( Monad m, Show a, Hashable a, Renderable a
, m ~ RenderMonad a
, r ~ RenderRsrc a
, t ~ RenderTfrm a)
=> a -> Element m r t
class Renderable a where
type RenderMonad a :: * -> *
type RenderTfrm a :: *
type RenderRsrc a :: *
nameOf :: a -> String
cache :: (Monad (RenderMonad a), Monoid (RenderTfrm a))
=> RenderRsrc a -> Cache (RenderMonad a) (RenderTfrm a) -> a
-> (RenderMonad a) (Cache (RenderMonad a) (RenderTfrm a))
composite :: a -> Composite (RenderTfrm a)
type Cache m t = IntMap (Rendering m t)
instance Monad m => Monoid (Rendering m t) where
(Rendering a b) `mappend` (Rendering c d) =
Rendering (\t -> a t >> c t) (b >> d)
mempty = Rendering (const $ return ()) (return ())
data Rendering m t = Rendering { render :: t -> m ()
, clean :: m ()
}
type Composite a = [(Int, Maybe a)]