module Language.Syntactic.Sharing.Reify
( reifyGraph
) where
import Control.Monad.Writer
import Data.IntMap as Map
import Data.IORef
import Data.Typeable
import System.Mem.StableName
import Language.Syntactic
import Language.Syntactic.Sharing.Graph
import Language.Syntactic.Sharing.StableName
type GraphMonad ctx dom a = WriterT
[(NodeId, SomeAST (Node ctx :+: dom))]
IO
(AST (Node ctx :+: dom) a)
reifyGraphM :: forall ctx dom a . Typeable a
=> (forall a . ASTF dom a -> Maybe (SatWit ctx a))
-> IORef NodeId
-> IORef (History (AST dom))
-> ASTF dom a
-> GraphMonad ctx dom (Full a)
reifyGraphM canShare nSupp history = reifyNode
where
reifyNode :: Typeable b => ASTF dom b -> GraphMonad ctx dom (Full b)
reifyNode a = case canShare a of
Nothing -> reifyRec a
Just SatWit | a `seq` True -> do
st <- liftIO $ makeStableName a
hist <- liftIO $ readIORef history
case lookHistory hist (StName st) of
Just n -> return $ Sym $ InjL $ Node n
_ -> do
n <- fresh nSupp
liftIO $ modifyIORef history $ remember (StName st) n
a' <- reifyRec a
tell [(n, SomeAST a')]
return $ Sym $ InjL $ Node n
reifyRec :: AST dom b -> GraphMonad ctx dom b
reifyRec (f :$ a) = liftM2 (:$) (reifyRec f) (reifyNode a)
reifyRec (Sym a) = return $ Sym (InjR a)
reifyGraph :: Typeable a
=> (forall a . ASTF dom a -> Maybe (SatWit ctx a))
-> ASTF dom a
-> IO (ASG ctx dom a)
reifyGraph canShare a = do
nSupp <- newIORef 0
history <- newIORef empty
(a',ns) <- runWriterT $ reifyGraphM canShare nSupp history a
n <- readIORef nSupp
return (ASG a' ns n)