-- | Reifying the sharing in an 'AST'---- This module is based on /Type-Safe Observable Sharing in Haskell/ (Andy Gill,-- /Haskell Symposium/, 2009).moduleLanguage.Syntactic.Sharing.Reify(reifyGraph)whereimportControl.Monad.WriterimportData.IntMapasMapimportData.IORefimportData.TypeableimportSystem.Mem.StableNameimportLanguage.SyntacticimportLanguage.Syntactic.Sharing.GraphimportLanguage.Syntactic.Sharing.StableName-- | Shorthand used by 'reifyGraphM'---- Writes out a list of encountered nodes and returns the top expression.typeGraphMonadctxdoma=WriterT[(NodeId,SomeAST(Nodectx:+:dom))]IO(AST(Nodectx:+:dom)a)reifyGraphM::forallctxdoma.Typeablea=>(foralla.ASTFdoma->Maybe(Witness'ctxa))->IORefNodeId->IORef(History(ASTdom))->ASTFdoma->GraphMonadctxdom(Fulla)reifyGraphMcanSharenSupphistory=reifyNodewherereifyNode::Typeableb=>ASTFdomb->GraphMonadctxdom(Fullb)reifyNodea=casecanShareaofNothing->reifyRecaJustWitness'|a`seq`True->dost<-liftIO$makeStableNameahist<-liftIO$readIORefhistorycaselookHistoryhist(StNamest)ofJustn->return$Symbol$InjectL$Noden_->don<-freshnSuppliftIO$modifyIORefhistory$remember(StNamest)na'<-reifyRecatell[(n,SomeASTa')]return$Symbol$InjectL$NodenreifyRec::ASTdomb->GraphMonadctxdombreifyRec(f:$:a)=liftM2(:$:)(reifyRecf)(reifyNodea)reifyRec(Symbola)=return$Symbol(InjectRa)-- | Convert a syntax tree to a sharing-preserving graph---- This function is not referentially transparent (hence the 'IO'). However, it-- is well-behaved in the sense that the worst thing that could happen is that-- sharing is lost. It is not possible to get false sharing.reifyGraph::Typeablea=>(foralla.ASTFdoma->Maybe(Witness'ctxa))-- ^ A function that decides whether a given node can be shared.-- 'Nothing' means \"don't share\"; 'Just' means \"share\". Nodes whose-- result type fulfills @(`Sat` ctx a)@ can be shared, which is why the-- function returns a 'Witness''.->ASTFdoma->IO(ASGctxdoma)reifyGraphcanSharea=donSupp<-newIORef0history<-newIORefempty(a',ns)<-runWriterT$reifyGraphMcanSharenSupphistoryan<-readIORefnSuppreturn(ASGa'nsn)