GhciSessionSpec.hs

module Unit.Tricorder.Daemon.GhciSessionSpec (test_GhciSession) where

import Atelier.Effects.Publishing.Pub (Pub)
import Control.Exception (ErrorCall (..))
import Effectful (IOE, runEff)
import Effectful.Exception (try)
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (assertBool, testCase, (@?=))

import Atelier.Effects.Publishing.Pub qualified as Pub
import Data.Map.Strict qualified as Map
import Data.Set qualified as Set

import Tricorder.Build (BuildProgress, Diagnostic (..), Severity (..))
import Tricorder.Daemon.GhciSession
    ( Controls (..)
    , GhciSession
    , LoadResult (..)
    , runGhciSessionScripted
    , withGhci
    )
import Tricorder.Runtime (ProjectRoot (..))
import Tricorder.Session.Command.RenderedCommand (RenderedCommand (..))
import Tricorder.Session.Stage (Stage (..))


test_GhciSession :: TestTree
test_GhciSession =
    testGroup
        "GhciSession"
        [ testGroup "runGhciSessionScripted" testScripted
        ]


--------------------------------------------------------------------------------
-- Scripted interpreter tests
--------------------------------------------------------------------------------

testScripted :: [TestTree]
testScripted =
    [ testGroup
        "withGhci"
        [ testGroup
            "initial load"
            [ testCase "returns scripted messages" do
                LoadResult {diagnostics = msgs} <-
                    runScripted [simpleResult [errMsg]]
                        $ withGhci cmd (ProjectRoot "/") \initial _ -> pure initial
                msgs @?= [errMsg]
            , testCase "returns empty list when scripted result has no messages" do
                LoadResult {diagnostics = msgs} <-
                    runScripted [simpleResult []]
                        $ withGhci cmd (ProjectRoot "/") \initial _ -> pure initial
                msgs @?= []
            , testCase "throws when scripted result is Left" do
                result <-
                    runScripted [Left (toException boom)]
                        $ try @ErrorCall
                        $ withGhci cmd (ProjectRoot "/") \initial _ -> pure initial
                result @?= Left boom
            ]
        , testGroup
            "reloading"
            [ testCase "returns scripted messages" do
                LoadResult {diagnostics = msgs} <-
                    runScripted [simpleResult [warnMsg], simpleResult [errMsg]]
                        $ withGhci cmd (ProjectRoot "/") \_ controls -> controls.reload
                msgs @?= [errMsg]
            , testCase "throws when scripted result is Left" do
                result <-
                    runScripted [Left (toException boom)]
                        $ try @ErrorCall
                        $ withGhci cmd (ProjectRoot "/") \_ controls -> controls.reload
                result @?= Left boom
            ]
        ]
    , testGroup
        "sequencing"
        [ testCase "consumes results in order across mixed operations" do
            (a, b) <- runScripted [simpleResult [errMsg], simpleResult [warnMsg]] do
                withGhci cmd (ProjectRoot "/") \LoadResult {diagnostics = a} controls -> do
                    LoadResult {diagnostics = b} <- controls.reload
                    pure (a, b)
            a @?= [errMsg]
            b @?= [warnMsg]
        , testCase "recover scenario: error then success" do
            result <- runScripted [Left (toException boom), simpleResult []] do
                r1 <- try @ErrorCall $ withGhci cmd (ProjectRoot "/") \i _ -> pure i
                LoadResult {diagnostics = r2} <- withGhci cmd (ProjectRoot "/") \i _ -> pure i
                pure (r1, r2)
            assertBool "expected Left" $ isLeft (fst result)
            snd result @?= []
        ]
    ]


--------------------------------------------------------------------------------
-- Helpers
--------------------------------------------------------------------------------

cmd :: RenderedCommand 'Build
cmd = RenderedCommand "cabal repl lib:foo"


boom :: ErrorCall
boom = ErrorCall "simulated GHCi crash"


errMsg :: Diagnostic
errMsg =
    Diagnostic
        { severity = SError
        , file = "src/Foo.hs"
        , line = 1
        , col = 1
        , endLine = 1
        , endCol = 5
        , title = "Variable not in scope: foo"
        , text = "Variable not in scope: foo"
        }


warnMsg :: Diagnostic
warnMsg =
    Diagnostic
        { severity = SWarning
        , file = "src/Bar.hs"
        , line = 10
        , col = 3
        , endLine = 10
        , endCol = 8
        , title = "Unused import"
        , text = "Unused import"
        }


-- | Convenience constructor: a scripted result with no compiled-file info.
simpleResult :: [Diagnostic] -> Either SomeException LoadResult
simpleResult msgs =
    Right
        LoadResult
            { moduleCount = 0
            , compiledFiles = Set.empty
            , loadedModules = Map.empty
            , targetNames = []
            , diagnostics = msgs
            }


runScripted
    :: [Either SomeException LoadResult]
    -> Eff '[GhciSession, Pub BuildProgress, IOE] a
    -> IO a
runScripted results = runEff . Pub.runNoOp . runGhciSessionScripted results