{-# LANGUAGE TypeFamilies, OverloadedStrings, GeneralizedNewtypeDeriving, DeriveTraversable #-}
module Data.Greskell.GMap
(
FlattenedMap(..),
parseToFlattenedMap,
GMap(..),
unGMap,
singleton,
toList,
parseToGMap,
GMapEntry(..),
unGMapEntry,
parseToGMapEntry
) where
import Control.Applicative ((<$>), (<*>), (<|>), empty)
import Data.Aeson
( FromJSON(..), ToJSON(..), Value(..),
FromJSONKey, fromJSONKey, FromJSONKeyFunction(..), ToJSONKey
)
import Data.Aeson.Types (Parser)
import Data.Foldable (length, Foldable)
import Data.Hashable (Hashable)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HM
import qualified Data.Map as M
import Data.Text (Text, intercalate, unpack)
import Data.Traversable (Traversable, traverse)
import Data.Vector ((!), Vector)
import qualified Data.Vector as V
import GHC.Exts (IsList(Item))
import qualified GHC.Exts as List (IsList(fromList, toList))
import Unsafe.Coerce (unsafeCoerce)
import Data.Greskell.GraphSON.GraphSONTyped (GraphSONTyped(..))
newtype FlattenedMap c k v = FlattenedMap { unFlattenedMap :: c k v }
deriving (Show,Eq,Ord,Foldable,Traversable,Functor)
instance (FromJSON k, FromJSON v, IsList (c k v), Item (c k v) ~ (k,v)) => FromJSON (FlattenedMap c k v) where
parseJSON (Array v) = parseToFlattenedMap parseJSON parseJSON v
parseJSON v = fail ("Expects Array, but got " ++ show v)
parseToAVec :: (s -> Parser k) -> (s -> Parser v) -> Vector s -> Parser (Vector (k,v))
parseToAVec parseKey parseValue v =
if odd vlen
then fail "Fail to parse a list into an associative list because there are odd number of elements."
else traverse parsePair pairVec
where
vlen = length v
pairVec = fmap (\i -> (v ! (i * 2), v ! (i * 2 + 1))) $ V.fromList [0 .. ((vlen `div` 2) - 1)]
parsePair (vk, vv) = (,) <$> parseKey vk <*> parseValue vv
parseToFlattenedMap :: (IsList (c k v), Item (c k v) ~ (k,v))
=> (s -> Parser k)
-> (s -> Parser v)
-> Vector s
-> Parser (FlattenedMap c k v)
parseToFlattenedMap parseKey parseValue v =
fmap (FlattenedMap . List.fromList . V.toList) $ parseToAVec parseKey parseValue v
instance (ToJSON k, ToJSON v, IsList (c k v), Item (c k v) ~ (k,v)) => ToJSON (FlattenedMap c k v) where
toJSON (FlattenedMap m) = toJSON $ flatten $ map toValuePair $ List.toList m
where
toValuePair (k, v) = (toJSON k, toJSON v)
flatten pl = (\(k, v) -> [k, v]) =<< pl
instance GraphSONTyped (FlattenedMap c k v) where
gsonTypeFor _ = "g:Map"
data GMap c k v =
GMap
{ gmapFlat :: !Bool,
gmapValue :: !(c k v)
}
deriving (Show,Eq,Foldable,Traversable,Functor)
parseToGMap :: (IsList (c k v), Item (c k v) ~ (k,v))
=> (s -> Parser k)
-> (s -> Parser v)
-> (HashMap Text s -> Parser (c k v))
-> Either (HashMap Text s) (Vector s)
-> Parser (GMap c k v)
parseToGMap _ _ op (Left o) = fmap (GMap False) $ op o
parseToGMap kp vp _ (Right v) = fmap (GMap True . unFlattenedMap) $ parseToFlattenedMap kp vp v
instance (FromJSON k, FromJSON v, IsList (c k v), Item (c k v) ~ (k,v), FromJSON (c k v)) => FromJSON (GMap c k v) where
parseJSON v = case v of
Object o -> parse $ Left o
Array a -> parse $ Right a
other -> fail ("Expects Object or Array, but got " ++ show other)
where
parse = parseToGMap parseJSON parseJSON (parseJSON . Object)
instance (ToJSON k, ToJSON v, IsList (c k v), Item (c k v) ~ (k,v), ToJSON (c k v)) => ToJSON (GMap c k v) where
toJSON gm = if gmapFlat gm
then toJSON $ FlattenedMap $ unGMap gm
else toJSON $ unGMap gm
instance GraphSONTyped (GMap c k v) where
gsonTypeFor _ = "g:Map"
unGMap :: GMap c k v -> c k v
unGMap = gmapValue
data GMapEntry k v =
GMapEntry
{ gmapEntryFlat :: !Bool,
gmapEntryKey :: !k,
gmapEntryValue :: !v
}
deriving (Show,Eq,Ord,Foldable,Traversable,Functor)
parseKeyValueToEntry :: (s -> Parser k)
-> (s -> Parser v)
-> HashMap Text s
-> Parser (Maybe (GMapEntry k v))
parseKeyValueToEntry kp vp o =
if length o /= 2
then return Nothing
else do
mk <- parseIfPresent kp $ HM.lookup "key" o
mv <- parseIfPresent vp $ HM.lookup "value" o
return $ GMapEntry False <$> mk <*> mv
where
parseIfPresent :: (a -> Parser v) -> Maybe a -> Parser (Maybe v)
parseIfPresent f = maybe (return Nothing) (fmap Just . f)
parseSingleEntryObjectToEntry :: FromJSONKey k
=> (s -> Parser v)
-> HashMap Text s
-> Parser (Maybe (GMapEntry k v))
parseSingleEntryObjectToEntry vp o =
case HM.toList o of
[(raw_key, raw_val)] -> do
key <- parseKey raw_key
val <- vp raw_val
return $ Just $ GMapEntry False key val
_ -> return Nothing
where
parseKey k = do
p <- getParser
p k
getParser = case fromJSONKey of
FromJSONKeyText p -> return $ fmap return p
FromJSONKeyTextParser p -> return p
FromJSONKeyCoerce _ -> return $ fmap return unsafeCoerce
FromJSONKeyValue _ -> fail ( "Unexpected FromJSONKeyValue."
++ " It expects that the entry key is parsed from the text key in JSON Object,"
++ " but the key type does not support it."
)
orElseM :: Monad m => m (Maybe a) -> m (Maybe a) -> m (Maybe a)
orElseM act_a act_b = do
ma <- act_a
case ma of
Just a -> return $ Just a
Nothing -> act_b
parseToGMapEntry :: FromJSONKey k
=> (s -> Parser k)
-> (s -> Parser v)
-> Either (HashMap Text s) (Vector s)
-> Parser (GMapEntry k v)
parseToGMapEntry kp vp (Right vec) = do
avec <- parseToAVec kp vp vec
case V.toList avec of
[(key, val)] -> return $ GMapEntry True key val
_ -> fail ("Expects a single entry of key-value pair, but got " ++ (show $ V.length avec) ++ " entries.")
parseToGMapEntry kp vp (Left o) = do
m_ret <- parseKeyValueToEntry kp vp o `orElseM` parseSingleEntryObjectToEntry vp o
case m_ret of
Just ret -> return ret
Nothing -> fail ("Unexpected structure of Object: got keys: " ++ (unpack $ intercalate ", " $ HM.keys o))
instance GraphSONTyped (GMapEntry k v) where
gsonTypeFor _ = "g:Map"
instance (FromJSON k, FromJSONKey k, FromJSON v) => FromJSON (GMapEntry k v) where
parseJSON val = case val of
Object o -> parse $ Left o
Array a -> parse $ Right a
other -> fail ("Expects Object or Array, but got " ++ show other)
where
parse = parseToGMapEntry parseJSON parseJSON
instance (ToJSON k, ToJSONKey k, Ord k, ToJSON v) => ToJSON (GMapEntry k v) where
toJSON e = toJSON $ singleton' e
where
singleton' :: (Ord k) => GMapEntry k v -> GMap M.Map k v
singleton' = singleton
unGMapEntry :: GMapEntry k v -> (k, v)
unGMapEntry e = (gmapEntryKey e, gmapEntryValue e)
singleton :: (IsList (c k v), Item (c k v) ~ (k,v)) => GMapEntry k v -> GMap c k v
singleton e = GMap { gmapFlat = gmapEntryFlat e,
gmapValue = List.fromList [(gmapEntryKey e, gmapEntryValue e)]
}
toList :: (IsList (c k v), Item (c k v) ~ (k,v)) => GMap c k v -> [GMapEntry k v]
toList gm = map toEntry $ List.toList $ gmapValue gm
where
toEntry (k, v) = GMapEntry (gmapFlat gm) k v