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)