{-# LANGUAGE OverloadedStrings, FlexibleInstances #-}
module NetSpider.GraphML.Attribute
( AttributeKey,
AttributeValue(..),
ToAttributes(..),
valueFromAeson,
attributesFromAeson,
attributesToAeson
) where
import Control.Applicative (empty)
import Data.Aeson (FromJSON(..), ToJSON(..))
import qualified Data.Aeson as Aeson
import qualified Data.HashMap.Strict as HM
import qualified Data.Scientific as Sci
import Data.Text (Text, pack)
import Data.Time (TimeZone(..))
type AttributeKey = Text
data AttributeValue = AttrBoolean Bool
| AttrInt Int
| AttrLong Integer
| AttrFloat Float
| AttrDouble Double
| AttrString Text
deriving (Show,Eq,Ord)
instance FromJSON AttributeValue where
parseJSON v = maybe empty return $ valueFromAeson v
instance ToJSON AttributeValue where
toJSON v =
case v of
AttrBoolean b -> toJSON b
AttrInt i -> toJSON i
AttrLong l -> toJSON l
AttrFloat f -> toJSON f
AttrDouble d -> toJSON d
AttrString t -> toJSON t
class ToAttributes a where
toAttributes :: a -> [(AttributeKey, AttributeValue)]
instance ToAttributes () where
toAttributes _ = []
instance ToAttributes [(AttributeKey, AttributeValue)] where
toAttributes = id
instance ToAttributes a => ToAttributes (Maybe a) where
toAttributes Nothing = []
toAttributes (Just a) = toAttributes a
instance ToAttributes TimeZone where
toAttributes tz =
[ ("@tz_offset_min", AttrInt $ timeZoneMinutes tz),
("@tz_summer_only", AttrBoolean $ timeZoneSummerOnly tz),
("@tz_name", AttrString $ pack $ timeZoneName tz)
]
valueFromAeson :: Aeson.Value -> Maybe AttributeValue
valueFromAeson v =
case v of
Aeson.String t -> Just $ AttrString t
Aeson.Bool b -> Just $ AttrBoolean b
Aeson.Number n -> Just $ AttrDouble $ Sci.toRealFloat n
_ -> Nothing
attributesFromAeson :: Aeson.Value -> Maybe [(AttributeKey, AttributeValue)]
attributesFromAeson v =
case v of
Aeson.Object o -> mapM convElem $ HM.toList o
_ -> Nothing
where
convElem (k, val) = fmap ((,) k) $ valueFromAeson val
attributesToAeson :: [(AttributeKey, AttributeValue)] -> Aeson.Value
attributesToAeson = Aeson.Object . HM.fromList . (fmap . fmap) toJSON