Select Git revision
-
Hans-Peter Deifel authored
This allows to parse arbitrary metadata instead of just the node id and edges.
Hans-Peter Deifel authoredThis allows to parse arbitrary metadata instead of just the node id and edges.
JSON.hs 2.44 KiB
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Compare.JSON
( parseFile
, FromJSONNode(..)
, ToJSONNode(..)
) where
import Data.Aeson
import Data.Aeson.Types (typeMismatch, Parser)
import qualified Data.ByteString.Lazy as BS
import qualified Data.Graph.Inductive as G
import Data.Text (Text)
import Lens.Micro
import Compare.Types
import Compare.Types.Lenses
parseFile :: FromJSON (Graph n e) => BS.ByteString -> Either String (Graph n e)
parseFile input = eitherDecode' input
class FromJSONNode a where
parseJSONNode :: Value -> Parser a
class ToJSONNode a where
toJSONNode :: a -> Value
newtype E n e = E { unE :: (n, n, e) }
instance (FromJSONNode n, HasNodeId n, FromJSON (NodeId n), FromJSON e) => FromJSON (Graph n e) where
parseJSON (Object v) = mkGraph
<$> ((v .: "nodes") >>= mapM parseJSONNode)
<*> (map unE <$> (v .: "edges"))
<*> v .: "entry"
parseJSON invalid = typeMismatch "Graph" invalid
instance (ToJSONNode n, HasNodeId n, ToJSON (NodeId n), ToJSON e) => ToJSON (Graph n e) where
toJSON g = object
[ "nodes" .= (g ^. _graph & G.labNodes & map snd & map toJSONNode)
, "edges" .= (g ^. _graph & G.labEdges & map (toE g))
, "entry" .= (g ^?! node (g ^. _point) . to nodeId)
]
instance FromJSONNode Text where
parseJSONNode (Object v) = v .: "id"
parseJSONNode invalid = typeMismatch "NodeLabel" invalid
instance FromJSONNode Int where
parseJSONNode (Object v) = v .: "id"
parseJSONNode invalid = typeMismatch "NodeLabel" invalid
instance ToJSONNode Text where
toJSONNode x = object [ "id" .= toJSON x]
instance ToJSONNode Int where
toJSONNode x = object [ "id" .= toJSON x]
toE :: HasNodeId n => Graph n e -> G.LEdge e -> E (NodeId n) e
toE g (from, to', lab) = E ( G.lab (g^._graph) from ^?! _Just . to nodeId
, G.lab (g^._graph) to' ^?! _Just . to nodeId
, lab)
instance (FromJSON n, FromJSON e) => FromJSON (E n e) where
parseJSON (Object v) =
E <$> ((\a b c -> (a,b,c)) <$> v .: "from" <*> v .: "to" <*> v .: "label")
parseJSON invalid = typeMismatch "Edge" invalid
instance (ToJSON n, ToJSON e) => ToJSON (E n e) where
toJSON (E (from, to, label)) = object
[ "from" .= from
, "to" .= to
, "label" .= label
]