diff --git a/src/Compare/JSON.hs b/src/Compare/JSON.hs index 2625960acfac20132a06f398431f12ce87ce7f53..4b4d8fd17a202fba4c64886f3bff05b7618d8d27 100644 --- a/src/Compare/JSON.hs +++ b/src/Compare/JSON.hs @@ -4,19 +4,19 @@ {-# OPTIONS_GHC -Wno-orphans #-} module Compare.JSON - ( parseFile ) where + ( parseFile + , NodeLabel + , EdgeLabel + ) where import Data.Aeson import Data.Aeson.Types (typeMismatch) import qualified Data.ByteString.Lazy as BS import qualified Data.Graph.Inductive as G -import qualified Data.Map as M import Data.Text (Text) import qualified Data.Text as T import Lens.Micro -import Data.Tuple - import Compare.Types parseFile :: BS.ByteString -> Either String (Graph NodeLabel EdgeLabel) @@ -25,36 +25,41 @@ parseFile input = eitherDecode' input & _Right . _graph %~ G.emap stripArgument type NodeLabel = Text type EdgeLabel = Text -newtype N = N { unN :: NodeLabel } -newtype E = E { unE :: (NodeLabel, NodeLabel, EdgeLabel) } +newtype N n = N { unN :: n } +newtype E n e = E { unE :: (n, n, e) } -instance FromJSON (Graph NodeLabel EdgeLabel) where +instance (FromJSON n, Ord n, FromJSON e) => FromJSON (Graph n e) where parseJSON (Object v) = mkGraph <$> (map unN <$> v .: "nodes") <*> (map unE <$> v .: "edges") <*> v .: "entry" parseJSON invalid = typeMismatch "Graph" invalid -instance FromJSON N where +instance (ToJSON n, ToJSON e) => ToJSON (Graph n e) where + toJSON g = object + [ "nodes" .= ((g^._graph) & G.labNodes & map snd) + , "edges" .= ((g^._graph) & G.labEdges & map G.edgeLabel) + , "entry" .= (G.lab (g^._graph) (g^._point) ^?! _Just) + ] + +instance FromJSON n => FromJSON (N n) where parseJSON (Object v) = N <$> v .: "id" parseJSON invalid = typeMismatch "Node" invalid -instance FromJSON E where +instance ToJSON n => ToJSON (N n) where + toJSON (N n) = object ["id" .= n] + +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 --- TODO Make more robust against input errors --- E.g unknown notes in edges -mkGraph :: [NodeLabel] -> [(NodeLabel, NodeLabel, EdgeLabel)] -> NodeLabel -> Graph NodeLabel EdgeLabel -mkGraph nodes labels entry = - let - labNodes = zip [0..] nodes - nodeMap = M.fromList $ map swap labNodes - labEdges = map (\(from, to, label) -> (nodeMap M.! from, nodeMap M.! to, label)) labels - in - Graph (G.mkGraph labNodes labEdges) (nodeMap M.! entry) - +instance (ToJSON n, ToJSON e) => ToJSON (E n e) where + toJSON (E (from, to, label)) = object + [ "from" .= from + , "to" .= to + , "label" .= label + ] -- | Strip the part inside parenthesis from edge labels stripArgument :: Text -> Text diff --git a/src/Compare/Types.hs b/src/Compare/Types.hs index 362e660c3d571bfbbf820fb1cdfbcd92fca68c6d..0c6c75d74024a7d3e3cd98ef87febbf10d7f9144 100644 --- a/src/Compare/Types.hs +++ b/src/Compare/Types.hs @@ -6,10 +6,14 @@ module Compare.Types , _point , singletonGraph , insEdges' + , mkGraph ) where import Data.Foldable +import Data.Tuple + import qualified Data.Graph.Inductive as G +import qualified Data.Map as M import qualified Data.Set as S import Lens.Micro.TH @@ -39,3 +43,19 @@ insEdges' edges g = foldl' (flip insEdge) g edges insEdge (v, w, l) g = case G.match v g of (Nothing, _) -> g (Just (pr, _, la, su), g') -> (pr, v, la, S.toList $ S.insert (l,w) (S.fromList su)) G.& g' + +-- TODO Make more robust against input errors +-- E.g unknown notes in edges +-- | Create a graph from node and edge labels +mkGraph :: Ord n + => [n] -- ^ nodes + -> [(n, n, e)] -- ^ edges + -> n -- ^ point + -> Graph n e +mkGraph nodes labels entry = + let + labNodes = zip [0..] nodes + nodeMap = M.fromList $ map swap labNodes + labEdges = map (\(from, to, label) -> (nodeMap M.! from, nodeMap M.! to, label)) labels + in + Graph (G.mkGraph labNodes labEdges) (nodeMap M.! entry) diff --git a/test/Compare/CompareSpec.hs b/test/Compare/CompareSpec.hs index 3951e7ab5317b2cfa9e4fb8b07b00251308f176e..1ac89dc04a26706fe7bb62276b61e215791a4399 100644 --- a/test/Compare/CompareSpec.hs +++ b/test/Compare/CompareSpec.hs @@ -15,7 +15,7 @@ import Data.Text (Text) import qualified Data.IntMap as M import Compare.Compare -import Compare.Types +import Compare.Types hiding (mkGraph) spec :: Spec spec = do @@ -59,6 +59,7 @@ isIsomorphicSpec = describe "isIsomorphic" $ do property $ \(g :: Graph () Int) -> forAll (shuffleGraph g) $ \g' -> isDeterministic (graph g) ==> isIsomorphic g g' === True +-- FIXME: Use Compare.Types.mkGraph for this mkGraph :: [Int] -> [(Int, Int, Text)] -> G.Gr () Text mkGraph nodes edges = G.mkGraph (zip nodes (repeat ())) edges