src/Hakyll/Core/DirectedGraph/Internal.hs


1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52

-- | Internal structure of the DirectedGraph type. Not exported outside of the
-- library.
--
{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable #-}
module Hakyll.Core.DirectedGraph.Internal
    ( Node (..)
    , DirectedGraph (..)
    ) where

import Prelude hiding (reverse, filter)
import Control.Applicative ((<$>), (<*>))
import Data.Monoid (Monoid, mempty, mappend)
import Data.Set (Set)
import Data.Map (Map)
import qualified Data.Map as M
import qualified Data.Set as S

import Data.Binary (Binary, put, get)
import Data.Typeable (Typeable)

-- | A node in the directed graph
--
data Node a = Node
    { nodeTag        :: a      -- ^ Tag identifying the node
    , nodeNeighbours :: Set a  -- ^ Edges starting at this node
    } deriving (Show, Typeable)

instance (Binary a, Ord a) => Binary (Node a) where
    put (Node t n) = put t >> put n
    get = Node <$> get <*> get

-- | Append two nodes. Useful for joining graphs.
--
appendNodes :: Ord a => Node a -> Node a -> Node a
appendNodes (Node t1 n1) (Node t2 n2)
    | t1 /= t2 = error'
    | otherwise = Node t1 (n1 `S.union` n2)
  where
    error' = error $  "Hakyll.Core.DirectedGraph.Internal.appendNodes: "
                   ++ "Appending differently tagged nodes"

-- | Type used to represent a directed graph
--
newtype DirectedGraph a = DirectedGraph {unDirectedGraph :: Map a (Node a)}
                        deriving (Show, Binary, Typeable)

-- | Allow users to concatenate different graphs
--
instance Ord a => Monoid (DirectedGraph a) where
    mempty = DirectedGraph M.empty
    mappend (DirectedGraph m1) (DirectedGraph m2) = DirectedGraph $
        M.unionWith appendNodes m1 m2