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 (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 <- Text -> Maybe SourceDir -> M SourceDir forall a. Text -> Maybe a -> M a noteGhci Text "Internal: No source dir for file target" Maybe SourceDir mdir Text -> Maybe (Path Rel File) -> M (Path Rel File) forall a. Text -> Maybe a -> M a noteGhci Text "Internal: Bad file target" (Path Abs Dir -> Path Abs File -> Maybe (Path Rel File) forall (m :: * -> *) b t. MonadThrow m => Path b Dir -> Path b t -> m (Path Rel t) stripProperPrefix (Path Abs Dir root Path Abs Dir -> Path Rel Dir -> Path Abs Dir forall b t. Path b Dir -> Path Rel t -> Path b t </> PackageConfig package.src Path Rel Dir -> Path Rel Dir -> Path Rel Dir 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 (HasCallStack => Text -> Text -> Text -> Text Text -> Text -> Text -> Text Text.replace Text "/" Text "." (Path Rel File -> Text forall {b}. Path b File -> Text withoutExt Path Rel File rel))) GhciOptions {TestOptions test :: TestOptions $sel:test:GhciOptions :: GhciOptions -> TestOptions test} -> ModuleName -> M ModuleName forall a. a -> ReaderT Env (ExceptT Error IO) a forall (f :: * -> *) a. Applicative f => a -> f a pure TestOptions test.mod where withoutExt :: Path b File -> Text withoutExt Path b File p = Path b File -> Text forall b t. Path b t -> Text pathText (Path b File -> ((Path b File, FilePath) -> Path b File) -> Maybe (Path b File, FilePath) -> Path b File forall b a. b -> (a -> b) -> Maybe a -> b maybe Path b File p (Path b File, FilePath) -> Path b File forall a b. (a, b) -> a fst (Path b File -> Maybe (Path b File, FilePath) 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 Text -> M Text forall a. a -> ReaderT Env (ExceptT Error IO) a 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 = Maybe GhciSetupCode -> GhciSetupCode forall m. Monoid m => Maybe m -> m forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m fold ((RunnerName -> Map RunnerName GhciSetupCode -> Maybe GhciSetupCode) -> Map RunnerName GhciSetupCode -> RunnerName -> Maybe GhciSetupCode forall a b c. (a -> b -> c) -> b -> a -> c flip RunnerName -> Map RunnerName GhciSetupCode -> Maybe GhciSetupCode forall k a. Ord k => k -> Map k a -> Maybe a Map.lookup GhciConfig config.setup (RunnerName -> Maybe GhciSetupCode) -> Maybe RunnerName -> Maybe GhciSetupCode 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 <- SourceDirs -> [SourceDir] forall a b. Coercible a b => a -> b coerce ComponentConfig comp.sourceDirs Path Rel Dir -> [Path Rel Dir] forall a. a -> [a] forall (f :: * -> *) a. Applicative f => a -> f a pure (PackageConfig pkg.src Path Rel Dir -> Path Rel Dir -> Path Rel Dir 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 <- PackagesConfig -> [PackageConfig] forall k a. Map k a -> [a] Map.elems PackagesConfig pkgs ComponentConfig comp <- Maybe ComponentConfig -> [ComponentConfig] forall a. Maybe a -> [a] maybeToList (PackageConfig pkg.components Map ComponentName ComponentConfig -> ComponentName -> Maybe ComponentConfig 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 = [Path Rel Dir] -> [Path Rel Dir] forall a. Ord a => [a] -> [a] nubOrd (PackageConfig -> ComponentConfig -> [Path Rel Dir] componentSearchPaths PackageConfig pkg ComponentConfig comp [Path Rel Dir] -> [Path Rel Dir] -> [Path Rel Dir] 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 test :: Maybe Text $sel:test:TestOptions :: TestOptions -> Maybe Text test, $sel:runner:TestOptions :: TestOptions -> Maybe RunnerName runner = Just RunnerName runner} | Just (GhciRunExpr Text run) <- GhciConfig config.run Map RunnerName GhciRunExpr -> RunnerName -> Maybe GhciRunExpr forall k a. Ord k => Map k a -> k -> Maybe a !? RunnerName runner -> Text -> Maybe Text forall a. a -> Maybe a Just [exon|(#{run}) #{fold test}|] TestOptions {$sel:test:TestOptions :: TestOptions -> Maybe Text test = Just Text test} -> Text -> Maybe Text forall a. a -> Maybe a Just Text test TestOptions {$sel:test:TestOptions :: TestOptions -> Maybe Text test = Maybe Text Nothing} -> Maybe Text forall a. Maybe a Nothing assemble :: GhciOptions -> M GhciTest assemble :: GhciOptions -> M GhciTest assemble GhciOptions opt = do GhciConfig config <- (GhciConfig -> ReaderT Env (ExceptT Error IO) GhciConfig) -> (JsonConfig -> ReaderT Env (ExceptT Error IO) GhciConfig) -> Either GhciConfig JsonConfig -> ReaderT Env (ExceptT Error IO) GhciConfig forall a c b. (a -> c) -> (b -> c) -> Either a b -> c either GhciConfig -> ReaderT Env (ExceptT Error IO) GhciConfig forall a. a -> ReaderT Env (ExceptT Error IO) a forall (f :: * -> *) a. Applicative f => a -> f a pure JsonConfig -> ReaderT Env (ExceptT Error IO) GhciConfig 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 package :: PackageConfig component :: ComponentConfig sourceDir :: Maybe SourceDir $sel:package:Target :: Target -> PackageConfig $sel:component:Target :: Target -> ComponentConfig $sel:sourceDir:Target :: Target -> Maybe SourceDir ..} <- Maybe (Path Abs Dir) -> Maybe PackageName -> PackagesConfig -> TargetSpec -> M Target targetComponentOrError GhciOptions opt.root GhciConfig config.mainPackage 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 script :: Text $sel:script:GhciTest :: 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 </>) (Path Rel Dir -> Path Abs Dir) -> [Path Rel Dir] -> [Path Abs Dir] 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 <- IO (Path Abs Dir) -> ExceptT Error IO (Path Abs Dir) forall a. IO a -> ExceptT Error IO a tryIO IO (Path Abs Dir) forall (m :: * -> *). MonadIO m => m (Path Abs Dir) getTempDir Path Rel Dir user <- Text -> Maybe (Path Rel Dir) -> ExceptT Error IO (Path Rel Dir) forall a. Text -> Maybe a -> ExceptT Error IO a note Text "Couldn't determine user name" (Maybe (Path Rel Dir) -> ExceptT Error IO (Path Rel Dir)) -> (FilePath -> Maybe (Path Rel Dir)) -> FilePath -> ExceptT Error IO (Path Rel Dir) forall b c a. (b -> c) -> (a -> b) -> a -> c . FilePath -> Maybe (Path Rel Dir) forall (m :: * -> *). MonadThrow m => FilePath -> m (Path Rel Dir) parseRelDir (FilePath -> ExceptT Error IO (Path Rel Dir)) -> ExceptT Error IO FilePath -> ExceptT Error IO (Path Rel Dir) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< ExceptT Error IO FilePath -> (Error -> ExceptT Error IO FilePath) -> ExceptT Error IO FilePath forall (m :: * -> *) e a e'. Monad m => ExceptT e m a -> (e -> ExceptT e' m a) -> ExceptT e' m a catchE (IO FilePath -> ExceptT Error IO FilePath forall a. IO a -> ExceptT Error IO a tryIO IO FilePath getLoginName) (ExceptT Error IO FilePath -> Error -> ExceptT Error IO FilePath forall a b. a -> b -> a const (FilePath -> ExceptT Error IO FilePath forall a. a -> ExceptT Error IO a forall (f :: * -> *) a. Applicative f => a -> f a pure FilePath "user")) let hixTmp :: Path Abs Dir hixTmp = Path Abs Dir tmp Path Abs Dir -> Path Rel Dir -> Path Abs Dir forall b t. Path b Dir -> Path Rel t -> Path b t </> [reldir|hix|] Path Rel Dir -> Path Rel Dir -> Path Rel Dir forall b t. Path b Dir -> Path Rel t -> Path b t </> Path Rel Dir user IO () -> ExceptT Error IO () forall a. IO a -> ExceptT Error IO a tryIO (Bool -> Path Abs Dir -> IO () 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 = IO (Path Abs File) -> ExceptT Error IO (Path Abs File) forall a. IO a -> ExceptT Error IO a tryIO do (Path Abs File path, Handle handle) <- Path Abs Dir -> FilePath -> IO (Path Abs File, 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 argFrag :: Text -> Text argFrag :: Text -> Text argFrag Text "" = Text "" argFrag Text s = [exon| #{s}|] optArg :: Maybe Text -> Text optArg :: Maybe Text -> Text optArg = (Text -> Text) -> Maybe Text -> Text forall m a. Monoid m => (a -> m) -> Maybe a -> m forall (t :: * -> *) m a. (Foldable t, Monoid m) => (a -> m) -> t a -> m foldMap Text -> Text argFrag 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 ":" (Path Abs Dir -> Text forall b t. Path b t -> Text pathText (Path Abs Dir -> Text) -> [Path Abs Dir] -> [Text] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> NonEmpty (Path Abs Dir) -> [Path Abs Dir] forall a. NonEmpty a -> [a] 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 test :: GhciTest scriptFile :: Path Abs File cmdline :: Text shell :: Text run :: Maybe Text $sel:test:GhciRun :: GhciTest $sel:shell:GhciRun :: Text $sel:run:GhciRun :: Maybe Text $sel:scriptFile:GhciRun :: Path Abs File $sel:cmdline:GhciRun :: Text ..} where cmdline :: Text cmdline = [exon|ghci#{shell}#{optArg run}|] shell :: Text shell = [exon|#{argFrag args}#{argFrag sp} -ghci-script=##{toFilePath scriptFile}#{argFrag extraOpts}|] args :: Text args = [Text] -> Text Text.unwords (GhciArgs -> [Text] forall a b. Coercible a b => a -> b coerce GhciTest test.args) run :: Maybe Text run = Maybe (Path Abs File) runScriptFile Maybe (Path Abs File) -> (Path Abs File -> Text) -> Maybe Text forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b <&> \ Path Abs File f -> [exon|-ghci-script=##{toFilePath f}|] sp :: Text sp = (NonEmpty (Path Abs Dir) -> Text) -> Maybe (NonEmpty (Path Abs Dir)) -> Text forall m a. Monoid m => (a -> m) -> Maybe a -> m forall (t :: * -> *) m a. (Foldable t, Monoid m) => (a -> m) -> t a -> m foldMap NonEmpty (Path Abs Dir) -> Text searchPathArg ([Path Abs Dir] -> Maybe (NonEmpty (Path Abs Dir)) forall a. [a] -> Maybe (NonEmpty a) nonEmpty GhciTest test.searchPath) extraOpts :: Text extraOpts | Just (ExtraGhciOptions Text o) <- Maybe ExtraGhciOptions extra = Text 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 <- ExceptT Error IO (Path Abs File) -> ReaderT Env (ExceptT Error IO) (Path Abs File) forall (m :: * -> *) a. Monad m => m a -> ReaderT Env m a 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 <- ExceptT Error IO (Maybe (Path Abs File)) -> ReaderT Env (ExceptT Error IO) (Maybe (Path Abs File)) forall (m :: * -> *) a. Monad m => m a -> ReaderT Env m a forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTrans t, Monad m) => m a -> t m a lift ((Text -> ExceptT Error IO (Path Abs File)) -> Maybe Text -> ExceptT Error IO (Maybe (Path Abs File)) forall (t :: * -> *) (f :: * -> *) a b. (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b) forall (f :: * -> *) a b. Applicative f => (a -> f b) -> Maybe a -> f (Maybe 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 = Text -> Maybe Text -> Text forall a. a -> Maybe a -> a fromMaybe Text "main" GhciRun ghci.test.test GhcidRun -> M GhcidRun forall a. a -> ReaderT Env (ExceptT Error IO) a 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 <- ExceptT Error IO (Path Abs Dir) -> M (Path Abs Dir) forall (m :: * -> *) a. Monad m => m a -> ReaderT Env m a 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 IO () -> M () forall a. IO a -> ReaderT Env (ExceptT Error IO) a 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 <- ExceptT Error IO (Path Abs Dir) -> M (Path Abs Dir) forall (m :: * -> *) a. Monad m => m a -> ReaderT Env m a 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 IO () -> M () forall a. IO a -> ReaderT Env (ExceptT Error IO) a forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (Text -> IO () Text.putStrLn GhcidRun cmd.cmdline)