{-# LANGUAGE DeriveGeneric #-}
module NetSpider.Snapshot.Internal
( SnapshotGraph,
SnapshotLink(..),
linkNodeTuple,
linkNodePair,
SnapshotNode(..)
) where
import Control.Applicative (many, (*>))
import Data.Aeson (ToJSON(..), FromJSON(..))
import qualified Data.Aeson as Aeson
import Data.Bifunctor (Bifunctor(..))
import Data.Char (isUpper, toLower)
import GHC.Generics (Generic)
import NetSpider.Pair (Pair(..))
import NetSpider.Timestamp (Timestamp)
import qualified Text.Regex.Applicative as RE
type SnapshotGraph n na la = ([SnapshotNode n na], [SnapshotLink n la])
data SnapshotLink n la =
SnapshotLink
{ _sourceNode :: n,
_destinationNode :: n,
_isDirected :: Bool,
_linkTimestamp :: Timestamp,
_linkAttributes :: la
}
deriving (Show,Eq,Generic)
instance (Ord n, Eq la) => Ord (SnapshotLink n la) where
compare l r = compare (linkNodeTuple l) (linkNodeTuple r)
instance Functor (SnapshotLink n) where
fmap f l = l { _linkAttributes = f $ _linkAttributes l }
instance Bifunctor SnapshotLink where
bimap fn fla l = l { _linkAttributes = fla $ _linkAttributes l,
_sourceNode = fn $ _sourceNode l,
_destinationNode = fn $ _destinationNode l
}
aesonOpt :: Aeson.Options
aesonOpt = Aeson.defaultOptions
{ Aeson.fieldLabelModifier = modifier
}
where
modifier = RE.replace reSnake . RE.replace reAttr . RE.replace reDest . RE.replace reTime
reDest = fmap (const "dest") $ RE.string "destination"
reAttr = fmap (const "Attrs") $ RE.string "Attributes"
reTime = fmap (const "timestamp") (many RE.anySym *> RE.string "Timestamp")
reSnake = RE.msym $ \c ->
if c == '_'
then Just ""
else if isUpper c
then Just ['_', toLower c]
else Nothing
instance (FromJSON n, FromJSON la) => FromJSON (SnapshotLink n la) where
parseJSON = Aeson.genericParseJSON aesonOpt
instance (ToJSON n, ToJSON la) => ToJSON (SnapshotLink n la) where
toJSON = Aeson.genericToJSON aesonOpt
toEncoding = Aeson.genericToEncoding aesonOpt
linkNodeTuple :: SnapshotLink n la -> (n, n)
linkNodeTuple link = (_sourceNode link, _destinationNode link)
linkNodePair :: SnapshotLink n la -> Pair n
linkNodePair = Pair . linkNodeTuple
data SnapshotNode n na =
SnapshotNode
{ _nodeId :: n,
_isOnBoundary :: Bool,
_nodeTimestamp :: Maybe Timestamp,
_nodeAttributes :: Maybe na
}
deriving (Show,Eq,Generic)
instance (Ord n, Eq na) => Ord (SnapshotNode n na) where
compare l r = compare (_nodeId l) (_nodeId r)
instance Functor (SnapshotNode n) where
fmap f n = n { _nodeAttributes = fmap f $ _nodeAttributes n }
instance Bifunctor SnapshotNode where
bimap fn fna n = n { _nodeAttributes = fmap fna $ _nodeAttributes n,
_nodeId = fn $ _nodeId n
}
instance (FromJSON n, FromJSON na) => FromJSON (SnapshotNode n na) where
parseJSON = Aeson.genericParseJSON aesonOpt
instance (ToJSON n, ToJSON na) => ToJSON (SnapshotNode n na) where
toJSON = Aeson.genericToJSON aesonOpt
toEncoding = Aeson.genericToEncoding aesonOpt