{-# LANGUAGE TypeFamilies, OverloadedStrings, FlexibleInstances, GeneralizedNewtypeDeriving, DeriveTraversable, GADTs, DeriveGeneric #-}
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
module Data.Greskell.Graph
(
Element(..),
ElementData(..),
ElementID(..),
unsafeCastElementID,
Vertex,
Edge,
Property(..),
T,
tId,
tKey,
tLabel,
tValue,
Cardinality,
cList,
cSet,
cSingle,
Key(..),
key,
unsafeCastKey,
KeyValue(..),
(=:),
Keys(..),
singletonKeys,
(-:),
Path(..),
PathEntry(..),
pathToPMap,
makePathEntry,
AVertex(..),
AEdge(..),
AVertexProperty(..),
AProperty(..)
) where
import Control.Applicative (empty, (<$>), (<*>), (<|>))
import Control.Monad (when)
import Data.Aeson (Value(..), FromJSON(..), ToJSON(..))
import Data.Aeson.Types (Parser)
import Data.Foldable (toList, Foldable(foldr), foldlM)
import Data.Hashable (Hashable)
import Data.HashSet (HashSet)
import qualified Data.HashSet as HS
import qualified Data.HashMap.Strict as HM
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NL
import Data.Maybe (listToMaybe)
import Data.Monoid (Monoid(..))
import Data.Semigroup ((<>), Semigroup)
import qualified Data.Semigroup as Semigroup
import Data.String (IsString(..))
import Data.Text (Text, unpack)
import Data.Traversable (Traversable(traverse))
import Data.Vector (Vector)
import GHC.Generics (Generic)
import Data.Greskell.AsIterator (AsIterator(..))
import Data.Greskell.AsLabel (AsLabel(..), unsafeCastAsLabel)
import Data.Greskell.GraphSON
( GraphSON(..), GraphSONTyped(..), FromGraphSON(..),
(.:), GValue, GValueBody(..),
parseJSONViaGValue
)
import Data.Greskell.GraphSON.GValue (gValueBody, gValueType)
import Data.Greskell.Greskell
( Greskell, unsafeGreskellLazy, string,
ToGreskell(..)
)
import Data.Greskell.NonEmptyLike (NonEmptyLike)
import Data.Greskell.PMap (PMapKey(..), Single, Multi, PMap, pMapInsert)
newtype ElementID e =
ElementID
{ unElementID :: GValue
}
deriving (Show,Eq,Generic, ToJSON, FromJSON, FromGraphSON, Hashable)
instance Functor ElementID where
fmap _ e = unsafeCastElementID e
unsafeCastElementID :: ElementID a -> ElementID b
unsafeCastElementID (ElementID e) = ElementID e
class ElementData e where
elementId :: e -> ElementID e
elementLabel :: e -> Text
class ElementData e => Element e where
type ElementProperty e :: * -> *
type ElementPropertyContainer e :: * -> *
class (Element v) => Vertex v
class (Element e) => Edge e
class Property p where
propertyKey :: p v -> Text
propertyValue :: p v -> v
data T a b
instance GraphSONTyped (T a b) where
gsonTypeFor _ = "g:T"
tId :: Element a => Greskell (T a (ElementID a))
tId = unsafeGreskellLazy "T.id"
tKey :: (Element (p v), Property p) => Greskell (T (p v) Text)
tKey = unsafeGreskellLazy "T.key"
tLabel :: Element a => Greskell (T a Text)
tLabel = unsafeGreskellLazy "T.label"
tValue :: (Element (p v), Property p) => Greskell (T (p v) v)
tValue = unsafeGreskellLazy "T.value"
data Cardinality
cList :: Greskell Cardinality
cList = unsafeGreskellLazy "list"
cSet :: Greskell Cardinality
cSet = unsafeGreskellLazy "set"
cSingle :: Greskell Cardinality
cSingle = unsafeGreskellLazy "single"
newtype Key a b = Key { unKey :: Text }
deriving (Show,Eq)
instance Functor (Key a) where
fmap _ (Key t) = Key t
instance IsString (Key a b) where
fromString = Key . fromString
instance ToGreskell (Key a b) where
type GreskellReturn (Key a b) = Text
toGreskell = string . unKey
instance PMapKey (Key a b) where
type PMapValue (Key a b) = b
keyText (Key t) = t
key :: Text -> Key a b
key = Key
unsafeCastKey :: Key a1 b1 -> Key a2 b2
unsafeCastKey = Key . unKey
data KeyValue a where
KeyValue :: Key a b -> Greskell b -> KeyValue a
KeyNoValue :: Key a b -> KeyValue a
(=:) :: Key a b -> Greskell b -> KeyValue a
(=:) = KeyValue
data Keys a where
KeysNil :: Keys a
KeysCons :: Key a b -> Keys a -> Keys a
instance Semigroup (Keys a) where
a <> b =
case a of
KeysNil -> b
KeysCons x rest -> KeysCons x (rest <> b)
instance Monoid (Keys a) where
mempty = KeysNil
mappend = (<>)
singletonKeys :: Key a b -> Keys a
singletonKeys k = KeysCons k KeysNil
(-:) :: Key a b -> Keys a -> Keys a
(-:) = KeysCons
infixr 5 -:
data AVertex =
AVertex
{ avId :: ElementID AVertex,
avLabel :: Text
}
deriving (Show,Eq)
instance ElementData AVertex where
elementId = avId
elementLabel = avLabel
instance Element AVertex where
type ElementProperty AVertex = AVertexProperty
type ElementPropertyContainer AVertex = Multi
instance Vertex AVertex
instance GraphSONTyped AVertex where
gsonTypeFor _ = "g:Vertex"
instance FromJSON AVertex where
parseJSON = parseJSONViaGValue
instance FromGraphSON AVertex where
parseGraphSON gv = case gValueBody gv of
GObject o -> AVertex
<$> (o .: "id")
<*> (o .: "label")
_ -> empty
data AEdge =
AEdge
{ aeId :: ElementID AEdge,
aeLabel :: Text
}
deriving (Show,Eq)
instance ElementData AEdge where
elementId = aeId
elementLabel = aeLabel
instance Element AEdge where
type ElementProperty AEdge = AProperty
type ElementPropertyContainer AEdge = Single
instance Edge AEdge
instance GraphSONTyped AEdge where
gsonTypeFor _ = "g:Edge"
instance FromJSON AEdge where
parseJSON = parseJSONViaGValue
instance FromGraphSON AEdge where
parseGraphSON gv = case gValueBody gv of
GObject o -> AEdge
<$> (o .: "id")
<*> (o .: "label")
_ -> empty
data AProperty v =
AProperty
{ apKey :: Text,
apValue :: v
}
deriving (Show,Eq,Ord)
instance FromGraphSON v => FromJSON (AProperty v) where
parseJSON = parseJSONViaGValue
instance FromGraphSON v => FromGraphSON (AProperty v) where
parseGraphSON gv = case gValueBody gv of
GObject o -> AProperty <$> (o .: "key") <*> (o .: "value")
_ -> empty
instance Property AProperty where
propertyKey = apKey
propertyValue = apValue
instance GraphSONTyped (AProperty v) where
gsonTypeFor _ = "g:Property"
instance Functor AProperty where
fmap f sp = sp { apValue = f $ apValue sp }
instance Foldable AProperty where
foldr f start sp = f (apValue sp) start
instance Traversable AProperty where
traverse f sp = fmap (\v -> sp { apValue = v } ) $ f $ apValue sp
data AVertexProperty v =
AVertexProperty
{ avpId :: ElementID (AVertexProperty v),
avpLabel :: Text,
avpValue :: v
}
deriving (Show,Eq)
instance FromGraphSON v => FromJSON (AVertexProperty v) where
parseJSON = parseJSONViaGValue
instance FromGraphSON v => FromGraphSON (AVertexProperty v) where
parseGraphSON gv = case gValueBody gv of
GObject o -> AVertexProperty
<$> (o .: "id")
<*> (o .: "label")
<*> (o .: "value")
_ -> empty
instance GraphSONTyped (AVertexProperty v) where
gsonTypeFor _ = "g:VertexProperty"
instance ElementData (AVertexProperty v) where
elementId = avpId
elementLabel = avpLabel
instance Element (AVertexProperty v) where
type ElementProperty (AVertexProperty v) = AProperty
type ElementPropertyContainer (AVertexProperty v) = Single
instance Property AVertexProperty where
propertyKey = avpLabel
propertyValue = avpValue
instance Functor AVertexProperty where
fmap f vp = vp { avpValue = f $ avpValue vp,
avpId = unsafeCastElementID $ avpId vp
}
instance Foldable AVertexProperty where
foldr f start vp = f (avpValue vp) start
instance Traversable AVertexProperty where
traverse f vp = fmap setValue $ f $ avpValue vp
where
setValue v = vp { avpValue = v, avpId = unsafeCastElementID $ avpId vp }
newtype Path a = Path { unPath :: [PathEntry a] }
deriving (Show,Eq,Ord,Functor,Foldable,Traversable,Semigroup,Monoid)
instance GraphSONTyped (Path a) where
gsonTypeFor _ = "g:Path"
instance AsIterator (Path a) where
type IteratorItem (Path a) = a
instance FromGraphSON a => FromJSON (Path a) where
parseJSON = parseJSONViaGValue
instance FromGraphSON a => FromGraphSON (Path a) where
parseGraphSON gv =
case gValueBody gv of
GObject o -> parseObj o
_ -> empty
where
parseObj o = do
labels <- o .: "labels"
objects <- o .: "objects"
let nlabels = length labels
nobjects = length objects
when (nlabels /= nobjects) $ do
fail ( "Different number of labels and objects: "
<> show nlabels <> " labels, "
<> show nobjects <> " objects."
)
return $ Path $ map (uncurry PathEntry) $ zip (map (HS.map AsLabel) labels) objects
data PathEntry a =
PathEntry
{ peLabels :: HashSet (AsLabel a),
peObject :: a
}
deriving (Show,Eq,Ord)
instance Functor PathEntry where
fmap f pe = PathEntry { peLabels = HS.map (fmap f) $ peLabels pe,
peObject = f $ peObject pe
}
instance Foldable PathEntry where
foldr f acc pe = f (peObject pe) acc
instance Traversable PathEntry where
traverse f pe = fmap mkPE $ f $ peObject pe
where
mkPE obj =
PathEntry { peLabels = HS.map unsafeCastAsLabel $ peLabels pe,
peObject = obj
}
pathToPMap :: Path a -> PMap Multi a
pathToPMap (Path entries) = foldr fentry mempty entries
where
fentry entry pm = foldr (flabel $ peObject entry) pm $ peLabels entry
flabel obj label pm = pMapInsert (unAsLabel label) obj pm
makePathEntry :: [AsLabel a]
-> a
-> PathEntry a
makePathEntry ls obj = PathEntry (HS.fromList ls) obj