Setup.hs

-- | What the setup phase records before compilation.
module Spec.Setup (tests) where

import Control.Monad.IO.Class (liftIO)
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (testCase, (@?=))

import Fragr (Access (..))
import Fragr qualified as FG
import Utils

tests :: TestTree
tests =
  testGroup
    "setup phase bookkeeping"
    [ duplicateReadsSuppressed
    , renameMintsNode
    , implicitReadRecorded
    , descriptorLookup
    ]

duplicateReadsSuppressed :: TestTree
duplicateReadsSuppressed = testCase "exact duplicate reads are suppressed, different flags are not" do
  g <- FG.newFrameGraph @Env @Env
  env <- newEnv
  h <- FG.importResource g "R" (tex "R") (Tex 1)
  _ <-
    FG.addPass
      g
      "B"
      ( do
          FG.readWith h 3
          FG.readWith h 3
          FG.readWith h 4
          FG.setSideEffect
      )
      \_data -> pure ()
  FG.compile g
  s <- FG.snapshot g
  [node] <- pure (filter (\n -> n.name == "R") s.nodes)
  node.refCount @?= 2
  FG.execute g env env
  ev <- getEvents env
  ev @?= [EPreRead "R" 3, EPreRead "R" 4]

renameMintsNode :: TestTree
renameMintsNode = testCase "rename bumps the entry version and mints a new node" do
  g <- FG.newFrameGraph @Env @Env
  h1 <- FG.importResource g "BB" (tex "BB") (Tex 1)
  FG.addPass_ g "P" (FG.write_ h1) (pure ())
  s <- FG.snapshot g
  map (.version) s.nodes @?= [1, 2]
  map (.resourceId) s.nodes @?= [0, 0]
  map (.name) s.nodes @?= ["BB", "BB"]
  map (.version) s.entries @?= [2]

implicitReadRecorded :: TestTree
implicitReadRecorded = testCase "the implicit read of a rename is recorded without flags" do
  g <- FG.newFrameGraph @Env @Env
  h1 <- FG.importResource g "BB" (tex "BB") (Tex 1)
  h2 <- FG.addPass g "P" (FG.writeWith h1 5) \_data -> pure ()
  s <- FG.snapshot g
  [p] <- pure s.passes
  p.reads @?= [Access{handle = h1, flags = Nothing}]
  p.writes @?= [Access{handle = h2, flags = Just 5}]

descriptorLookup :: TestTree
descriptorLookup = testCase "getDescriptor works on the graph and through the accessor" do
  g <- FG.newFrameGraph @Env @Env
  env <- newEnv
  h <-
    FG.addPass
      g
      "P"
      ( do
          h <- FG.create @Tex "R" (tex "R")
          FG.write_ h
          FG.setSideEffect
          pure h
      )
      \h -> do
        d <- FG.getDesc @Tex h
        liftIO (d @?= tex "R")
  d <- FG.getDescriptor @Tex g h
  d @?= tex "R"
  FG.compile g
  FG.execute g env env