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
type GraphM a = ReaderT (Gam a, AlgNode) (State (Int, M.Map Algebra AlgNode, Tags))
type Gam a = [(String, a)]
type AlgPlan res = (M.Map Algebra AlgNode, res, Tags)
type Tags = M.Map AlgNode [String]
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)
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)
getLoop :: GraphM a AlgNode
getLoop = do
(_, l) <- ask
return l
getGamma :: GraphM a (Gam a)
getGamma = do
(g, _) <- ask
return g
getFreshId :: GraphM a Int
getFreshId = do
(n, t, c) <- get
put $ (n + 1, t, c)
return n
findNode :: Algebra -> GraphM a (Maybe AlgNode)
findNode n = do
(_, t, _) <- get
return $ M.lookup n t
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
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
withBinding :: String -> a -> GraphM a r -> GraphM a r
withBinding n v a = do
local (\(g, alg) -> ((n, v):g, alg)) a
withContext :: Gam a -> AlgNode -> GraphM a r -> GraphM a r
withContext gam loop = local (\_ -> (gam, loop))
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!"