{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveTraversable, OverloadedStrings #-}
module Data.Greskell.Graph.PropertyMap {-# DEPRECATED "Use PMap instead" #-}
(
PropertyMap(..),
PropertyMapSingle,
PropertyMapList,
lookupOneValue,
lookupListValues,
parseOneValue,
parseListValues,
parseNonEmptyValues,
fromProperties,
FromGraphSONWithKey,
AProperty(..),
AVertexProperty(..)
) where
import Control.Applicative (empty, (<|>))
import Data.Aeson (FromJSON(..))
import Data.Aeson.Types (Parser)
import Data.Foldable (Foldable(..), foldlM)
import Data.Greskell.GraphSON
( FromGraphSON(..), GValue, GraphSONTyped(..), (.:),
parseJSONViaGValue
)
import Data.Greskell.GraphSON.GValue (gValueBody, gValueType, GValueBody(..))
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.Text (Text, unpack)
import Data.Traversable (Traversable(..))
import Data.Vector (Vector)
import Data.Greskell.Graph (Property(..), AProperty(..), AVertexProperty(..))
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
class FromGraphSONWithKey a where
parseGraphSONWithKey :: Text -> GValue -> Parser a
instance FromGraphSON v => FromGraphSONWithKey (AProperty v) where
parseGraphSONWithKey k v = AProperty k <$> parseGraphSON v
instance FromGraphSON v => FromGraphSONWithKey (AVertexProperty v) where
parseGraphSONWithKey k gv = case gValueBody gv of
GObject o -> AVertexProperty
<$> (o .: "id")
<*> pure k
<*> (o .: "value")
_ -> empty