module Data.Kiln
( Clay , newClay , readClay , modifyClay , writeClay , identifyClay
, kiln , kilnWith , runKilningWith , runKilning
, module X
) where
import Control.Monad.Squishy as X
import Data.Fix as X
import Data.Traversable as X
import Control.Monad
import Control.Monad.State
import Control.Monad.IfElse
import Control.Applicative
import Control.Arrow
import Data.Map ( Map )
import qualified Data.Map as M
data Clay s f = Clay { getClay :: Distinct s (Ref s (f (Clay s f))) }
newClay :: f (Clay s f) -> Squishy s (Clay s f)
newClay = (Clay <$>) . (distinguish =<<) . newRef
readClay :: Clay s f -> Squishy s (f (Clay s f))
readClay = readRef . conflate . getClay
modifyClay :: Clay s f -> (f (Clay s f) -> f (Clay s f)) -> Squishy s ()
modifyClay = modifyRef . conflate . getClay
writeClay :: Clay s f -> f (Clay s f) -> Squishy s ()
writeClay = writeRef . conflate . getClay
identifyClay :: Clay s f -> Identifier s
identifyClay = identify . getClay
kilnWith :: forall s f g. (Traversable f) => (forall a. f a -> g a) -> Clay s f -> Squishy s (Fix g)
kilnWith transform = flip evalStateT M.empty . kiln'
where
kiln' :: Clay s f -> StateT (Map (Identifier s) (Fix g)) (Squishy s) (Fix g)
kiln' clay =
aifM (M.lookup (identifyClay clay) <$> get) return $ do
baked <- (Fix . transform <$>) . traverse kiln' =<< lift (readClay clay)
modify (M.insert (identifyClay clay) baked) >> return baked
kiln :: (Traversable f) => Clay s f -> Squishy s (Fix f)
kiln = kilnWith id
runKilningWith :: (Traversable f) => (forall a. f a -> g a) -> (forall s. Squishy s (Clay s f)) -> Fix g
runKilningWith transform action = runSquishy (action >>= kilnWith transform)
runKilning :: (Traversable f) => (forall s. Squishy s (Clay s f)) -> Fix f
runKilning = runKilningWith id