{-# LANGUAGE OverloadedStrings, DeriveGeneric, TypeFamilies #-}
module Data.Greskell.GraphSON
(
GraphSON(..),
GraphSONTyped(..),
nonTypedGraphSON,
typedGraphSON,
typedGraphSON',
parseTypedGraphSON,
GValue,
GValueBody(..),
nonTypedGValue,
typedGValue',
FromGraphSON(..),
Parser,
parseEither,
parseUnwrapAll,
parseUnwrapList,
(.:),
parseJSONViaGValue
) where
import Control.Applicative ((<$>), (<*>), (<|>))
import Control.Monad (when)
import Data.Aeson
( ToJSON(toJSON), FromJSON(parseJSON), FromJSONKey,
object, (.=), Value(..)
)
import qualified Data.Aeson as Aeson
import Data.Aeson.Types (Parser)
import qualified Data.Aeson.Types as Aeson (parseEither)
import Data.Foldable (Foldable(foldr))
import Data.Functor.Identity (Identity(..))
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HM
import qualified Data.HashMap.Lazy as L (HashMap)
import Data.HashSet (HashSet)
import Data.Hashable (Hashable(..))
import Data.List.NonEmpty (NonEmpty(..))
import Data.Int (Int8, Int16, Int32, Int64)
import qualified Data.IntMap.Lazy as L (IntMap)
import qualified Data.IntMap.Lazy as LIntMap
import Data.IntSet (IntSet)
import qualified Data.Map.Lazy as L (Map)
import qualified Data.Map.Lazy as LMap
import Data.Monoid (mempty)
import qualified Data.Monoid as M
import Data.Ratio (Ratio)
import Data.Scientific (Scientific)
import qualified Data.Semigroup as S
import Data.Sequence (Seq)
import Data.Set (Set)
import Data.Text (Text, unpack)
import qualified Data.Text.Lazy as TL
import Data.Traversable (Traversable(traverse))
import Data.UUID (UUID)
import qualified Data.UUID as UUID
import Data.Vector (Vector)
import Data.Word (Word8, Word16, Word32, Word64)
import Numeric.Natural (Natural)
import GHC.Exts (IsList(Item))
import qualified GHC.Exts as List (fromList, toList)
import GHC.Generics (Generic)
import Data.Greskell.GMap
( GMap, GMapEntry, unGMap,
FlattenedMap, parseToFlattenedMap, parseToGMap, parseToGMapEntry
)
import Data.Greskell.GraphSON.Core
import Data.Greskell.GraphSON.GraphSONTyped (GraphSONTyped(..))
import Data.Greskell.GraphSON.GValue
class FromGraphSON a where
parseGraphSON :: GValue -> Parser a
parseUnwrapAll :: FromJSON a => GValue -> Parser a
parseUnwrapAll gv = parseJSON $ unwrapAll gv
parseUnwrapList :: (IsList a, i ~ Item a, FromGraphSON i) => GValue -> Parser a
parseUnwrapList (GValue (GraphSON _ (GArray v))) = fmap List.fromList $ traverse parseGraphSON $ List.toList v
parseUnwrapList (GValue (GraphSON _ body)) = fail ("Expects GArray, but got " ++ show body)
parseEither :: FromGraphSON a => GValue -> Either String a
parseEither = Aeson.parseEither parseGraphSON
(.:) :: FromGraphSON a => HashMap Text GValue -> Text -> Parser a
go .: label = maybe failure parseGraphSON $ HM.lookup label go
where
failure = fail ("Cannot find field " ++ unpack label)
parseJSONViaGValue :: FromGraphSON a => Value -> Parser a
parseJSONViaGValue v = parseGraphSON =<< parseJSON v
instance FromGraphSON GValue where
parseGraphSON = return
instance FromGraphSON Int where
parseGraphSON = parseUnwrapAll
instance FromGraphSON Text where
parseGraphSON = parseUnwrapAll
instance FromGraphSON TL.Text where
parseGraphSON = parseUnwrapAll
instance FromGraphSON Bool where
parseGraphSON = parseUnwrapAll
instance FromGraphSON Double where
parseGraphSON = parseUnwrapAll
instance FromGraphSON Float where
parseGraphSON = parseUnwrapAll
instance FromGraphSON Int8 where
parseGraphSON = parseUnwrapAll
instance FromGraphSON Int16 where
parseGraphSON = parseUnwrapAll
instance FromGraphSON Int32 where
parseGraphSON = parseUnwrapAll
instance FromGraphSON Int64 where
parseGraphSON = parseUnwrapAll
instance FromGraphSON Integer where
parseGraphSON = parseUnwrapAll
instance FromGraphSON Natural where
parseGraphSON = parseUnwrapAll
instance (FromJSON a, Integral a) => FromGraphSON (Ratio a) where
parseGraphSON = parseUnwrapAll
instance FromGraphSON Word where
parseGraphSON = parseUnwrapAll
instance FromGraphSON Word8 where
parseGraphSON = parseUnwrapAll
instance FromGraphSON Word16 where
parseGraphSON = parseUnwrapAll
instance FromGraphSON Word32 where
parseGraphSON = parseUnwrapAll
instance FromGraphSON Word64 where
parseGraphSON = parseUnwrapAll
instance FromGraphSON Scientific where
parseGraphSON = parseUnwrapAll
instance FromGraphSON IntSet where
parseGraphSON = parseUnwrapAll
instance FromGraphSON a => FromGraphSON [a] where
parseGraphSON = parseUnwrapList
instance FromGraphSON a => FromGraphSON (Vector a) where
parseGraphSON = parseUnwrapList
instance FromGraphSON a => FromGraphSON (Seq a) where
parseGraphSON = parseUnwrapList
instance FromGraphSON a => FromGraphSON (NonEmpty a) where
parseGraphSON gv = do
list <- parseGraphSON gv
case list of
[] -> fail ("Empty list.")
(a : rest) -> return (a :| rest)
instance (FromGraphSON a, Ord a) => FromGraphSON (Set a) where
parseGraphSON = parseUnwrapList
instance (FromGraphSON a, Eq a, Hashable a) => FromGraphSON (HashSet a) where
parseGraphSON = parseUnwrapList
instance FromGraphSON a => FromGraphSON (Identity a) where
parseGraphSON = fmap Identity . parseGraphSON
instance FromGraphSON a => FromGraphSON (S.Min a) where
parseGraphSON = fmap S.Min . parseGraphSON
instance FromGraphSON a => FromGraphSON (S.Max a) where
parseGraphSON = fmap S.Max . parseGraphSON
instance FromGraphSON a => FromGraphSON (S.First a) where
parseGraphSON = fmap S.First . parseGraphSON
instance FromGraphSON a => FromGraphSON (S.Last a) where
parseGraphSON = fmap S.Last . parseGraphSON
instance FromGraphSON a => FromGraphSON (S.WrappedMonoid a) where
parseGraphSON = fmap S.WrapMonoid . parseGraphSON
instance FromGraphSON a => FromGraphSON (S.Dual a) where
parseGraphSON = fmap S.Dual . parseGraphSON
instance FromGraphSON a => FromGraphSON (M.Sum a) where
parseGraphSON = fmap M.Sum . parseGraphSON
instance FromGraphSON a => FromGraphSON (M.Product a) where
parseGraphSON = fmap M.Product . parseGraphSON
instance FromGraphSON M.All where
parseGraphSON = fmap M.All . parseGraphSON
instance FromGraphSON M.Any where
parseGraphSON = fmap M.Any . parseGraphSON
instance (FromGraphSON k, FromGraphSON v, IsList (c k v), Item (c k v) ~ (k,v)) => FromGraphSON (FlattenedMap c k v) where
parseGraphSON gv = case gValueBody gv of
GArray a -> parseToFlattenedMap parseGraphSON parseGraphSON a
b -> fail ("Expects GArray, but got " ++ show b)
parseGObjectToTraversal :: (Traversable t, FromJSON (t GValue), FromGraphSON v)
=> HashMap Text GValue
-> Parser (t v)
parseGObjectToTraversal o = traverse parseGraphSON =<< (parseJSON $ Object $ fmap toJSON o)
instance (FromGraphSON k, FromGraphSON v, IsList (c k v), Item (c k v) ~ (k,v), Traversable (c k), FromJSON (c k GValue))
=> FromGraphSON (GMap c k v) where
parseGraphSON gv = case gValueBody gv of
GObject o -> parse $ Left o
GArray a -> parse $ Right a
other -> fail ("Expects GObject or GArray, but got " ++ show other)
where
parse = parseToGMap parseGraphSON parseGraphSON parseObject
parseObject = parseGObjectToTraversal
instance (FromGraphSON k, FromGraphSON v, FromJSONKey k) => FromGraphSON (GMapEntry k v) where
parseGraphSON val = case gValueBody val of
GObject o -> parse $ Left o
GArray a -> parse $ Right a
other -> fail ("Expects GObject or GArray, but got " ++ show other)
where
parse = parseToGMapEntry parseGraphSON parseGraphSON
instance (FromGraphSON v, Eq k, Hashable k, FromJSONKey k, FromGraphSON k) => FromGraphSON (L.HashMap k v) where
parseGraphSON = fmap unGMap . parseGraphSON
instance (FromGraphSON v, Ord k, FromJSONKey k, FromGraphSON k) => FromGraphSON (L.Map k v) where
parseGraphSON = fmap unGMap . parseGraphSON
instance FromGraphSON v => FromGraphSON (L.IntMap v) where
parseGraphSON = fmap (mapToIntMap . unGMap) . parseGraphSON
where
mapToIntMap :: L.Map Int v -> L.IntMap v
mapToIntMap = LMap.foldrWithKey LIntMap.insert mempty
instance FromGraphSON a => FromGraphSON (Maybe a) where
parseGraphSON (GValue (GraphSON _ GNull)) = return Nothing
parseGraphSON gv = fmap Just $ parseGraphSON gv
instance (FromGraphSON a, FromGraphSON b) => FromGraphSON (Either a b) where
parseGraphSON gv = (fmap Left $ parseGraphSON gv) <|> (fmap Right $ parseGraphSON gv)
instance FromGraphSON a => FromGraphSON (S.Option a) where
parseGraphSON = fmap S.Option . parseGraphSON
instance FromGraphSON a => FromGraphSON (M.First a) where
parseGraphSON = fmap M.First . parseGraphSON
instance FromGraphSON a => FromGraphSON (M.Last a) where
parseGraphSON = fmap M.Last . parseGraphSON
instance FromGraphSON Value where
parseGraphSON = return . unwrapAll
instance FromGraphSON UUID where
parseGraphSON gv = case gValueBody gv of
GString t -> maybe failure return $ UUID.fromText t
where
failure = fail ("Failed to parse into UUID: " ++ unpack t)
b -> fail ("Expected GString, but got " ++ show b)
instance FromGraphSON () where
parseGraphSON _ = return ()