Skip to content
Snippets Groups Projects
Select Git revision
  • 24485bd40a876e67b4766a5ecac2c566597b5c69
  • master default protected
  • wip/graph-iso
  • ip-save-debugging
4 results

JSON.hs

Blame
  • 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
        ]