module Data.Greskell.Graph
(
Element(..),
Vertex,
Edge(..),
Property(..),
T,
tId,
tKey,
tLabel,
tValue,
Key(..),
key,
AVertex(..),
AEdge(..),
AVertexProperty(..),
AProperty(..),
PropertyMap(..),
PropertyMapSingle,
PropertyMapList,
lookupOneValue,
lookupListValues,
parseOneValue,
parseListValues,
parseNonEmptyValues,
fromProperties,
FromJSONWithKey
) where
import Control.Applicative (empty, (<$>), (<*>), (<|>))
import Data.Aeson (Value(..), FromJSON(..), (.:), (.:?), Object)
import Data.Aeson.Types (Parser)
import Data.Foldable (toList, Foldable(foldr), foldlM)
import qualified Data.HashMap.Lazy 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.Greskell.GraphSON (GraphSON(..), GraphSONTyped(..), parseTypedGraphSON)
import Data.Greskell.Greskell
( Greskell, unsafeGreskellLazy, string,
ToGreskell(..)
)
class Element e where
type ElementID e
type ElementProperty e :: * -> *
class (Element v) => Vertex v
class (Element e) => Edge e where
type EdgeVertexID 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"
newtype Key a b = Key { unKey :: Greskell 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 = unKey
key :: Text -> Key a b
key = Key . string
data AVertex =
AVertex
{ avId :: GraphSON Value,
avLabel :: Text,
avProperties :: PropertyMapList AVertexProperty (GraphSON Value)
}
deriving (Show,Eq)
instance Element AVertex where
type ElementID AVertex = Value
type ElementProperty AVertex = AVertexProperty
instance Vertex AVertex
instance GraphSONTyped AVertex where
gsonTypeFor _ = "g:Vertex"
instance FromJSON AVertex where
parseJSON (Object o) = AVertex
<$> (o .: "id")
<*> (o .: "label")
<*> (o `optionalMonoid` "properties")
parseJSON _ = empty
data AEdge =
AEdge
{ aeId :: GraphSON Value,
aeLabel :: Text,
aeInVLabel :: Text,
aeOutVLabel :: Text,
aeInV :: GraphSON Value,
aeOutV :: GraphSON Value,
aeProperties :: PropertyMapSingle AProperty (GraphSON Value)
}
deriving (Show,Eq)
instance Element AEdge where
type ElementID AEdge = Value
type ElementProperty AEdge = AProperty
instance Edge AEdge where
type EdgeVertexID AEdge = Value
instance GraphSONTyped AEdge where
gsonTypeFor _ = "g:Edge"
instance FromJSON AEdge where
parseJSON (Object o) =
AEdge
<$> (o .: "id")
<*> (o .: "label")
<*> (o .: "inVLabel")
<*> (o .: "outVLabel")
<*> (o .: "inV")
<*> (o .: "outV")
<*> (o `optionalMonoid` "properties")
parseJSON _ = empty
optionalMonoid :: (Monoid m, FromJSON m) => Object -> Text -> Parser m
optionalMonoid obj field_name = fmap (maybe mempty id) (obj .:? field_name)
class FromJSONWithKey a where
parseJSONWithKey :: Text -> Value -> Parser a
data AProperty v =
AProperty
{ apKey :: Text,
apValue :: v
}
deriving (Show,Eq,Ord)
instance FromJSON v => FromJSON (AProperty v) where
parseJSON (Object o) =
AProperty <$> (o .: "key") <*> (o .: "value")
parseJSON _ = empty
instance FromJSON v => FromJSONWithKey (AProperty v) where
parseJSONWithKey k v = AProperty k <$> parseJSON v
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 :: GraphSON Value,
avpLabel :: Text,
avpValue :: v,
avpProperties :: PropertyMapSingle AProperty (GraphSON Value)
}
deriving (Show,Eq)
instance FromJSON v => FromJSON (AVertexProperty v) where
parseJSON v@(Object o) = do
label <- o .: "label"
parseJSONWithKey label v
parseJSON _ = empty
instance FromJSON v => FromJSONWithKey (AVertexProperty v) where
parseJSONWithKey k (Object o) = AVertexProperty
<$> (o .: "id")
<*> pure k
<*> (o .: "value")
<*> (o `optionalMonoid` "properties")
parseJSONWithKey _ _ = empty
instance GraphSONTyped (AVertexProperty v) where
gsonTypeFor _ = "g:VertexProperty"
instance Element (AVertexProperty v) where
type ElementID (AVertexProperty v) = Value
type ElementProperty (AVertexProperty v) = AProperty
instance Property AVertexProperty where
propertyKey = avpLabel
propertyValue = avpValue
instance Functor AVertexProperty where
fmap f vp = vp { avpValue = f $ avpValue vp }
instance Foldable AVertexProperty where
foldr f start vp = f (avpValue vp) start
instance Traversable AVertexProperty where
traverse f vp = fmap (\v -> vp { avpValue = v }) $ f $ avpValue vp
class PropertyMap m where
lookupOne :: Text -> m p v -> Maybe (p v)
lookupOne k m = listToMaybe $ lookupList k m
lookupList :: Text -> m p v -> [p v]
putProperty :: Property p => p v -> m p v -> m p v
removeProperty :: Text -> m p v -> m p v
allProperties :: m p v -> [p v]
lookupOneValue :: (PropertyMap m, Property p) => Text -> m p v -> Maybe v
lookupOneValue k = fmap propertyValue . lookupOne k
lookupListValues :: (PropertyMap m, Property p) => Text -> m p v -> [v]
lookupListValues k = fmap propertyValue . lookupList k
notExistErrorMsg :: Text -> String
notExistErrorMsg k = "Property '" ++ unpack k ++ "' does not exist."
parseOneValue :: (PropertyMap m, Property p, FromJSON v) => Text -> m p (GraphSON Value) -> Parser v
parseOneValue k pm = maybe (fail err_msg) (parseJSON . gsonValue) $ lookupOneValue k pm
where
err_msg = notExistErrorMsg k
parseListValues :: (PropertyMap m, Property p, FromJSON v) => Text -> m p (GraphSON Value) -> Parser [v]
parseListValues k pm = mapM (parseJSON . gsonValue) $ lookupListValues k pm
parseNonEmptyValues :: (PropertyMap m, Property p, FromJSON v) => Text -> m p (GraphSON Value) -> Parser (NonEmpty v)
parseNonEmptyValues k pm = toNonEmpty =<< parseListValues k pm
where
toNonEmpty [] = fail $ notExistErrorMsg k
toNonEmpty (x : rest) = return (x :| rest)
fromProperties :: (PropertyMap m, Property p, Monoid (m p v))
=> [p v]
-> m p v
fromProperties = foldr putProperty mempty
newtype PropertyMapGeneric t p v = PropertyMapGeneric (HM.HashMap Text (t (p v)))
deriving (Show,Eq)
instance Semigroup (t (p v)) => Monoid (PropertyMapGeneric t p v) where
mempty = PropertyMapGeneric mempty
mappend (PropertyMapGeneric a) (PropertyMapGeneric b) =
PropertyMapGeneric $ HM.unionWith (<>) a b
instance (Functor t, Functor p) => Functor (PropertyMapGeneric t p) where
fmap f (PropertyMapGeneric hm) = PropertyMapGeneric $ (fmap . fmap . fmap) f hm
instance (Foldable t, Foldable p) => Foldable (PropertyMapGeneric t p) where
foldr f start (PropertyMapGeneric hm) = foldr f2 start hm
where
f2 t start2 = foldr f3 start2 t
f3 p start3 = foldr f start3 p
instance (Traversable t, Traversable p) => Traversable (PropertyMapGeneric t p) where
traverse f (PropertyMapGeneric hm) = fmap PropertyMapGeneric $ (traverse . traverse . traverse) f hm
putPropertyGeneric :: (Semigroup (t (p v)), Applicative t, Property p) => p v -> PropertyMapGeneric t p v -> PropertyMapGeneric t p v
putPropertyGeneric prop (PropertyMapGeneric hm) =
PropertyMapGeneric $ HM.insertWith (<>) (propertyKey prop) (pure prop) hm
removePropertyGeneric :: Text -> PropertyMapGeneric t p v -> PropertyMapGeneric t p v
removePropertyGeneric k (PropertyMapGeneric hm) = PropertyMapGeneric $ HM.delete k hm
allPropertiesGeneric :: Foldable t => PropertyMapGeneric t p v -> [p v]
allPropertiesGeneric (PropertyMapGeneric hm) = concat $ map toList $ HM.elems hm
parsePropertiesGeneric :: (Property p, PropertyMap m, Monoid (m p v), GraphSONTyped (p v), FromJSON (p v), FromJSONWithKey (p v))
=> (Value -> Parser [Value])
-> Value
-> Parser (m p v)
parsePropertiesGeneric normalizeCardinality (Object obj) = foldlM folder mempty $ HM.toList obj
where
folder pm (k, value) = fmap (foldr putProperty pm) $ traverse (parseProperty k) =<< normalizeCardinality value
parseProperty k value = (fmap gsonValue $ parseTypedGraphSON value) <|> parseJSONWithKey k value
parsePropertiesGeneric _ _ = empty
expectAesonArray :: Value -> Parser [Value]
expectAesonArray (Array a) = return $ toList a
expectAesonArray _ = empty
newtype PropertyMapSingle p v = PropertyMapSingle (PropertyMapGeneric Semigroup.First p v)
deriving (Show,Eq,Monoid,Functor,Foldable,Traversable)
instance PropertyMap PropertyMapSingle where
lookupOne k (PropertyMapSingle (PropertyMapGeneric hm)) = fmap Semigroup.getFirst $ HM.lookup k hm
lookupList k m = maybe [] return $ lookupOne k m
putProperty p (PropertyMapSingle pg) = PropertyMapSingle $ putPropertyGeneric p pg
removeProperty t (PropertyMapSingle pg) = PropertyMapSingle $ removePropertyGeneric t pg
allProperties (PropertyMapSingle pg) = allPropertiesGeneric pg
instance (Property p, GraphSONTyped (p v), FromJSON (p v), FromJSONWithKey (p v))
=> FromJSON (PropertyMapSingle p v) where
parseJSON = parsePropertiesGeneric (return . return)
newtype PropertyMapList p v = PropertyMapList (PropertyMapGeneric NonEmpty p v)
deriving (Show,Eq,Monoid,Functor,Foldable,Traversable)
instance PropertyMap PropertyMapList where
lookupList k (PropertyMapList (PropertyMapGeneric hm)) = maybe [] NL.toList $ HM.lookup k hm
putProperty p (PropertyMapList pg) = PropertyMapList $ putPropertyGeneric p pg
removeProperty t (PropertyMapList pg) = PropertyMapList $ removePropertyGeneric t pg
allProperties (PropertyMapList pg) = allPropertiesGeneric pg
instance (Property p, GraphSONTyped (p v), FromJSON (p v), FromJSONWithKey (p v))
=> FromJSON (PropertyMapList p v) where
parseJSON v = parsePropertiesGeneric expectAesonArray v