    {-# LANGUAGE CPP, MultiParamTypeClasses #-}

    -- (c) 2002 by Martin Erwig [see file COPYRIGHT]
    -- | Monadic Graphs
    module Data.Graph.Inductive.Monad(
        -- * Classes
        GraphM(..),
        -- * Operations
        -- ** Graph Folds and Maps
        ufoldM,
        -- ** Graph Projection
        nodesM,edgesM,newNodesM,
        -- ** Graph Construction and Destruction
        delNodeM,delNodesM,
        mkUGraphM,
        -- ** Graph Inspection
        contextM,labM
    ) where

    import Data.Graph.Inductive.Graph
    #if MIN_VERSION_base(4,12,0)
    import Control.Monad.Fail
    import Prelude hiding (fail)
    #endif

    {-# ANN module "HLint: ignore Redundant lambda" #-}

    ----------------------------------------------------------------------
    -- MONADIC GRAPH CLASS
    ----------------------------------------------------------------------

    --
    -- Currently, we define just one monadic graph class:
    --
    --   GraphM:    static, decomposable graphs
    --              static means that a graph itself cannot be changed
    --
    -- Later we might also define DynGraphM for dynamic, extensible graphs
    --

    -- Monadic Graph
    --
    class
    #if MIN_VERSION_base(4,12,0)
     (MonadFail m)
    #else
     (Monad m)
    #endif
      => GraphM m gr where
      {-# MINIMAL emptyM, isEmptyM, matchM, mkGraphM, labNodesM #-}

      emptyM     :: m (gr a b)

      isEmptyM   :: m (gr a b) -> m Bool

      matchM     :: Node -> m (gr a b) -> m (Decomp gr a b)

      mkGraphM   :: [LNode a] -> [LEdge b] -> m (gr a b)

      labNodesM  :: m (gr a b) -> m [LNode a]

      matchAnyM  :: m (gr a b) -> m (GDecomp gr a b)
      matchAnyM g = do vs <- labNodesM g
                       case vs of
                         []      -> fail "Match Exception, Empty Graph"
                         (v,_):_ -> do (Just c,g') <- matchM v g
                                       return (c,g')

      noNodesM   :: m (gr a b) -> m Int
      noNodesM = labNodesM >>. length

      nodeRangeM :: m (gr a b) -> m (Node,Node)
      nodeRangeM g = do isE <- isEmptyM g
                        if isE
                           then fail "nodeRangeM of empty graph"
                           else do vs <- nodesM g
                                   return (minimum vs,maximum vs)

      labEdgesM  :: m (gr a b) -> m [LEdge b]
      labEdgesM = ufoldM (\(p,v,_,s)->((map (i v) p ++ map (o v) s)++)) []
        where
          o v = \(l,w)->(v,w,l)
          i v = \(l,w)->(w,v,l)

    -- composing a monadic function with a non-monadic one
    --
    (>>.) :: (Monad m) => (m a -> m b) -> (b -> c) -> m a -> m c
    f >>. g = (>>= return . g) . f

    ----------------------------------------------------------------------
    -- DERIVED GRAPH OPERATIONS
    ----------------------------------------------------------------------

    -- graph folds and maps
    --

    -- | graph fold
    ufoldM :: (GraphM m gr) => (Context a b -> c -> c) -> c -> m (gr a b) -> m c
    ufoldM f u g = do b <- isEmptyM g
                      if b then return u
                           else do (c,g') <- matchAnyM g
                                   x <- ufoldM f u (return g')
                                   return (f c x)

    -- (additional) graph projection
    -- [noNodes, nodeRange, labNodes, labEdges are defined in class Graph]
    --
    nodesM :: (GraphM m gr) => m (gr a b) -> m [Node]
    nodesM = labNodesM >>. map fst

    edgesM :: (GraphM m gr) => m (gr a b) -> m [Edge]
    edgesM =  labEdgesM >>. map (\(v,w,_)->(v,w))

    newNodesM :: (GraphM m gr) => Int -> m (gr a b) -> m [Node]
    newNodesM i g = do isE <- isEmptyM g
                       if isE
                          then return [0..i-1]
                          else do (_,n) <- nodeRangeM g
                                  return [n+1..n+i]

    -- graph construction & destruction
    --
    delNodeM :: (GraphM m gr) => Node -> m (gr a b) -> m (gr a b)
    delNodeM v = delNodesM [v]

    delNodesM :: (GraphM m gr) => [Node] -> m (gr a b) -> m (gr a b)
    delNodesM []     g = g
    delNodesM (v:vs) g = do (_,g') <- matchM v g
                            delNodesM vs (return g')

    mkUGraphM :: (GraphM m gr) => [Node] -> [Edge] -> m (gr () ())
    mkUGraphM vs es = mkGraphM (labUNodes vs) (labUEdges es)

    labUEdges :: [Edge] -> [LEdge ()]
    labUEdges = map (`toLEdge` ())

    labUNodes :: [Node] -> [LNode ()]
    labUNodes = map (\v->(v,()))

    -- graph inspection (for a particular node)
    --
    onMatch :: (GraphM m gr) => (Context a b -> c) -> c -> m (gr a b) -> Node -> m c
    onMatch f u g v = do (x,_) <- matchM v g
                         return (case x of {Nothing -> u; Just c -> f c})

    contextM :: (GraphM m gr) => m (gr a b) -> Node -> m (Context a b)
    contextM g v = onMatch id (error ("Match Exception, Node: "++show v)) g v

    labM :: (GraphM m gr) => m (gr a b) -> Node -> m (Maybe a)
    labM = onMatch (Just . lab') Nothing

    {-
    neighbors :: (GraphM m gr) => m (gr a b) -> Node -> [Node]
    neighbors = (\(p,_,_,s) -> map snd (p++s)) .: context

    suc :: (GraphM m gr) => m (gr a b) -> Node -> [Node]
    suc = map snd .: context4

    pre :: (GraphM m gr) => m (gr a b) -> Node -> [Node]
    pre = map snd .: context1

    lsuc :: (GraphM m gr) => m (gr a b) -> Node -> [(Node,b)]
    lsuc = map flip2 .: context4

    lpre :: (GraphM m gr) => m (gr a b) -> Node -> [(Node,b)]
    lpre = map flip2 .: context1

    out :: (GraphM m gr) => m (gr a b) -> Node -> [LEdge b]
    out g v = map (\(l,w)->(v,w,l)) (context4 g v)

    inn :: (GraphM m gr) => m (gr a b) -> Node -> [LEdge b]
    inn g v = map (\(l,w)->(w,v,l)) (context1 g v)

    outdeg :: (GraphM m gr) => m (gr a b) -> Node -> Int
    outdeg = length .: context4

    indeg :: (GraphM m gr) => m (gr a b) -> Node -> Int
    indeg  = length .: context1

    deg :: (GraphM m gr) => m (gr a b) -> Node -> Int
    deg = (\(p,_,_,s) -> length p+length s) .: context
    --

    -- -- context inspection
    -- --
    -- node' :: Context a b -> Node
    -- node' (_,v,_,_) = v
    --
    -- lab' :: Context a b -> a
    -- lab' (_,_,l,_) = l
    --
    -- labNode' :: Context a b -> LNode a
    -- labNode' (_,v,l,_) = (v,l)
    --
    -- neighbors' :: Context a b -> [Node]
    -- neighbors' (p,_,_,s) = map snd p++map snd s
    --
    -- suc' :: Context a b -> [Node]
    -- suc' (_,_,_,s) = map snd s
    --
    -- pre' :: Context a b -> [Node]
    -- pre' (p,_,_,_) = map snd p
    --
    -- lpre' :: Context a b -> [(Node,b)]
    -- lpre' (p,_,_,_) = map flip2 p
    --
    -- lsuc' :: Context a b -> [(Node,b)]
    -- lsuc' (_,_,_,s) = map flip2 s
    --
    -- out' :: Context a b -> [LEdge b]
    -- out' (_,v,_,s) = map (\(l,w)->(v,w,l)) s
    --
    -- inn' :: Context a b -> [LEdge b]
    -- inn' (p,v,_,_) = map (\(l,w)->(w,v,l)) p
    --
    -- outdeg' :: Context a b -> Int
    -- outdeg' (_,_,_,s) = length s
    --
    -- indeg' :: Context a b -> Int
    -- indeg' (p,_,_,_) = length p
    --
    -- deg' :: Context a b -> Int
    -- deg' (p,_,_,s) = length p+length s

    -- graph equality
    --
    nodeComp :: (Eq b) => LNode b -> LNode b -> Ordering
    nodeComp n@(v,a) n'@(w,b) | n == n'   = EQ
                              | v<w       = LT
                              | otherwise = GT

    slabNodes :: (Eq a,Graph gr) => m (gr a b) -> [LNode a]
    slabNodes = sortBy nodeComp . labNodes

    edgeComp :: (Eq b) => LEdge b -> LEdge b -> Ordering
    edgeComp e@(v,w,a) e'@(x,y,b) | e == e'              = EQ
                                  | v<x || (v==x && w<y) = LT
                                  | otherwise            = GT

    slabEdges :: (Eq b,Graph gr) => m (gr a b) -> [LEdge b]
    slabEdges = sortBy edgeComp . labEdges

    instance (Eq a,Eq b,Graph gr) => Eq (m (gr a b)) where
      g == g' = slabNodes g == slabNodes g' && slabEdges g == slabEdges g'

    -}