{-# LANGUAGE TypeFamilies, OverloadedStrings, FlexibleInstances, GeneralizedNewtypeDeriving, DeriveTraversable, GADTs #-}
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
module Data.Greskell.Graph
(
Element(..),
Vertex,
Edge(..),
Property(..),
T,
tId,
tKey,
tLabel,
tValue,
Cardinality,
cList,
cSet,
cSingle,
Key(..),
key,
KeyValue(..),
(=:),
AVertex(..),
AEdge(..),
AVertexProperty(..),
AProperty(..),
PropertyMap(..),
PropertyMapSingle,
PropertyMapList,
lookupOneValue,
lookupListValues,
parseOneValue,
parseListValues,
parseNonEmptyValues,
fromProperties,
FromGraphSONWithKey
) where
import Control.Applicative (empty, (<$>), (<*>), (<|>))
import Data.Aeson (Value(..), FromJSON(..))
import Data.Aeson.Types (Parser)
import Data.Foldable (toList, Foldable(foldr), foldlM)
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 Data.Greskell.GraphSON
( GraphSON(..), GraphSONTyped(..), FromGraphSON(..),
(.:), GValue, GValueBody(..),
parseJSONViaGValue
)
import Data.Greskell.GraphSON.GValue (gValueBody, gValueType)
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"
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 :: 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 KeyValue a where
KeyValue :: Key a b -> Greskell b -> KeyValue a
(=:) :: Key a b -> Greskell b -> KeyValue a
(=:) = KeyValue
data AVertex =
AVertex
{ avId :: GValue,
avLabel :: Text,
avProperties :: PropertyMapList AVertexProperty GValue
}
deriving (Show,Eq)
instance Element AVertex where
type ElementID AVertex = GValue
type ElementProperty AVertex = AVertexProperty
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")
<*> (o `optionalMonoid` "properties")
_ -> empty
data AEdge =
AEdge
{ aeId :: GValue,
aeLabel :: Text,
aeInVLabel :: Text,
aeOutVLabel :: Text,
aeInV :: GValue,
aeOutV :: GValue,
aeProperties :: PropertyMapSingle AProperty GValue
}
deriving (Show,Eq)
instance Element AEdge where
type ElementID AEdge = GValue
type ElementProperty AEdge = AProperty
instance Edge AEdge where
type EdgeVertexID AEdge = GValue
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")
<*> (o .: "inVLabel")
<*> (o .: "outVLabel")
<*> (o .: "inV")
<*> (o .: "outV")
<*> (o `optionalMonoid` "properties")
_ -> empty
optionalMonoid :: (Monoid m, FromGraphSON m) => HM.HashMap Text GValue -> Text -> Parser m
optionalMonoid obj field_name = maybe (return mempty) parseGraphSON $ nullToNothing =<< HM.lookup field_name obj
where
nullToNothing gv = case gValueBody gv of
GNull -> Nothing
_ -> Just gv
class FromGraphSONWithKey a where
parseGraphSONWithKey :: Text -> GValue -> Parser a
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 FromGraphSON v => FromGraphSONWithKey (AProperty v) where
parseGraphSONWithKey k v = AProperty k <$> parseGraphSON 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 :: GValue,
avpLabel :: Text,
avpValue :: v,
avpProperties :: PropertyMapSingle AProperty GValue
}
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 -> do
label <- o .: "label"
parseGraphSONWithKey label gv
_ -> empty
instance FromGraphSON v => FromGraphSONWithKey (AVertexProperty v) where
parseGraphSONWithKey k gv = case gValueBody gv of
GObject o -> AVertexProperty
<$> (o .: "id")
<*> pure k
<*> (o .: "value")
<*> (o `optionalMonoid` "properties")
_ -> empty
instance GraphSONTyped (AVertexProperty v) where
gsonTypeFor _ = "g:VertexProperty"
instance Element (AVertexProperty v) where
type ElementID (AVertexProperty v) = GValue
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, FromGraphSON v) => Text -> m p GValue -> Parser v
parseOneValue k pm = maybe (fail err_msg) parseGraphSON $ lookupOneValue k pm
where
err_msg = notExistErrorMsg k
parseListValues :: (PropertyMap m, Property p, FromGraphSON v) => Text -> m p GValue -> Parser [v]
parseListValues k pm = mapM parseGraphSON $ lookupListValues k pm
parseNonEmptyValues :: (PropertyMap m, Property p, FromGraphSON v) => Text -> m p GValue -> 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)) => Semigroup (PropertyMapGeneric t p v) where
(PropertyMapGeneric a) <> (PropertyMapGeneric b) = PropertyMapGeneric $ HM.unionWith (<>) a b
instance Semigroup (t (p v)) => Monoid (PropertyMapGeneric t p v) where
mempty = PropertyMapGeneric mempty
mappend = (<>)
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), FromGraphSON (p v), FromGraphSONWithKey (p v))
=> (GValue -> Parser (Vector GValue))
-> GValue
-> Parser (m p v)
parsePropertiesGeneric normalizeCardinality gv = case gValueBody gv of
GObject obj -> foldlM folder mempty $ HM.toList obj
_ -> empty
where
folder pm (k, value) = fmap (foldr putProperty pm) $ traverse (parseProperty k) =<< normalizeCardinality value
parseProperty k value = parseTypedGValue value <|> parseGraphSONWithKey k value
parseTypedGValue :: (GraphSONTyped v, FromGraphSON v) => GValue -> Parser v
parseTypedGValue gv = do
prop <- parseGraphSON gv
let exp_type = gsonTypeFor prop
mgot_type = gValueType gv
if mgot_type /= Just exp_type
then fail ("Expected @type field of " ++ unpack exp_type ++ ", but got " ++ show mgot_type)
else return prop
expectAesonArray :: GValue -> Parser (Vector GValue)
expectAesonArray gv = case gValueBody gv of
GArray a -> return a
_ -> empty
newtype PropertyMapSingle p v = PropertyMapSingle (PropertyMapGeneric Semigroup.First p v)
deriving (Show,Eq,Semigroup,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), FromGraphSON (p v), FromGraphSONWithKey (p v))
=> FromJSON (PropertyMapSingle p v) where
parseJSON = parseJSONViaGValue
instance (Property p, GraphSONTyped (p v), FromGraphSON (p v), FromGraphSONWithKey (p v))
=> FromGraphSON (PropertyMapSingle p v) where
parseGraphSON = parsePropertiesGeneric (return . return)
newtype PropertyMapList p v = PropertyMapList (PropertyMapGeneric NonEmpty p v)
deriving (Show,Eq,Semigroup,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), FromGraphSON (p v), FromGraphSONWithKey (p v))
=> FromJSON (PropertyMapList p v) where
parseJSON = parseJSONViaGValue
instance (Property p, GraphSONTyped (p v), FromGraphSON (p v), FromGraphSONWithKey (p v))
=> FromGraphSON (PropertyMapList p v) where
parseGraphSON v = parsePropertiesGeneric expectAesonArray v