JSON.hs

{-|
JSON exporter for the interactive viewer: https://skaarj1989.github.io/FrameGraph/

@
FG.compile graph
jsonSource <- Json.dump graph
@

'fromSnapshot' projects a compiled graph's 'Snapshot' onto the data model a
browser-based viewer consumes, and 'render' serializes it — hand-rolled, so
the library stays free of an aeson dependency. The types keep 'Generic'
instances for consumers who prefer deriving their own.

Unlike the Graphviz writer ("Fragr.Snapshot.Dot"), which draws one vertex
per resource /version/, this form collapses a resource's whole rename chain
(§3.4) into a single record keyed by resource /entry/ id, aggregating the
readers and writers of every version. 'fromSnapshot' accumulates in
version-major, then registration order, holding one id per declared access
with no deduplication.
-}
module Fragr.Snapshot.JSON
  ( dump
  , render
  , fromSnapshot
  , ViewerGraph (..)
  , ViewerPass (..)
  , ViewerResource (..)
  ) where

import Control.Monad (guard)
import Data.IntMap.Strict (IntMap)
import Data.IntMap.Strict qualified as IntMap
import Data.List (intersperse)
import Data.Maybe (listToMaybe, maybeToList)
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Text.Lazy qualified as Text.Lazy
import Data.Text.Lazy.Builder (Builder)
import Data.Text.Lazy.Builder qualified as Builder
import Data.Text.Lazy.Builder.Int qualified as Builder
import GHC.Generics (Generic)

import Fragr (EntryInfo (..), FrameGraph, NodeInfo (..), PassInfo (..), Snapshot (..), accessId, snapshot, someHandleId)

dump :: FrameGraph ctx alloc -> IO Text
dump g = render . fromSnapshot <$> snapshot g

{- | Serialize onto the viewer document (SPEC §8.3), compact. A resource's
empty @readers@/@writers@ and absent @createdBy@ are omitted, as the schema
allows; a pass keeps its @reads@/@writes@ even when empty.
-}
render :: ViewerGraph -> Text
render vg =
  Text.Lazy.toStrict . Builder.toLazyText $
    object
      [ ("passes", array (map passJson vg.passes))
      , ("resources", array (map resourceJson vg.resources))
      ]
  where
    passJson p =
      object
        [ ("id", int p.id)
        , ("name", string p.name)
        , ("culled", bool p.culled)
        , ("reads", ints p.reads)
        , ("writes", ints p.writes)
        ]
    resourceJson r =
      object $
        concat
          [
            [ ("id", int r.id)
            , ("name", string r.name)
            , ("description", string r.description)
            , ("transient", bool r.transient)
            ]
          , do
              c <- maybeToList r.createdBy
              pure ("createdBy", int c)
          , do
              guard (not (null r.readers))
              pure ("readers", ints r.readers)
          , do
              guard (not (null r.writers))
              pure ("writers", ints r.writers)
          ]

-- | The whole compiled graph: passes and resources as arrays indexed by id.
data ViewerGraph = ViewerGraph
  { passes :: [ViewerPass]
  , resources :: [ViewerResource]
  }
  deriving stock (Eq, Show, Generic)

{- | One pass. @reads@ / @writes@ are resource /entry/ ids (one per declared
access, in access order — not handles or version node ids), and @culled@ is
@not canExecute@.
-}
data ViewerPass = ViewerPass
  { id :: Int
  , name :: Text
  , culled :: Bool
  , reads :: [Int]
  , writes :: [Int]
  }
  deriving stock (Eq, Show, Generic)

{- | One resource /entry/, with its whole rename chain collapsed into a
single record. @readers@ / @writers@ are pass ids aggregated across every
version; @createdBy@ is the creating pass id, present only for transient
resources (imported resources have no creating pass).
-}
data ViewerResource = ViewerResource
  { id :: Int
  , name :: Text
  , description :: Text
  , transient :: Bool
  , createdBy :: Maybe Int
  , readers :: [Int]
  , writers :: [Int]
  }
  deriving stock (Eq, Show, Generic)

-- | Project a graph 'Snapshot' onto the viewer data model.
fromSnapshot :: Snapshot -> ViewerGraph
fromSnapshot s =
  ViewerGraph
    { passes = map mkPass s.passes
    , resources = map mkResource s.entries
    }
  where
    -- Resource-node id -> underlying entry id.
    entryOfNode :: IntMap Int
    entryOfNode = IntMap.fromList do
      n <- s.nodes
      pure (n.nodeId, n.resourceId)

    entryOf :: Int -> Int
    entryOf i = IntMap.findWithDefault (-1) i entryOfNode

    -- Entry id -> its version nodes, in node (version) order.
    nodesByEntry :: IntMap [NodeInfo]
    nodesByEntry = IntMap.fromListWith (flip (<>)) do
      n <- s.nodes
      pure (n.resourceId, [n])

    mkPass p =
      ViewerPass
        { id = p.passId
        , name = p.name
        , culled = not p.canExecute
        , reads = map (entryOf . accessId) p.reads
        , writes = map (entryOf . accessId) p.writes
        }

    -- Node id -> accessing pass ids, one per declared access, in
    -- registration order; concatenated per entry in node (version) order —
    -- the accumulation order noted above.
    readersOfNode = accessesOfNode do
      p <- s.passes
      i <- map accessId p.reads
      pure (i, p.passId)
    writersOfNode = accessesOfNode do
      p <- s.passes
      i <- map accessId p.writes
      pure (i, p.passId)
    creatorOfNode = IntMap.fromList do
      p <- s.passes
      i <- map someHandleId p.creates
      pure (i, p.passId)

    accessesOfNode :: [(Int, Int)] -> IntMap [Int]
    accessesOfNode accesses = IntMap.fromListWith (flip (<>)) do
      (i, pid) <- accesses
      pure (i, [pid])

    mkResource e =
      ViewerResource
        { id = e.entryId
        , name = maybe "" (.name) (listToMaybe nodes)
        , description = e.description
        , transient = not e.imported
        , createdBy = listToMaybe do
            n <- nodes
            maybeToList (IntMap.lookup n.nodeId creatorOfNode)
        , readers = accessesOf readersOfNode
        , writers = accessesOf writersOfNode
        }
      where
        nodes = IntMap.findWithDefault [] e.entryId nodesByEntry
        accessesOf m = concatMap (\n -> IntMap.findWithDefault [] n.nodeId m) nodes

-- tiny json encoder to avoid aeson deps

object :: [(Text, Builder)] -> Builder
object kvs = "{" <> mconcat (intersperse "," (map kv kvs)) <> "}"
  where
    kv (k, v) = string k <> ":" <> v

array :: [Builder] -> Builder
array vs = "[" <> mconcat (intersperse "," vs) <> "]"

ints :: [Int] -> Builder
ints = array . map int

int :: Int -> Builder
int = Builder.decimal

bool :: Bool -> Builder
bool b = if b then "true" else "false"

string :: Text -> Builder
string t = "\"" <> escape t <> "\""

escape :: Text -> Builder
escape t = case Text.break needsEscape t of
  (safe, rest) -> case Text.uncons rest of
    Nothing -> Builder.fromText safe
    Just (c, more) -> Builder.fromText safe <> escaped c <> escape more
  where
    needsEscape c = c == '"' || c == '\\' || c < ' '
    escaped = \case
      '"' -> "\\\""
      '\\' -> "\\\\"
      c -> unicode (fromEnum c) -- a control char, two hex digits suffice
    unicode n = "\\u00" <> (if n < 0x10 then "0" else "") <> Builder.hexadecimal n