{-# LANGUAGE GADTs #-} module Database.Ferry.Algebra.Data.GraphBuilder where import Database.Ferry.Algebra.Data.Algebra import qualified Data.Map as M import Control.Monad.State import Control.Monad.Reader -- | Graphs are constructed in a monadic environment. -- | The graph constructed has to be a DAG. -- | The reader monad provides access to the variable environment Gamma and the loop table -- | The variable environment is a mapping from variable names to graphnodes that represent -- | their compiled form. -- | The state monad gives access to a supply of fresh variables, and maintains a map from -- | nodes to node ids. When a node is inserted and an equal node (equal means, equal node -- | and equal child nodes) already exists in the map the node id for that already existing -- | node is returned. This allows maximal sharing. type GraphM a = ReaderT (Gam a, AlgNode) (State (Int, M.Map Algebra AlgNode, Tags)) -- | Variable environemtn mapping from variables to compiled nodes. type Gam a = [(String, a)] -- | An algebraic plan is the result of constructing a graph. -- | The pair consists of the mapping from nodes to their respective ids -- | and the algres from the top node. type AlgPlan res = (M.Map Algebra AlgNode, res, Tags) type Tags = M.Map AlgNode [String] -- | Evaluate the monadic graph into an algebraic plan, given a loop relation. runGraph :: Algebra -> GraphM res res -> AlgPlan res runGraph l = (\(r, (_,m, c)) -> (m, r, c) ) . flip runState (2, M.singleton l 1, M.empty) . flip runReaderT ([], 1) -- Add tag addTag :: AlgNode -> String -> GraphM a () addTag i c = modify insertTag where insertTag :: (Int, M.Map Algebra AlgNode, Tags) -> (Int, M.Map Algebra AlgNode, Tags) insertTag (s, g, v) = (s, g, M.insertWith (++) i [c] v) -- | Get the current loop table getLoop :: GraphM a AlgNode getLoop = do (_, l) <- ask return l -- | Get the current variable environment getGamma :: GraphM a (Gam a) getGamma = do (g, _) <- ask return g -- | Get a fresh node id getFreshId :: GraphM a Int getFreshId = do (n, t, c) <- get put $ (n + 1, t, c) return n -- | Check if a node already exists in the graph construction environment, if so return its id. findNode :: Algebra -> GraphM a (Maybe AlgNode) findNode n = do (_, t, _) <- get return $ M.lookup n t -- | Insert a node into the graph construction environment, first check if the node already exists -- | if so return its id, otherwise insert it and return its id. insertNode :: Algebra -> GraphM a AlgNode insertNode (Dummy s c) = do addTag c s return c insertNode n = do v <- findNode n case v of (Just n') -> return n' Nothing -> insertNode' n -- | Blindly insert a node, get a fresh id and return that insertNode' :: Algebra -> GraphM a AlgNode insertNode' n = do i <- getFreshId (sup, t, c) <- get let t' = M.insert n i t put $ (sup, t', c) return i -- | Evaluate the graph construction computation with the current environment extended with a binding n to v. withBinding :: String -> a -> GraphM a r -> GraphM a r withBinding n v a = do local (\(g, alg) -> ((n, v):g, alg)) a -- | Evaluate the graph construction computation with a differnt gamma, -- | and loop table. Return within he current computational context. withContext :: Gam a -> AlgNode -> GraphM a r -> GraphM a r withContext gam loop = local (\_ -> (gam, loop)) -- | Lookup a variable in the environment fromGam :: String -> GraphM a a fromGam n = do (m, _) <- ask case lookup n m of Just r -> return r Nothing -> error $ "Variable: " ++ n ++ " could not be found, should not be possible!"