module Hix.Ghci where

import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Except (ExceptT, catchE)
import Data.List.Extra (nubOrd)
import qualified Data.Map.Strict as Map
import Data.Map.Strict ((!?))
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
import Exon (exon)
import Path (Abs, Dir, File, Path, Rel, parseRelDir, reldir, splitExtension, stripProperPrefix, toFilePath, (</>))
import Path.IO (createDirIfMissing, getTempDir, openTempFile)
import System.IO (hClose)
import System.Posix.User (getLoginName)

import Hix.Component (targetComponentOrError)
import qualified Hix.Data.ComponentConfig
import Hix.Data.ComponentConfig (
  ComponentConfig,
  ModuleName (ModuleName),
  PackageConfig,
  PackageName,
  SourceDir (SourceDir),
  Target (Target),
  )
import Hix.Data.Error (Error, note, pathText, tryIO)
import qualified Hix.Data.GhciConfig
import Hix.Data.GhciConfig (GhciConfig, GhciRunExpr (GhciRunExpr), GhciSetupCode (GhciSetupCode))
import qualified Hix.Data.GhciTest as GhciTest
import Hix.Data.GhciTest (GhciRun (GhciRun), GhciTest (GhciTest), GhcidRun (GhcidRun))
import Hix.Json (jsonConfig)
import Hix.Monad (M, noteGhci)
import qualified Hix.Options as Options
import Hix.Options (
  ExtraGhciOptions,
  ExtraGhcidOptions (ExtraGhcidOptions),
  GhciOptions (GhciOptions),
  GhcidOptions,
  TargetSpec (TargetForFile),
  TestOptions (TestOptions),
  )
import Hix.Path (rootDir)

relativeToComponent ::
  Path Abs Dir ->
  PackageConfig ->
  Maybe SourceDir ->
  Path Abs File ->
  M (Path Rel File)
relativeToComponent :: Path Abs Dir
-> PackageConfig
-> Maybe SourceDir
-> Path Abs File
-> M (Path Rel File)
relativeToComponent Path Abs Dir
root PackageConfig
package Maybe SourceDir
mdir Path Abs File
path = do
  SourceDir Path Rel Dir
dir <- forall a. Text -> Maybe a -> M a
noteGhci Text
"Internal: No source dir for file target" Maybe SourceDir
mdir
  forall a. Text -> Maybe a -> M a
noteGhci Text
"Internal: Bad file target" (forall (m :: * -> *) b t.
MonadThrow m =>
Path b Dir -> Path b t -> m (Path Rel t)
stripProperPrefix (Path Abs Dir
root forall b t. Path b Dir -> Path Rel t -> Path b t
</> PackageConfig
package.src forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
dir) Path Abs File
path)

moduleName ::
  PackageConfig ->
  Maybe SourceDir ->
  GhciOptions ->
  M ModuleName
moduleName :: PackageConfig -> Maybe SourceDir -> GhciOptions -> M ModuleName
moduleName PackageConfig
package Maybe SourceDir
component = \case
  GhciOptions {$sel:component:GhciOptions :: GhciOptions -> TargetSpec
component = TargetForFile Path Abs File
path, $sel:root:GhciOptions :: GhciOptions -> Maybe (Path Abs Dir)
root = Maybe (Path Abs Dir)
cliRoot} -> do
    Path Abs Dir
root <- Maybe (Path Abs Dir) -> M (Path Abs Dir)
rootDir Maybe (Path Abs Dir)
cliRoot
    Path Rel File
rel <- Path Abs Dir
-> PackageConfig
-> Maybe SourceDir
-> Path Abs File
-> M (Path Rel File)
relativeToComponent Path Abs Dir
root PackageConfig
package Maybe SourceDir
component Path Abs File
path
    pure (Text -> ModuleName
ModuleName (Text -> Text -> Text -> Text
Text.replace Text
"/" Text
"." (forall {b}. Path b File -> Text
withoutExt Path Rel File
rel)))
  GhciOptions {TestOptions
$sel:test:GhciOptions :: GhciOptions -> TestOptions
test :: TestOptions
test} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure TestOptions
test.mod
  where
    withoutExt :: Path b File -> Text
withoutExt Path b File
p = forall b t. Path b t -> Text
pathText (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Path b File
p forall a b. (a, b) -> a
fst (forall (m :: * -> *) b.
MonadThrow m =>
Path b File -> m (Path b File, FilePath)
splitExtension Path b File
p))

ghciScript ::
  GhciConfig ->
  PackageConfig ->
  Maybe SourceDir ->
  GhciOptions ->
  M Text
ghciScript :: GhciConfig
-> PackageConfig -> Maybe SourceDir -> GhciOptions -> M Text
ghciScript GhciConfig
config PackageConfig
package Maybe SourceDir
component GhciOptions
opt = do
  ModuleName Text
module_ <- PackageConfig -> Maybe SourceDir -> GhciOptions -> M ModuleName
moduleName PackageConfig
package Maybe SourceDir
component GhciOptions
opt
  forall (f :: * -> *) a. Applicative f => a -> f a
pure [exon|#{cdCode}#{setup}
:load #{module_}
import #{module_}|]
  where
    cdCode :: Text
cdCode | GhciOptions
opt.test.cd.unChangeDir = [exon|:cd #{pathText package.src}
|]
           | Bool
otherwise = Text
""
    GhciSetupCode Text
setup = forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup GhciConfig
config.setup forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< GhciOptions
opt.test.runner)

componentSearchPaths :: PackageConfig -> ComponentConfig -> [Path Rel Dir]
componentSearchPaths :: PackageConfig -> ComponentConfig -> [Path Rel Dir]
componentSearchPaths PackageConfig
pkg ComponentConfig
comp = do
  SourceDir Path Rel Dir
dir <- coerce :: forall a b. Coercible a b => a -> b
coerce ComponentConfig
comp.sourceDirs
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageConfig
pkg.src forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
dir)

librarySearchPaths :: Map PackageName PackageConfig -> [Path Rel Dir]
librarySearchPaths :: PackagesConfig -> [Path Rel Dir]
librarySearchPaths PackagesConfig
pkgs = do
  PackageConfig
pkg <- forall k a. Map k a -> [a]
Map.elems PackagesConfig
pkgs
  ComponentConfig
comp <- forall a. Maybe a -> [a]
maybeToList (PackageConfig
pkg.components forall k a. Ord k => Map k a -> k -> Maybe a
!? ComponentName
"library")
  PackageConfig -> ComponentConfig -> [Path Rel Dir]
componentSearchPaths PackageConfig
pkg ComponentConfig
comp

searchPath :: Map PackageName PackageConfig -> PackageConfig -> ComponentConfig -> [Path Rel Dir]
searchPath :: PackagesConfig
-> PackageConfig -> ComponentConfig -> [Path Rel Dir]
searchPath PackagesConfig
pkgs PackageConfig
pkg ComponentConfig
comp =
  forall a. Ord a => [a] -> [a]
nubOrd (PackageConfig -> ComponentConfig -> [Path Rel Dir]
componentSearchPaths PackageConfig
pkg ComponentConfig
comp forall a. Semigroup a => a -> a -> a
<> PackagesConfig -> [Path Rel Dir]
librarySearchPaths PackagesConfig
pkgs)

testRun :: GhciConfig -> TestOptions -> Maybe Text
testRun :: GhciConfig -> TestOptions -> Maybe Text
testRun GhciConfig
config = \case
  TestOptions {Maybe Text
$sel:test:TestOptions :: TestOptions -> Maybe Text
test :: Maybe Text
test, $sel:runner:TestOptions :: TestOptions -> Maybe RunnerName
runner = Just RunnerName
runner} | Just (GhciRunExpr Text
run) <- GhciConfig
config.run forall k a. Ord k => Map k a -> k -> Maybe a
!? RunnerName
runner ->
    forall a. a -> Maybe a
Just [exon|(#{run}) #{fold test}|]
  TestOptions {$sel:test:TestOptions :: TestOptions -> Maybe Text
test = Just Text
test} ->
    forall a. a -> Maybe a
Just Text
test
  TestOptions {$sel:test:TestOptions :: TestOptions -> Maybe Text
test = Maybe Text
Nothing} ->
    forall a. Maybe a
Nothing

assemble :: GhciOptions -> M GhciTest
assemble :: GhciOptions -> M GhciTest
assemble GhciOptions
opt = do
  GhciConfig
config <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. FromJSON a => JsonConfig -> M a
jsonConfig GhciOptions
opt.config
  Path Abs Dir
root <- Maybe (Path Abs Dir) -> M (Path Abs Dir)
rootDir GhciOptions
opt.root
  Target {Maybe SourceDir
PackageConfig
ComponentConfig
$sel:sourceDir:Target :: Target -> Maybe SourceDir
$sel:component:Target :: Target -> ComponentConfig
$sel:package:Target :: Target -> PackageConfig
sourceDir :: Maybe SourceDir
component :: ComponentConfig
package :: PackageConfig
..} <- Maybe (Path Abs Dir) -> PackagesConfig -> TargetSpec -> M Target
targetComponentOrError GhciOptions
opt.root GhciConfig
config.packages GhciOptions
opt.component
  Text
script <- GhciConfig
-> PackageConfig -> Maybe SourceDir -> GhciOptions -> M Text
ghciScript GhciConfig
config PackageConfig
package Maybe SourceDir
sourceDir GhciOptions
opt
  pure GhciTest {
    Text
$sel:script:GhciTest :: Text
script :: Text
script,
    $sel:test:GhciTest :: Maybe Text
test = GhciConfig -> TestOptions -> Maybe Text
testRun GhciConfig
config GhciOptions
opt.test,
    $sel:args:GhciTest :: GhciArgs
args = GhciConfig
config.args,
    $sel:searchPath:GhciTest :: [Path Abs Dir]
searchPath = (Path Abs Dir
root </>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PackagesConfig
-> PackageConfig -> ComponentConfig -> [Path Rel Dir]
searchPath GhciConfig
config.packages PackageConfig
package ComponentConfig
component
    }

hixTempDir ::
  ExceptT Error IO (Path Abs Dir)
hixTempDir :: ExceptT Error IO (Path Abs Dir)
hixTempDir = do
  Path Abs Dir
tmp <- forall a. IO a -> ExceptT Error IO a
tryIO forall (m :: * -> *). MonadIO m => m (Path Abs Dir)
getTempDir
  Path Rel Dir
user <- forall a. Text -> Maybe a -> ExceptT Error IO a
note Text
"Couldn't determine user name" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). MonadThrow m => FilePath -> m (Path Rel Dir)
parseRelDir forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) e a e'.
Monad m =>
ExceptT e m a -> (e -> ExceptT e' m a) -> ExceptT e' m a
catchE (forall a. IO a -> ExceptT Error IO a
tryIO IO FilePath
getLoginName) (forall a b. a -> b -> a
const (forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
"user"))
  let hixTmp :: Path Abs Dir
hixTmp = Path Abs Dir
tmp forall b t. Path b Dir -> Path Rel t -> Path b t
</> [reldir|hix|] forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
user
  forall a. IO a -> ExceptT Error IO a
tryIO (forall (m :: * -> *) b. MonadIO m => Bool -> Path b Dir -> m ()
createDirIfMissing Bool
True Path Abs Dir
hixTmp)
  pure Path Abs Dir
hixTmp

ghciScriptFile ::
  Path Abs Dir ->
  Text ->
  ExceptT Error IO (Path Abs File)
ghciScriptFile :: Path Abs Dir -> Text -> ExceptT Error IO (Path Abs File)
ghciScriptFile Path Abs Dir
tmp Text
text =
  forall a. IO a -> ExceptT Error IO a
tryIO do
    (Path Abs File
path, Handle
handle) <- forall (m :: * -> *) b.
MonadIO m =>
Path b Dir -> FilePath -> m (Path Abs File, Handle)
openTempFile Path Abs Dir
tmp FilePath
"hix-ghci-.ghci"
    Handle -> Text -> IO ()
Text.hPutStr Handle
handle Text
text
    Handle -> IO ()
hClose Handle
handle
    pure Path Abs File
path

searchPathArg :: NonEmpty (Path Abs Dir) -> Text
searchPathArg :: NonEmpty (Path Abs Dir) -> Text
searchPathArg NonEmpty (Path Abs Dir)
paths =
  [exon| -i#{colonSeparated}|]
  where
    colonSeparated :: Text
colonSeparated = Text -> [Text] -> Text
Text.intercalate Text
":" (forall b t. Path b t -> Text
pathText forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (Path Abs Dir)
paths)

ghciCmdline ::
  GhciTest ->
  Maybe ExtraGhciOptions ->
  Path Abs File ->
  Maybe (Path Abs File) ->
  GhciRun
ghciCmdline :: GhciTest
-> Maybe ExtraGhciOptions
-> Path Abs File
-> Maybe (Path Abs File)
-> GhciRun
ghciCmdline GhciTest
test Maybe ExtraGhciOptions
extra Path Abs File
scriptFile Maybe (Path Abs File)
runScriptFile =
  GhciRun {Maybe Text
Text
Path Abs File
GhciTest
$sel:scriptFile:GhciRun :: Path Abs File
$sel:run:GhciRun :: Maybe Text
$sel:shell:GhciRun :: Text
$sel:test:GhciRun :: GhciTest
run :: Maybe Text
shell :: Text
scriptFile :: Path Abs File
test :: GhciTest
..}
  where
    shell :: Text
shell = [exon|##{Text.unwords (coerce test.args)}#{sp} -ghci-script=##{toFilePath scriptFile}#{extraOpts}|]
    run :: Maybe Text
run = Maybe (Path Abs File)
runScriptFile forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \ Path Abs File
f -> [exon|-ghci-script=##{toFilePath f}|]
    sp :: Text
sp = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap NonEmpty (Path Abs Dir) -> Text
searchPathArg (forall a. [a] -> Maybe (NonEmpty a)
nonEmpty GhciTest
test.searchPath)
    extraOpts :: Text
extraOpts | Just ExtraGhciOptions
o <- Maybe ExtraGhciOptions
extra = [exon| ##{o}|]
              | Bool
otherwise = Text
""

ghciCmdlineFromOptions ::
  Path Abs Dir ->
  GhciOptions ->
  M GhciRun
ghciCmdlineFromOptions :: Path Abs Dir -> GhciOptions -> M GhciRun
ghciCmdlineFromOptions Path Abs Dir
tmp GhciOptions
opt = do
  GhciTest
conf <- GhciOptions -> M GhciTest
assemble GhciOptions
opt
  Path Abs File
shellScriptFile <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Path Abs Dir -> Text -> ExceptT Error IO (Path Abs File)
ghciScriptFile Path Abs Dir
tmp GhciTest
conf.script)
  Maybe (Path Abs File)
runScriptFile <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Path Abs Dir -> Text -> ExceptT Error IO (Path Abs File)
ghciScriptFile Path Abs Dir
tmp) GhciTest
conf.test)
  pure (GhciTest
-> Maybe ExtraGhciOptions
-> Path Abs File
-> Maybe (Path Abs File)
-> GhciRun
ghciCmdline GhciTest
conf GhciOptions
opt.extra Path Abs File
shellScriptFile Maybe (Path Abs File)
runScriptFile)

ghcidCmdlineFromOptions ::
  Path Abs Dir ->
  GhcidOptions ->
  M GhcidRun
ghcidCmdlineFromOptions :: Path Abs Dir -> GhcidOptions -> M GhcidRun
ghcidCmdlineFromOptions Path Abs Dir
tmp GhcidOptions
opt = do
  GhciRun
ghci <- Path Abs Dir -> GhciOptions -> M GhciRun
ghciCmdlineFromOptions Path Abs Dir
tmp GhcidOptions
opt.ghci
  let
    test :: Text
test = forall a. a -> Maybe a -> a
fromMaybe Text
"main" GhciRun
ghci.test.test
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> GhciRun -> GhcidRun
GhcidRun [exon|ghcid --command="ghci #{ghci.shell}" --test='##{test}'#{foldMap extra opt.extra}|] GhciRun
ghci)
  where
    extra :: ExtraGhcidOptions -> inner
extra (ExtraGhcidOptions Text
o) = [exon| ##{o}|]

printGhciCmdline ::
  GhciOptions ->
  M ()
printGhciCmdline :: GhciOptions -> M ()
printGhciCmdline GhciOptions
opt = do
  Path Abs Dir
tmp <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ExceptT Error IO (Path Abs Dir)
hixTempDir
  GhciRun
cmd <- Path Abs Dir -> GhciOptions -> M GhciRun
ghciCmdlineFromOptions Path Abs Dir
tmp GhciOptions
opt
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Text -> IO ()
Text.putStrLn [exon|ghci #{cmd.shell} #{fold cmd.run}|])

printGhcidCmdline ::
  GhcidOptions ->
  M ()
printGhcidCmdline :: GhcidOptions -> M ()
printGhcidCmdline GhcidOptions
opt = do
  Path Abs Dir
tmp <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ExceptT Error IO (Path Abs Dir)
hixTempDir
  GhcidRun
cmd <- Path Abs Dir -> GhcidOptions -> M GhcidRun
ghcidCmdlineFromOptions Path Abs Dir
tmp GhcidOptions
opt
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Text -> IO ()
Text.putStrLn GhcidRun
cmd.cmdline)