module Language.Syntactic.Sharing.ReifyHO
( reifyGraphTop
, reifyGraph
) where
import Control.Monad.Writer
import Data.IntMap as Map
import Data.IORef
import System.Mem.StableName
import Language.Syntactic
import Language.Syntactic.Constructs.Binding
import Language.Syntactic.Constructs.Binding.HigherOrder
import Language.Syntactic.Sharing.Graph
import Language.Syntactic.Sharing.StableName
import qualified Language.Syntactic.Sharing.Reify
type GraphMonad dom p a = WriterT
[(NodeId, ASTB (NodeDomain ((Lambda :+: Variable :+: dom) :|| p)))]
IO
(AST (NodeDomain ((Lambda :+: Variable :+: dom) :|| p)) a)
reifyGraphM :: forall dom p a
. (forall a . ASTF (HODomain dom p) a -> Bool)
-> IORef VarId
-> IORef NodeId
-> IORef (History (AST (HODomain dom p)))
-> ASTF (HODomain dom p) a
-> GraphMonad dom p (Full a)
reifyGraphM canShare vSupp nSupp history = reifyNode
where
reifyNode :: ASTF (HODomain dom p) b -> GraphMonad dom p (Full b)
reifyNode a
| Dict <- exprDict a = case canShare a of
False -> reifyRec a
True | a `seq` True -> do
st <- liftIO $ makeStableName a
hist <- liftIO $ readIORef history
case lookHistory hist (StName st) of
Just n -> return $ injC $ Node n
_ -> do
n <- fresh nSupp
liftIO $ modifyIORef history $ remember (StName st) n
a' <- reifyRec a
tell [(n, ASTB a')]
return $ injC $ Node n
reifyRec :: AST (HODomain dom p) b -> GraphMonad dom p b
reifyRec (f :$ a) = liftM2 (:$) (reifyRec f) (reifyNode a)
reifyRec (Sym (C' (InjR a))) = return $ Sym $ C' $ InjR $ C' $ InjR a
reifyRec (Sym (C' (InjL (HOLambda f)))) = do
v <- fresh vSupp
body <- reifyNode $ f $ injC $ Variable v
return $ injC (Lambda v) :$ body
reifyGraphTop
:: (forall a . ASTF (HODomain dom p) a -> Bool)
-> ASTF (HODomain dom p) a
-> IO (ASG ((Lambda :+: Variable :+: dom) :|| p) a, VarId)
reifyGraphTop canShare a = do
vSupp <- newIORef 0
nSupp <- newIORef 0
history <- newIORef empty
(a',ns) <- runWriterT $ reifyGraphM canShare vSupp nSupp history a
v <- readIORef vSupp
n <- readIORef nSupp
return (ASG a' ns n, v)
reifyGraph :: Syntactic a (HODomain dom p)
=> (forall a . ASTF (HODomain dom p) a -> Bool)
-> a
-> IO (ASG ((Lambda :+: Variable :+: dom) :|| p) (Internal a), VarId)
reifyGraph canShare = reifyGraphTop canShare . desugar