GhcPkg.hs

module Tricorder.SourceLookup.GhcPkg
    ( GhcPkg
    , findModule
    , runGhcPkgIO
    , runGhcPkgScripted
    , GhcPkgScript (..)
    )
where

import Atelier.Effects.Process (Process, readProcessSafe)
import Effectful (Effect)
import Effectful.Dispatch.Dynamic (interpret, reinterpret)
import Effectful.State.Static.Shared (evalState, get, put)
import Effectful.TH (makeEffect)
import Tricorder.SourceLookup.PackageId (PackageId (..))
import Tricorder.SourceLookup.SourceQuery (ModuleName (..))

import Data.Text qualified as T

import Tricorder.Session.Repl (Repl (..))


data GhcPkg :: Effect where
    FindModule :: Repl -> ModuleName -> GhcPkg m (Maybe PackageId)


makeEffect ''GhcPkg


runGhcPkgIO :: (Process :> es) => Eff (GhcPkg : es) a -> Eff es a
runGhcPkgIO = interpret \_ -> \case
    FindModule repl modName -> do
        let cmd = "ghc-pkg"
            args = ["find-module", "--simple-output", toString $ unModuleName modName]
            stack = readProcessSafe "stack" $ ["exec", "--", cmd] <> args
            direct = readProcessSafe cmd args
        out <- case repl of
            Stack -> stack
            StackMulti -> stack
            Cabal -> direct
            Unknown -> direct
        pure $ out >>= fmap PackageId . listToMaybe . filter (not . T.null) . map T.strip . T.lines


-- | Script element for the test interpreter.
newtype GhcPkgScript
    = -- | Return this value for the next 'findModule' call.
      NextFindModule (Maybe PackageId)


-- | Scripted interpreter for testing. Does not require 'IOE'.
runGhcPkgScripted :: [GhcPkgScript] -> Eff (GhcPkg : es) a -> Eff es a
runGhcPkgScripted script = reinterpret (evalState script) \_ -> \case
    FindModule _ _ ->
        get >>= \case
            NextFindModule result : rest -> put rest >> pure result
            _ -> error "GhcPkgScripted: expected NextFindModule but queue was empty or mismatched"