{-# LANGUAGE NoImplicitPrelude     #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NoFieldSelectors      #-}
{-# LANGUAGE OverloadedRecordDot   #-}
{-# LANGUAGE OverloadedStrings     #-}

{-|
Module      : Stack.Script
Description : Types and functions related to Stack's @script@ command.
License     : BSD-3-Clause

Types and functions related to Stack's @script@ command.
-}

module Stack.Script
  ( ScriptOpts (..)
  , ScriptExecute (..)
  , ShouldRun (..)
  , scriptCmd
  ) where

import           Data.ByteString.Builder ( toLazyByteString )
import qualified Data.ByteString.Char8 as S8
import qualified Data.Conduit.List as CL
import qualified Data.List.NonEmpty as NE
import           Data.List.Split ( splitWhen )
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import           Distribution.Compiler ( CompilerFlavor (..) )
import           Distribution.ModuleName ( ModuleName )
import qualified Distribution.PackageDescription as PD
import qualified Distribution.Types.CondTree as C
import           Distribution.Types.ModuleReexport ( moduleReexportName )
import           Distribution.Types.PackageName ( mkPackageName )
import           Distribution.Types.VersionRange ( withinRange )
import           Distribution.System ( Platform (..) )
import qualified Pantry.SHA256 as SHA256
import           Path
                   ( (</>), filename, fromAbsDir, fromAbsFile, fromRelFile
                   , parent, parseRelDir, replaceExtension, splitExtension
                   )
import           Path.IO ( getModificationTime, resolveFile' )
import qualified RIO.Directory as Dir
import           RIO.Process
                   ( HasProcessContext, exec, proc, readProcessStdout_
                   , withWorkingDir
                   )
import qualified RIO.Text as T
import           Stack.Build ( build )
import           Stack.Build.Installed ( getInstalled, toInstallMap )
import           Stack.Constants ( osIsWindows, relDirScripts )
import           Stack.Prelude
import           Stack.Runners
                   ( ShouldReexec (..), withConfig, withDefaultEnvConfig )
import           Stack.Setup ( withNewLocalBuildTargets )
import           Stack.SourceMap ( getCompilerInfo, immutableLocSha )
import           Stack.Types.Compiler ( ActualCompiler (..) )
import           Stack.Types.CompilerPaths
                   ( CompilerPaths (..), GhcPkgExe (..), HasCompiler (..) )
import           Stack.Types.Config ( Config (..), HasConfig (..), stackRootL )
import           Stack.Types.ConfigMonoid ( ConfigMonoid (..) )
import qualified Stack.Types.ConfigMonoid as ConfigMonoid ( ConfigMonoid (..) )
import           Stack.Types.DumpPackage ( DumpPackage (..) )
import           Stack.Types.EnvConfig
                   ( EnvConfig (..), HasEnvConfig (..), actualCompilerVersionL
                   , appropriateGhcColorFlag
                   )
import           Stack.Types.EnvSettings ( defaultEnvSettings )
import           Stack.Types.GlobalOpts ( GlobalOpts (..) )
import           Stack.Types.Platform ( HasPlatform (..) )
import           Stack.Types.Runner ( Runner, globalOptsL )
import           Stack.Types.SourceMap
                   ( CommonPackage (..), DepPackage (..), SourceMap (..) )
import           Stack.Types.StackYamlLoc ( StackYamlLoc (..) )
import           System.FilePath ( splitDrive )

-- | Type representing exceptions thrown by functions exported by the

-- "Stack.Script" module.

data ScriptException
  = MutableDependenciesForScript [PackageName]
  | AmbiguousModuleName ModuleName [PackageName]
  | ArgumentsWithNoRunInvalid
  | NoRunWithoutCompilationInvalid
  | FailedToParseScriptFileAsDirBug (Path Rel File)
  | FailedToParseFileAsDirBug (Path Abs Dir)
  deriving Int -> ScriptException -> ShowS
[ScriptException] -> ShowS
ScriptException -> [Char]
(Int -> ScriptException -> ShowS)
-> (ScriptException -> [Char])
-> ([ScriptException] -> ShowS)
-> Show ScriptException
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ScriptException -> ShowS
showsPrec :: Int -> ScriptException -> ShowS
$cshow :: ScriptException -> [Char]
show :: ScriptException -> [Char]
$cshowList :: [ScriptException] -> ShowS
showList :: [ScriptException] -> ShowS
Show

instance Exception ScriptException where
  displayException :: ScriptException -> [Char]
displayException (MutableDependenciesForScript [PackageName]
names) = [[Char]] -> [Char]
unlines
    ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
"Error: [S-4994]"
    [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [Char]
"No mutable packages are allowed in the 'script' command. Mutable \
      \packages found:"
    [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: (PackageName -> [Char]) -> [PackageName] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (\PackageName
name -> [Char]
"- " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ PackageName -> [Char]
packageNameString PackageName
name) [PackageName]
names
  displayException (AmbiguousModuleName ModuleName
mname [PackageName]
pkgs) = [[Char]] -> [Char]
unlines
    ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
"Error: [S-1691]"
    [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: (  [Char]
"Module "
      [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ModuleName -> [Char]
moduleNameString ModuleName
mname
      [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" appears in multiple packages: "
      )
    [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [ [[Char]] -> [Char]
unwords ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ (PackageName -> [Char]) -> [PackageName] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map PackageName -> [Char]
packageNameString [PackageName]
pkgs ]
  displayException ScriptException
ArgumentsWithNoRunInvalid =
    [Char]
"Error: [S-5067]\n"
    [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"'--no-run' incompatible with arguments."
  displayException ScriptException
NoRunWithoutCompilationInvalid =
    [Char]
"Error: [S-9469]\n"
    [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"'--no-run' requires either '--compile' or '--optimize'."
  displayException (FailedToParseScriptFileAsDirBug Path Rel File
fp) = [Char] -> ShowS
bugReport [Char]
"[S-5055]" ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
       [Char]
"Failed to parse script file name as directory:\n"
    [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Path Rel File -> [Char]
fromRelFile Path Rel File
fp [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"\n"
  displayException (FailedToParseFileAsDirBug Path Abs Dir
p) = [Char] -> ShowS
bugReport [Char]
"[S-9464]" ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
       [Char]
"Failed to parse path to script file as directory:\n"
    [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Path Abs Dir -> [Char]
fromAbsDir Path Abs Dir
p [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"\n"

-- | Type representing choices of interpreting, compiling (without optimisation)

-- and compiling (with optimisation).

data ScriptExecute
  = SEInterpret
  | SECompile
    -- ^ Without optimisation.

  | SEOptimize
    -- ^ Compile with optimisation.

  deriving Int -> ScriptExecute -> ShowS
[ScriptExecute] -> ShowS
ScriptExecute -> [Char]
(Int -> ScriptExecute -> ShowS)
-> (ScriptExecute -> [Char])
-> ([ScriptExecute] -> ShowS)
-> Show ScriptExecute
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ScriptExecute -> ShowS
showsPrec :: Int -> ScriptExecute -> ShowS
$cshow :: ScriptExecute -> [Char]
show :: ScriptExecute -> [Char]
$cshowList :: [ScriptExecute] -> ShowS
showList :: [ScriptExecute] -> ShowS
Show

-- | Type representing choices of whether to run or not.

data ShouldRun
  = YesRun
    -- ^ Run.

  | NoRun
    -- ^ Do not run.

  deriving Int -> ShouldRun -> ShowS
[ShouldRun] -> ShowS
ShouldRun -> [Char]
(Int -> ShouldRun -> ShowS)
-> (ShouldRun -> [Char])
-> ([ShouldRun] -> ShowS)
-> Show ShouldRun
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ShouldRun -> ShowS
showsPrec :: Int -> ShouldRun -> ShowS
$cshow :: ShouldRun -> [Char]
show :: ShouldRun -> [Char]
$cshowList :: [ShouldRun] -> ShowS
showList :: [ShouldRun] -> ShowS
Show

-- | Type representing command line options for the @stack script@ command.

data ScriptOpts = ScriptOpts
  { ScriptOpts -> [[Char]]
packages :: ![String]
  , ScriptOpts -> [Char]
file :: !FilePath
  , ScriptOpts -> [[Char]]
args :: ![String]
  , ScriptOpts -> ScriptExecute
compile :: !ScriptExecute
  , ScriptOpts -> Bool
useRoot :: !Bool
  , ScriptOpts -> [[Char]]
ghcOptions :: ![String]
  , ScriptOpts -> [Unresolved (NonEmpty RawPackageLocationImmutable)]
scriptExtraDeps :: ![Unresolved (NonEmpty RawPackageLocationImmutable)]
  , ScriptOpts -> ShouldRun
shouldRun :: !ShouldRun
  }

-- | Run a Stack Script

scriptCmd :: ScriptOpts -> RIO Runner ()
scriptCmd :: ScriptOpts -> RIO Runner ()
scriptCmd ScriptOpts
opts = do
  -- Some warnings in case the user somehow tries to set a stack.yaml location.

  -- Note that in this functions we use logError instead of logWarn because,

  -- when using the interpreter mode, only error messages are shown. See:

  -- https://github.com/commercialhaskell/stack/issues/3007

  Getting StackYamlLoc Runner StackYamlLoc -> RIO Runner StackYamlLoc
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((GlobalOpts -> Const StackYamlLoc GlobalOpts)
-> Runner -> Const StackYamlLoc Runner
forall env. HasRunner env => Lens' env GlobalOpts
Lens' Runner GlobalOpts
globalOptsL ((GlobalOpts -> Const StackYamlLoc GlobalOpts)
 -> Runner -> Const StackYamlLoc Runner)
-> ((StackYamlLoc -> Const StackYamlLoc StackYamlLoc)
    -> GlobalOpts -> Const StackYamlLoc GlobalOpts)
-> Getting StackYamlLoc Runner StackYamlLoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GlobalOpts -> StackYamlLoc)
-> SimpleGetter GlobalOpts StackYamlLoc
forall s a. (s -> a) -> SimpleGetter s a
to (.stackYaml)) RIO Runner StackYamlLoc
-> (StackYamlLoc -> RIO Runner ()) -> RIO Runner ()
forall a b. RIO Runner a -> (a -> RIO Runner b) -> RIO Runner b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    SYLOverride Path Abs File
fp -> Utf8Builder -> RIO Runner ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError (Utf8Builder -> RIO Runner ()) -> Utf8Builder -> RIO Runner ()
forall a b. (a -> b) -> a -> b
$
         Utf8Builder
"Ignoring override stack.yaml file for script command: "
      Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> [Char] -> Utf8Builder
forall a. IsString a => [Char] -> a
fromString (Path Abs File -> [Char]
forall b t. Path b t -> [Char]
toFilePath Path Abs File
fp)
    StackYamlLoc
SYLGlobalProject -> Utf8Builder -> RIO Runner ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError Utf8Builder
"Ignoring SYLGlobalProject for script command"
    StackYamlLoc
SYLDefault -> () -> RIO Runner ()
forall a. a -> RIO Runner a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    SYLNoProject [RawPackageLocationImmutable]
_ -> Bool -> RIO Runner () -> RIO Runner ()
forall a. HasCallStack => Bool -> a -> a
assert Bool
False (() -> RIO Runner ()
forall a. a -> RIO Runner a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

  file <- [Char] -> RIO Runner (Path Abs File)
forall (m :: * -> *). MonadIO m => [Char] -> m (Path Abs File)
resolveFile' ScriptOpts
opts.file
  let scriptFile = Path Abs File -> Path Rel File
forall b. Path b File -> Path Rel File
filename Path Abs File
file
      scriptRoot = Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Path Abs File
file

  isNoRunCompile <- fromFirstFalse . (.noRunCompile) <$>
                           view (globalOptsL . to (.configMonoid))

  resolvedExtraDeps <-
    mapM (resolvePaths (Just scriptRoot)) opts.scriptExtraDeps
  let scriptDir = Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Path Abs File
file
      extraDeps = (NonEmpty RawPackageLocationImmutable
 -> [RawPackageLocationImmutable])
-> [NonEmpty RawPackageLocationImmutable]
-> [RawPackageLocationImmutable]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap NonEmpty RawPackageLocationImmutable
-> [RawPackageLocationImmutable]
forall a. NonEmpty a -> [a]
NE.toList [NonEmpty RawPackageLocationImmutable]
resolvedExtraDeps
      modifyGO GlobalOpts
go = GlobalOpts
go
        { configMonoid = go.configMonoid
            { ConfigMonoid.installGHC = FirstTrue $ Just True
            }
        , stackYaml = SYLNoProject extraDeps
        }
      (shouldRun, shouldCompile) = if isNoRunCompile
        then (NoRun, SECompile)
        else (opts.shouldRun, opts.compile)

  outputDir <- if opts.useRoot
    then do
      root <- local (over globalOptsL modifyGO) $
        withConfig NoReexec $ view stackRootL
      scriptFileAsDir <- maybe
        (throwIO $ FailedToParseScriptFileAsDirBug scriptFile)
        pure
        (parseRelDir $ fromRelFile scriptFile)
      let fileAsDir = Path Abs Dir
scriptDir Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
scriptFileAsDir
          -- We drop the information about the drive. On Windows, in principle,

          -- the drive could distinguish between two otherwise identical

          -- fileAsDir (eg C:\MyScript.hs\ D:\MyScript.hs\). In pactice, we

          -- tolerate that possibility as being unlikely.

          (_, escaped) = splitDrive (fromAbsDir fileAsDir)
      escapedRelDir <- maybe
        (throwIO $ FailedToParseFileAsDirBug fileAsDir)
        pure
        (parseRelDir escaped)
      pure $ root </> relDirScripts </> escapedRelDir
    else pure scriptDir

  -- path does not necessarily end with an extension.

  let dropExtension Path b File
path = Path b File -> f (Path b File)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path b File -> f (Path b File)) -> Path b File -> f (Path b File)
forall a b. (a -> b) -> a -> b
$ Path b File
-> ((Path b File, [Char]) -> Path b File)
-> Maybe (Path b File, [Char])
-> Path b File
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Path b File
path (Path b File, [Char]) -> Path b File
forall a b. (a, b) -> a
fst (Maybe (Path b File, [Char]) -> Path b File)
-> Maybe (Path b File, [Char]) -> Path b File
forall a b. (a -> b) -> a -> b
$ Path b File -> Maybe (Path b File, [Char])
forall (m :: * -> *) b.
MonadThrow m =>
Path b File -> m (Path b File, [Char])
splitExtension Path b File
path

  exe <- if osIsWindows
    then replaceExtension ".exe" (outputDir </> scriptFile)
    else dropExtension (outputDir </> scriptFile)

  case shouldRun of
    ShouldRun
YesRun -> () -> RIO Runner ()
forall a. a -> RIO Runner a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    ShouldRun
NoRun -> do
      Bool -> RIO Runner () -> RIO Runner ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([[Char]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ScriptOpts
opts.args) (RIO Runner () -> RIO Runner ()) -> RIO Runner () -> RIO Runner ()
forall a b. (a -> b) -> a -> b
$ ScriptException -> RIO Runner ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO ScriptException
ArgumentsWithNoRunInvalid
      case ScriptExecute
shouldCompile of
        ScriptExecute
SEInterpret -> ScriptException -> RIO Runner ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO ScriptException
NoRunWithoutCompilationInvalid
        ScriptExecute
SECompile -> () -> RIO Runner ()
forall a. a -> RIO Runner a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        ScriptExecute
SEOptimize -> () -> RIO Runner ()
forall a. a -> RIO Runner a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

  -- Optimization: if we're compiling, and the executable is newer than the

  -- source file, run it immediately.

  local (over globalOptsL modifyGO) $
    case shouldCompile of
      ScriptExecute
SEInterpret -> ShouldRun
-> ScriptExecute -> Path Abs File -> Path Abs File -> RIO Runner ()
longWay ShouldRun
shouldRun ScriptExecute
shouldCompile Path Abs File
file Path Abs File
exe
      ScriptExecute
SECompile -> ShouldRun
-> ScriptExecute -> Path Abs File -> Path Abs File -> RIO Runner ()
shortCut ShouldRun
shouldRun ScriptExecute
shouldCompile Path Abs File
file Path Abs File
exe
      ScriptExecute
SEOptimize -> ShouldRun
-> ScriptExecute -> Path Abs File -> Path Abs File -> RIO Runner ()
shortCut ShouldRun
shouldRun ScriptExecute
shouldCompile Path Abs File
file Path Abs File
exe

 where
  runCompiled ::
       (HasProcessContext env, HasTerm env)
    => ShouldRun
    -> Path Abs File
    -> RIO env ()
  runCompiled :: forall env.
(HasProcessContext env, HasTerm env) =>
ShouldRun -> Path Abs File -> RIO env ()
runCompiled ShouldRun
shouldRun Path Abs File
exe = do
    case ShouldRun
shouldRun of
      ShouldRun
YesRun -> [Char] -> [[Char]] -> RIO env ()
forall env b.
(HasProcessContext env, HasLogFunc env) =>
[Char] -> [[Char]] -> RIO env b
exec (Path Abs File -> [Char]
fromAbsFile Path Abs File
exe) ScriptOpts
opts.args
      ShouldRun
NoRun -> [StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyInfoL
        [ [Char] -> StyleDoc
flow [Char]
"Compilation finished, executable available at"
        , Style -> StyleDoc -> StyleDoc
style Style
File ([Char] -> StyleDoc
forall a. IsString a => [Char] -> a
fromString (Path Abs File -> [Char]
fromAbsFile Path Abs File
exe)) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
        ]

  shortCut :: ShouldRun
-> ScriptExecute -> Path Abs File -> Path Abs File -> RIO Runner ()
shortCut ShouldRun
shouldRun ScriptExecute
shouldCompile Path Abs File
file Path Abs File
exe =
    (IOException -> RIO Runner ()) -> RIO Runner () -> RIO Runner ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
(IOException -> m a) -> m a -> m a
handleIO (RIO Runner () -> IOException -> RIO Runner ()
forall a b. a -> b -> a
const (RIO Runner () -> IOException -> RIO Runner ())
-> RIO Runner () -> IOException -> RIO Runner ()
forall a b. (a -> b) -> a -> b
$ ShouldRun
-> ScriptExecute -> Path Abs File -> Path Abs File -> RIO Runner ()
longWay ShouldRun
shouldRun ScriptExecute
shouldCompile Path Abs File
file Path Abs File
exe) (RIO Runner () -> RIO Runner ()) -> RIO Runner () -> RIO Runner ()
forall a b. (a -> b) -> a -> b
$ do
      srcMod <- Path Abs File -> RIO Runner UTCTime
forall (m :: * -> *) b t. MonadIO m => Path b t -> m UTCTime
getModificationTime Path Abs File
file
      exeMod <- Dir.getModificationTime (fromAbsFile exe)
      if srcMod < exeMod
        then runCompiled shouldRun exe
        else longWay shouldRun shouldCompile file exe

  longWay :: ShouldRun
-> ScriptExecute -> Path Abs File -> Path Abs File -> RIO Runner ()
longWay ShouldRun
shouldRun ScriptExecute
shouldCompile Path Abs File
file Path Abs File
exe =
    ShouldReexec -> RIO Config () -> RIO Runner ()
forall a. ShouldReexec -> RIO Config a -> RIO Runner a
withConfig ShouldReexec
YesReexec (RIO Config () -> RIO Runner ()) -> RIO Config () -> RIO Runner ()
forall a b. (a -> b) -> a -> b
$
    RIO EnvConfig () -> RIO Config ()
forall a. RIO EnvConfig a -> RIO Config a
withDefaultEnvConfig (RIO EnvConfig () -> RIO Config ())
-> RIO EnvConfig () -> RIO Config ()
forall a b. (a -> b) -> a -> b
$ do
      config <- Getting Config EnvConfig Config -> RIO EnvConfig Config
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Config EnvConfig Config
forall env. HasConfig env => Lens' env Config
Lens' EnvConfig Config
configL
      menv <- liftIO $ config.processContextSettings defaultEnvSettings
      withProcessContext menv $ do
        colorFlag <- appropriateGhcColorFlag

        targetsSet <-
          case opts.packages of
            [] -> [Char] -> RIO EnvConfig (Set PackageName)
getPackagesFromImports ScriptOpts
opts.file -- Using the import parser

            [[Char]]
packages -> do
              let targets :: [[Char]]
targets = ([Char] -> [[Char]]) -> [[Char]] -> [[Char]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [Char] -> [[Char]]
wordsComma [[Char]]
packages
              targets' <- ([Char] -> RIO EnvConfig PackageName)
-> [[Char]] -> RIO EnvConfig [PackageName]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM [Char] -> RIO EnvConfig PackageName
forall (m :: * -> *). MonadThrow m => [Char] -> m PackageName
parsePackageNameThrowing [[Char]]
targets
              pure $ Set.fromList targets'

        GhcPkgExe pkg <- view $ compilerPathsL . to (.pkg)
        let ghcPkgPath = Path Abs File -> [Char]
forall b t. Path b t -> [Char]
toFilePath Path Abs File
pkg
        unless (Set.null targetsSet) $ do
          -- Optimization: use the relatively cheap ghc-pkg list --simple-output

          -- to check which packages are installed already. If all needed

          -- packages are available, we can skip the (rather expensive) build

          -- call below.

          -- https://github.com/haskell/process/issues/251

          bss <- snd <$> sinkProcessStderrStdout
                   ghcPkgPath
                   ["list", "--simple-output"]
                   CL.sinkNull
                   CL.consume
          -- ^ FIXME use the package info from envConfigPackages, or is that crazy?

          let installed = [[Char]] -> Set [Char]
forall a. Ord a => [a] -> Set a
Set.fromList
                        ([[Char]] -> Set [Char]) -> [[Char]] -> Set [Char]
forall a b. (a -> b) -> a -> b
$ ShowS -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ShowS
toPackageName
                        ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ [Char] -> [[Char]]
words
                        ([Char] -> [[Char]]) -> [Char] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ ByteString -> [Char]
S8.unpack
                        (ByteString -> [Char]) -> ByteString -> [Char]
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
S8.concat [ByteString]
bss
          if Set.null $ Set.difference (Set.map packageNameString targetsSet) installed
            then logDebug "All packages already installed"
            else do
              logDebug "Missing packages, performing installation"
              let targets =
                    (PackageName -> Text) -> [PackageName] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> Text
T.pack ([Char] -> Text) -> (PackageName -> [Char]) -> PackageName -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> [Char]
packageNameString) ([PackageName] -> [Text]) -> [PackageName] -> [Text]
forall a b. (a -> b) -> a -> b
$ Set PackageName -> [PackageName]
forall a. Set a -> [a]
Set.toList Set PackageName
targetsSet
              withNewLocalBuildTargets targets $ build Nothing

        let packagesSet = PackageName -> Set PackageName -> Set PackageName
forall a. Ord a => a -> Set a -> Set a
Set.insert ([Char] -> PackageName
mkPackageName [Char]
"base") Set PackageName
targetsSet
            -- Yields 'raw' strings with trailing whitespace. Assumes that the

            -- ghc-pkg application will find a package of the given name.

            getRawPackageId :: PackageName -> RIO EnvConfig [ByteString]
            getRawPackageId PackageName
target = ((), [ByteString]) -> [ByteString]
forall a b. (a, b) -> b
snd (((), [ByteString]) -> [ByteString])
-> RIO EnvConfig ((), [ByteString]) -> RIO EnvConfig [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char]
-> [[Char]]
-> ConduitM ByteString Void (RIO EnvConfig) ()
-> ConduitM ByteString Void (RIO EnvConfig) [ByteString]
-> RIO EnvConfig ((), [ByteString])
forall e o env.
(HasProcessContext env, HasLogFunc env, HasCallStack) =>
[Char]
-> [[Char]]
-> ConduitM ByteString Void (RIO env) e
-> ConduitM ByteString Void (RIO env) o
-> RIO env (e, o)
sinkProcessStderrStdout
              [Char]
ghcPkgPath
              [[Char]
"field", PackageName -> [Char]
packageNameString PackageName
target, [Char]
"id", [Char]
"--simple-output"]
              ConduitM ByteString Void (RIO EnvConfig) ()
forall (m :: * -> *) i o. Monad m => ConduitT i o m ()
CL.sinkNull
              ConduitM ByteString Void (RIO EnvConfig) [ByteString]
forall (m :: * -> *) a o. Monad m => ConduitT a o m [a]
CL.consume
        rawPackageIds <- mapM getRawPackageId $ Set.toList packagesSet
        let packageIds = [Char] -> [[Char]]
words ([Char] -> [[Char]]) -> [Char] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ ByteString -> [Char]
S8.unpack (ByteString -> [Char]) -> ByteString -> [Char]
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
S8.concat ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ [[ByteString]] -> [ByteString]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[ByteString]]
rawPackageIds
            -- ^ The use of words will eliminate whitespace between 'raw' items

            ghcArgs = [[[Char]]] -> [[Char]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
              [ [[Char]
"-i", [Char]
"-i" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Path Abs Dir -> [Char]
fromAbsDir (Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Path Abs File
file)]
              , [[Char]
"-hide-all-packages"]
              , Maybe [Char] -> [[Char]]
forall a. Maybe a -> [a]
maybeToList Maybe [Char]
colorFlag
                -- We use GHC's -package-id option rather than -package because

                -- there is a bug in the latter. For packages with a public

                -- sublibrary, -package <pkg> can expose an installed package

                -- that is not listed by ghc-pkg list <pkg>. See:

                -- https://gitlab.haskell.org/ghc/ghc/-/issues/25025

              , ShowS -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char]
"-package-id=" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++) [[Char]]
packageIds
              , case ScriptExecute
shouldCompile of
                  ScriptExecute
SEInterpret -> []
                  ScriptExecute
SECompile -> []
                  ScriptExecute
SEOptimize -> [[Char]
"-O2"]
              , ScriptOpts
opts.ghcOptions
              , if ScriptOpts
opts.useRoot
                  then
                    [ [Char]
"-outputdir=" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Path Abs Dir -> [Char]
fromAbsDir (Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Path Abs File
exe)
                    , [Char]
"-o", Path Abs File -> [Char]
fromAbsFile Path Abs File
exe
                    ]
                  else []
              ]
        case shouldCompile of
          ScriptExecute
SEInterpret -> do
            interpret <- Getting (Path Abs File) EnvConfig (Path Abs File)
-> RIO EnvConfig (Path Abs File)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting (Path Abs File) EnvConfig (Path Abs File)
 -> RIO EnvConfig (Path Abs File))
-> Getting (Path Abs File) EnvConfig (Path Abs File)
-> RIO EnvConfig (Path Abs File)
forall a b. (a -> b) -> a -> b
$ Getting (Path Abs File) EnvConfig CompilerPaths
forall env. HasCompiler env => SimpleGetter env CompilerPaths
SimpleGetter EnvConfig CompilerPaths
compilerPathsL Getting (Path Abs File) EnvConfig CompilerPaths
-> ((Path Abs File -> Const (Path Abs File) (Path Abs File))
    -> CompilerPaths -> Const (Path Abs File) CompilerPaths)
-> Getting (Path Abs File) EnvConfig (Path Abs File)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CompilerPaths -> Path Abs File)
-> SimpleGetter CompilerPaths (Path Abs File)
forall s a. (s -> a) -> SimpleGetter s a
to (.interpreter)
            exec (toFilePath interpret)
                (ghcArgs ++ toFilePath file : opts.args)
          ScriptExecute
_ -> do
            -- Use readProcessStdout_ so that (1) if GHC does send any output

            -- to stdout, we capture it and stop it from being sent to our

            -- stdout, which could break scripts, and (2) if there's an

            -- exception, the standard output we did capture will be reported

            -- to the user.

            IO () -> RIO EnvConfig ()
forall a. IO a -> RIO EnvConfig a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO EnvConfig ()) -> IO () -> RIO EnvConfig ()
forall a b. (a -> b) -> a -> b
$ Bool -> [Char] -> IO ()
forall (m :: * -> *). MonadIO m => Bool -> [Char] -> m ()
Dir.createDirectoryIfMissing Bool
True (Path Abs Dir -> [Char]
fromAbsDir (Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Path Abs File
exe))
            compilerExeName <-
              Getting [Char] EnvConfig [Char] -> RIO EnvConfig [Char]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting [Char] EnvConfig [Char] -> RIO EnvConfig [Char])
-> Getting [Char] EnvConfig [Char] -> RIO EnvConfig [Char]
forall a b. (a -> b) -> a -> b
$ Getting [Char] EnvConfig CompilerPaths
forall env. HasCompiler env => SimpleGetter env CompilerPaths
SimpleGetter EnvConfig CompilerPaths
compilerPathsL Getting [Char] EnvConfig CompilerPaths
-> (([Char] -> Const [Char] [Char])
    -> CompilerPaths -> Const [Char] CompilerPaths)
-> Getting [Char] EnvConfig [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CompilerPaths -> Path Abs File)
-> SimpleGetter CompilerPaths (Path Abs File)
forall s a. (s -> a) -> SimpleGetter s a
to (.compiler) Getting [Char] CompilerPaths (Path Abs File)
-> (([Char] -> Const [Char] [Char])
    -> Path Abs File -> Const [Char] (Path Abs File))
-> ([Char] -> Const [Char] [Char])
-> CompilerPaths
-> Const [Char] CompilerPaths
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Path Abs File -> [Char]) -> SimpleGetter (Path Abs File) [Char]
forall s a. (s -> a) -> SimpleGetter s a
to Path Abs File -> [Char]
forall b t. Path b t -> [Char]
toFilePath
            withWorkingDir (fromAbsDir (parent file)) $ proc
              compilerExeName
              (ghcArgs ++ [toFilePath file])
              (void . readProcessStdout_)
            runCompiled shouldRun exe

  toPackageName :: ShowS
toPackageName = ShowS
forall a. [a] -> [a]
reverse ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
1 ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'-') ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
forall a. [a] -> [a]
reverse

  -- Like words, but splits on both commas and spaces

  wordsComma :: [Char] -> [[Char]]
wordsComma = (Char -> Bool) -> [Char] -> [[Char]]
forall a. (a -> Bool) -> [a] -> [[a]]
splitWhen (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
',')

getPackagesFromImports ::
     FilePath -- ^ script filename

  -> RIO EnvConfig (Set PackageName)
getPackagesFromImports :: [Char] -> RIO EnvConfig (Set PackageName)
getPackagesFromImports [Char]
scriptFP = do
  (pns, mns) <- IO (Set PackageName, Set ModuleName)
-> RIO EnvConfig (Set PackageName, Set ModuleName)
forall a. IO a -> RIO EnvConfig a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Set PackageName, Set ModuleName)
 -> RIO EnvConfig (Set PackageName, Set ModuleName))
-> IO (Set PackageName, Set ModuleName)
-> RIO EnvConfig (Set PackageName, Set ModuleName)
forall a b. (a -> b) -> a -> b
$ ByteString -> (Set PackageName, Set ModuleName)
parseImports (ByteString -> (Set PackageName, Set ModuleName))
-> IO ByteString -> IO (Set PackageName, Set ModuleName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO ByteString
S8.readFile [Char]
scriptFP
  if Set.null mns
    then pure pns
    else Set.union pns <$> getPackagesFromModuleNames mns

getPackagesFromModuleNames ::
     Set ModuleName
  -> RIO EnvConfig (Set PackageName)
getPackagesFromModuleNames :: Set ModuleName -> RIO EnvConfig (Set PackageName)
getPackagesFromModuleNames Set ModuleName
mns = do
  hash <- RIO EnvConfig SnapshotCacheHash
hashSnapshot
  withSnapshotCache hash mapSnapshotPackageModules $ \ModuleName -> RIO EnvConfig [PackageName]
getModulePackages -> do
    pns <- [ModuleName]
-> (ModuleName -> RIO EnvConfig (Set PackageName))
-> RIO EnvConfig [Set PackageName]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Set ModuleName -> [ModuleName]
forall a. Set a -> [a]
Set.toList Set ModuleName
mns) ((ModuleName -> RIO EnvConfig (Set PackageName))
 -> RIO EnvConfig [Set PackageName])
-> (ModuleName -> RIO EnvConfig (Set PackageName))
-> RIO EnvConfig [Set PackageName]
forall a b. (a -> b) -> a -> b
$ \ModuleName
mn -> do
      pkgs <- ModuleName -> RIO EnvConfig [PackageName]
getModulePackages ModuleName
mn
      case pkgs of
        [] -> Set PackageName -> RIO EnvConfig (Set PackageName)
forall a. a -> RIO EnvConfig a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Set PackageName
forall a. Set a
Set.empty
        [PackageName
pn] -> Set PackageName -> RIO EnvConfig (Set PackageName)
forall a. a -> RIO EnvConfig a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Set PackageName -> RIO EnvConfig (Set PackageName))
-> Set PackageName -> RIO EnvConfig (Set PackageName)
forall a b. (a -> b) -> a -> b
$ PackageName -> Set PackageName
forall a. a -> Set a
Set.singleton PackageName
pn
        [PackageName]
_ -> ScriptException -> RIO EnvConfig (Set PackageName)
forall e a. (HasCallStack, Exception e) => e -> RIO EnvConfig a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (ScriptException -> RIO EnvConfig (Set PackageName))
-> ScriptException -> RIO EnvConfig (Set PackageName)
forall a b. (a -> b) -> a -> b
$ ModuleName -> [PackageName] -> ScriptException
AmbiguousModuleName ModuleName
mn [PackageName]
pkgs
    pure $ Set.unions pns `Set.difference` blacklist

hashSnapshot :: RIO EnvConfig SnapshotCacheHash
hashSnapshot :: RIO EnvConfig SnapshotCacheHash
hashSnapshot = do
  sourceMap <- Getting SourceMap EnvConfig SourceMap -> RIO EnvConfig SourceMap
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting SourceMap EnvConfig SourceMap -> RIO EnvConfig SourceMap)
-> Getting SourceMap EnvConfig SourceMap -> RIO EnvConfig SourceMap
forall a b. (a -> b) -> a -> b
$ (EnvConfig -> Const SourceMap EnvConfig)
-> EnvConfig -> Const SourceMap EnvConfig
forall env. HasEnvConfig env => Lens' env EnvConfig
Lens' EnvConfig EnvConfig
envConfigL ((EnvConfig -> Const SourceMap EnvConfig)
 -> EnvConfig -> Const SourceMap EnvConfig)
-> Getting SourceMap EnvConfig SourceMap
-> Getting SourceMap EnvConfig SourceMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EnvConfig -> SourceMap) -> SimpleGetter EnvConfig SourceMap
forall s a. (s -> a) -> SimpleGetter s a
to (.sourceMap)
  compilerInfo <- getCompilerInfo
  let eitherPliHash (a
pn, r
dep)
        | PLImmutable PackageLocationImmutable
pli <- r
dep.location = Builder -> Either a Builder
forall a b. b -> Either a b
Right (Builder -> Either a Builder) -> Builder -> Either a Builder
forall a b. (a -> b) -> a -> b
$ PackageLocationImmutable -> Builder
immutableLocSha PackageLocationImmutable
pli
        | Bool
otherwise = a -> Either a Builder
forall a b. a -> Either a b
Left a
pn
      deps = Map PackageName DepPackage -> [(PackageName, DepPackage)]
forall k a. Map k a -> [(k, a)]
Map.toList SourceMap
sourceMap.deps
  case partitionEithers (map eitherPliHash deps) of
    ([], [Builder]
pliHashes) -> do
      let hashedContent :: Builder
hashedContent = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> Builder) -> [Builder] -> Builder
forall a b. (a -> b) -> a -> b
$ Builder
compilerInfo Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
: [Builder]
pliHashes
      SnapshotCacheHash -> RIO EnvConfig SnapshotCacheHash
forall a. a -> RIO EnvConfig a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        (SnapshotCacheHash -> RIO EnvConfig SnapshotCacheHash)
-> SnapshotCacheHash -> RIO EnvConfig SnapshotCacheHash
forall a b. (a -> b) -> a -> b
$ SHA256 -> SnapshotCacheHash
SnapshotCacheHash (ByteString -> SHA256
SHA256.hashLazyBytes
        (ByteString -> SHA256) -> ByteString -> SHA256
forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
toLazyByteString Builder
hashedContent)
    ([PackageName]
mutables, [Builder]
_) -> ScriptException -> RIO EnvConfig SnapshotCacheHash
forall e a. (HasCallStack, Exception e) => e -> RIO EnvConfig a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (ScriptException -> RIO EnvConfig SnapshotCacheHash)
-> ScriptException -> RIO EnvConfig SnapshotCacheHash
forall a b. (a -> b) -> a -> b
$ [PackageName] -> ScriptException
MutableDependenciesForScript [PackageName]
mutables

mapSnapshotPackageModules :: RIO EnvConfig (Map PackageName (Set ModuleName))
mapSnapshotPackageModules :: RIO EnvConfig (Map PackageName (Set ModuleName))
mapSnapshotPackageModules = do
  sourceMap <- Getting SourceMap EnvConfig SourceMap -> RIO EnvConfig SourceMap
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting SourceMap EnvConfig SourceMap -> RIO EnvConfig SourceMap)
-> Getting SourceMap EnvConfig SourceMap -> RIO EnvConfig SourceMap
forall a b. (a -> b) -> a -> b
$ (EnvConfig -> Const SourceMap EnvConfig)
-> EnvConfig -> Const SourceMap EnvConfig
forall env. HasEnvConfig env => Lens' env EnvConfig
Lens' EnvConfig EnvConfig
envConfigL ((EnvConfig -> Const SourceMap EnvConfig)
 -> EnvConfig -> Const SourceMap EnvConfig)
-> Getting SourceMap EnvConfig SourceMap
-> Getting SourceMap EnvConfig SourceMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EnvConfig -> SourceMap) -> SimpleGetter EnvConfig SourceMap
forall s a. (s -> a) -> SimpleGetter s a
to (.sourceMap)
  installMap <- toInstallMap sourceMap
  (_installedMap, globalDumpPkgs, snapshotDumpPkgs, _localDumpPkgs) <-
    getInstalled installMap
  let globals = Map PackageName GlobalPackage
-> [DumpPackage] -> Map PackageName (Set ModuleName)
forall a.
Map PackageName a
-> [DumpPackage] -> Map PackageName (Set ModuleName)
dumpedPackageModules SourceMap
sourceMap.globalPkgs [DumpPackage]
globalDumpPkgs
      notHidden = (DepPackage -> Bool) -> Map k DepPackage -> Map k DepPackage
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (Bool -> Bool
not (Bool -> Bool) -> (DepPackage -> Bool) -> DepPackage -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.hidden))
      notHiddenDeps = Map PackageName DepPackage -> Map PackageName DepPackage
forall {k}. Map k DepPackage -> Map k DepPackage
notHidden SourceMap
sourceMap.deps
      installedDeps = Map PackageName DepPackage
-> [DumpPackage] -> Map PackageName (Set ModuleName)
forall a.
Map PackageName a
-> [DumpPackage] -> Map PackageName (Set ModuleName)
dumpedPackageModules Map PackageName DepPackage
notHiddenDeps [DumpPackage]
snapshotDumpPkgs
      dumpPkgs =
        [PackageName] -> Set PackageName
forall a. Ord a => [a] -> Set a
Set.fromList ([PackageName] -> Set PackageName)
-> [PackageName] -> Set PackageName
forall a b. (a -> b) -> a -> b
$ (DumpPackage -> PackageName) -> [DumpPackage] -> [PackageName]
forall a b. (a -> b) -> [a] -> [b]
map (PackageIdentifier -> PackageName
pkgName (PackageIdentifier -> PackageName)
-> (DumpPackage -> PackageIdentifier) -> DumpPackage -> PackageName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.packageIdent)) [DumpPackage]
snapshotDumpPkgs
      notInstalledDeps = Map PackageName DepPackage
-> Set PackageName -> Map PackageName DepPackage
forall k a. Ord k => Map k a -> Set k -> Map k a
Map.withoutKeys Map PackageName DepPackage
notHiddenDeps Set PackageName
dumpPkgs
  otherDeps <- for notInstalledDeps $ \DepPackage
dep -> do
    gpd <- IO GenericPackageDescription
-> RIO EnvConfig GenericPackageDescription
forall a. IO a -> RIO EnvConfig a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO DepPackage
dep.depCommon.gpd
    Set.fromList <$> allExposedModules gpd
  -- source map construction process should guarantee unique package names in

  -- these maps

  pure $ globals <> installedDeps <> otherDeps

dumpedPackageModules ::
     Map PackageName a
  -> [DumpPackage]
  -> Map PackageName (Set ModuleName)
dumpedPackageModules :: forall a.
Map PackageName a
-> [DumpPackage] -> Map PackageName (Set ModuleName)
dumpedPackageModules Map PackageName a
pkgs [DumpPackage]
dumpPkgs =
  let pnames :: Set PackageName
pnames = Map PackageName a -> Set PackageName
forall k a. Map k a -> Set k
Map.keysSet Map PackageName a
pkgs Set PackageName -> Set PackageName -> Set PackageName
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set PackageName
blacklist
  in  [(PackageName, Set ModuleName)] -> Map PackageName (Set ModuleName)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
        [ (PackageName
pn, DumpPackage
dp.exposedModules)
        | DumpPackage
dp <- [DumpPackage]
dumpPkgs
        , let PackageIdentifier PackageName
pn Version
_ = DumpPackage
dp.packageIdent
        , PackageName
pn PackageName -> Set PackageName -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set PackageName
pnames
        ]

allExposedModules :: PD.GenericPackageDescription -> RIO EnvConfig [ModuleName]
allExposedModules :: GenericPackageDescription -> RIO EnvConfig [ModuleName]
allExposedModules GenericPackageDescription
gpd = do
  Platform curArch curOs <- Getting Platform EnvConfig Platform -> RIO EnvConfig Platform
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Platform EnvConfig Platform
forall env. HasPlatform env => Lens' env Platform
Lens' EnvConfig Platform
platformL
  curCompiler <- view actualCompilerVersionL
  let checkCond (PD.OS OS
os) = Bool -> Either ConfVar Bool
forall a. a -> Either ConfVar a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Either ConfVar Bool) -> Bool -> Either ConfVar Bool
forall a b. (a -> b) -> a -> b
$ OS
os OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
curOs
      checkCond (PD.Arch Arch
arch) = Bool -> Either ConfVar Bool
forall a. a -> Either ConfVar a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Either ConfVar Bool) -> Bool -> Either ConfVar Bool
forall a b. (a -> b) -> a -> b
$ Arch
arch Arch -> Arch -> Bool
forall a. Eq a => a -> a -> Bool
== Arch
curArch
      checkCond (PD.Impl CompilerFlavor
compiler VersionRange
range) = case ActualCompiler
curCompiler of
        ACGhc Version
version ->
          Bool -> Either ConfVar Bool
forall a. a -> Either ConfVar a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Either ConfVar Bool) -> Bool -> Either ConfVar Bool
forall a b. (a -> b) -> a -> b
$ CompilerFlavor
compiler CompilerFlavor -> CompilerFlavor -> Bool
forall a. Eq a => a -> a -> Bool
== CompilerFlavor
GHC Bool -> Bool -> Bool
&& Version
version Version -> VersionRange -> Bool
`withinRange` VersionRange
range
        ACGhcGit {} ->
          Bool -> Either ConfVar Bool
forall a. a -> Either ConfVar a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Either ConfVar Bool) -> Bool -> Either ConfVar Bool
forall a b. (a -> b) -> a -> b
$ CompilerFlavor
compiler CompilerFlavor -> CompilerFlavor -> Bool
forall a. Eq a => a -> a -> Bool
== CompilerFlavor
GHC
      -- currently we don't do flag checking here

      checkCond ConfVar
other = ConfVar -> Either ConfVar Bool
forall a b. a -> Either a b
Left ConfVar
other
      mlibrary = ([Dependency], Library) -> Library
forall a b. (a, b) -> b
snd (([Dependency], Library) -> Library)
-> (CondTree ConfVar [Dependency] Library
    -> ([Dependency], Library))
-> CondTree ConfVar [Dependency] Library
-> Library
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ConfVar -> Either ConfVar Bool)
-> CondTree ConfVar [Dependency] Library -> ([Dependency], Library)
forall a d v.
(Semigroup a, Semigroup d) =>
(v -> Either v Bool) -> CondTree v d a -> (d, a)
C.simplifyCondTree ConfVar -> Either ConfVar Bool
checkCond (CondTree ConfVar [Dependency] Library -> Library)
-> Maybe (CondTree ConfVar [Dependency] Library) -> Maybe Library
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenericPackageDescription
-> Maybe (CondTree ConfVar [Dependency] Library)
PD.condLibrary GenericPackageDescription
gpd
  pure $ case mlibrary of
    Just Library
lib -> Library -> [ModuleName]
PD.exposedModules Library
lib [ModuleName] -> [ModuleName] -> [ModuleName]
forall a. [a] -> [a] -> [a]
++
                (ModuleReexport -> ModuleName) -> [ModuleReexport] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map ModuleReexport -> ModuleName
moduleReexportName (Library -> [ModuleReexport]
PD.reexportedModules Library
lib)
    Maybe Library
Nothing  -> [ModuleName]
forall a. Monoid a => a
mempty

-- | The Stackage project introduced the concept of hidden packages, to deal

-- with conflicting module names. However, this is a relatively recent addition

-- (at time of writing). See:

-- http://www.snoyman.com/blog/2017/01/conflicting-module-names. To kick this

-- thing off a bit better, we're included a blacklist of packages that should

-- never be auto-parsed in.

blacklist :: Set PackageName
blacklist :: Set PackageName
blacklist = [PackageName] -> Set PackageName
forall a. Ord a => [a] -> Set a
Set.fromList
  [ [Char] -> PackageName
mkPackageName [Char]
"Glob"
  , [Char] -> PackageName
mkPackageName [Char]
"HTF"
  , [Char] -> PackageName
mkPackageName [Char]
"async-dejafu"
  , [Char] -> PackageName
mkPackageName [Char]
"binary-ieee754"
  , [Char] -> PackageName
mkPackageName [Char]
"cipher-aes"
  , [Char] -> PackageName
mkPackageName [Char]
"cipher-blowfish"
  , [Char] -> PackageName
mkPackageName [Char]
"cipher-camellia"
  , [Char] -> PackageName
mkPackageName [Char]
"cipher-des"
  , [Char] -> PackageName
mkPackageName [Char]
"cipher-rc4"
  , [Char] -> PackageName
mkPackageName [Char]
"control-monad-free"
  , [Char] -> PackageName
mkPackageName [Char]
"courier"
  , [Char] -> PackageName
mkPackageName [Char]
"crypto-api"
  , [Char] -> PackageName
mkPackageName [Char]
"crypto-cipher-types"
  , [Char] -> PackageName
mkPackageName [Char]
"crypto-numbers"
  , [Char] -> PackageName
mkPackageName [Char]
"crypto-pubkey"
  , [Char] -> PackageName
mkPackageName [Char]
"crypto-random"
  , [Char] -> PackageName
mkPackageName [Char]
"cryptohash"
  , [Char] -> PackageName
mkPackageName [Char]
"cryptohash-conduit"
  , [Char] -> PackageName
mkPackageName [Char]
"cryptohash-md5"
  , [Char] -> PackageName
mkPackageName [Char]
"cryptohash-sha1"
  , [Char] -> PackageName
mkPackageName [Char]
"cryptohash-sha256"
  , [Char] -> PackageName
mkPackageName [Char]
"fay-base"
  , [Char] -> PackageName
mkPackageName [Char]
"gl"
  , [Char] -> PackageName
mkPackageName [Char]
"gtk3"
  , [Char] -> PackageName
mkPackageName [Char]
"hashmap"
  , [Char] -> PackageName
mkPackageName [Char]
"hledger-web"
  , [Char] -> PackageName
mkPackageName [Char]
"hxt-unicode"
  , [Char] -> PackageName
mkPackageName [Char]
"kawhi"
  , [Char] -> PackageName
mkPackageName [Char]
"language-c"
  , [Char] -> PackageName
mkPackageName [Char]
"log"
  , [Char] -> PackageName
mkPackageName [Char]
"monad-extras"
  , [Char] -> PackageName
mkPackageName [Char]
"monads-tf"
  , [Char] -> PackageName
mkPackageName [Char]
"nanospec"
  , [Char] -> PackageName
mkPackageName [Char]
"newtype-generics"
  , [Char] -> PackageName
mkPackageName [Char]
"objective"
  , [Char] -> PackageName
mkPackageName [Char]
"plot-gtk3"
  , [Char] -> PackageName
mkPackageName [Char]
"prompt"
  , [Char] -> PackageName
mkPackageName [Char]
"regex-compat-tdfa"
  , [Char] -> PackageName
mkPackageName [Char]
"regex-pcre-builtin"
  , [Char] -> PackageName
mkPackageName [Char]
"rerebase"
  , [Char] -> PackageName
mkPackageName [Char]
"svg-tree"
  , [Char] -> PackageName
mkPackageName [Char]
"zip"
  ]

parseImports :: ByteString -> (Set PackageName, Set ModuleName)
parseImports :: ByteString -> (Set PackageName, Set ModuleName)
parseImports =
  [(Set PackageName, Set ModuleName)]
-> (Set PackageName, Set ModuleName)
forall a. Monoid a => [a] -> a
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold ([(Set PackageName, Set ModuleName)]
 -> (Set PackageName, Set ModuleName))
-> (ByteString -> [(Set PackageName, Set ModuleName)])
-> ByteString
-> (Set PackageName, Set ModuleName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Maybe (Set PackageName, Set ModuleName))
-> [ByteString] -> [(Set PackageName, Set ModuleName)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (ByteString -> Maybe (Set PackageName, Set ModuleName)
forall {a}.
IsString a =>
ByteString -> Maybe (Set PackageName, Set a)
parseLine (ByteString -> Maybe (Set PackageName, Set ModuleName))
-> (ByteString -> ByteString)
-> ByteString
-> Maybe (Set PackageName, Set ModuleName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
stripCR') ([ByteString] -> [(Set PackageName, Set ModuleName)])
-> (ByteString -> [ByteString])
-> ByteString
-> [(Set PackageName, Set ModuleName)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
S8.lines
 where
  -- Remove any carriage pure character present at the end, to support

  -- Windows-style line endings (CRLF)

  stripCR' :: ByteString -> ByteString
stripCR' ByteString
bs
    | ByteString -> Bool
S8.null ByteString
bs = ByteString
bs
    | ByteString -> Char
S8.last ByteString
bs Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\r' = HasCallStack => ByteString -> ByteString
ByteString -> ByteString
S8.init ByteString
bs
    | Bool
otherwise = ByteString
bs

  stripPrefix :: ByteString -> ByteString -> Maybe ByteString
stripPrefix ByteString
x ByteString
y
    | ByteString
x ByteString -> ByteString -> Bool
`S8.isPrefixOf` ByteString
y = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
S8.drop (ByteString -> Int
S8.length ByteString
x) ByteString
y
    | Bool
otherwise = Maybe ByteString
forall a. Maybe a
Nothing

  parseLine :: ByteString -> Maybe (Set PackageName, Set a)
parseLine ByteString
bs0 = do
    bs1 <- ByteString -> ByteString -> Maybe ByteString
stripPrefix ByteString
"import " ByteString
bs0
    let bs2 = (Char -> Bool) -> ByteString -> ByteString
S8.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') ByteString
bs1
        bs3 = ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
bs2 (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> Maybe ByteString
stripPrefix ByteString
"qualified " ByteString
bs2
    case stripPrefix "\"" bs3 of
      Just ByteString
bs4 -> do
        pn <- [Char] -> Maybe PackageName
forall (m :: * -> *). MonadThrow m => [Char] -> m PackageName
parsePackageNameThrowing ([Char] -> Maybe PackageName) -> [Char] -> Maybe PackageName
forall a b. (a -> b) -> a -> b
$ ByteString -> [Char]
S8.unpack (ByteString -> [Char]) -> ByteString -> [Char]
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ByteString -> ByteString
S8.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'"') ByteString
bs4
        Just (Set.singleton pn, Set.empty)
      Maybe ByteString
Nothing -> (Set PackageName, Set a) -> Maybe (Set PackageName, Set a)
forall a. a -> Maybe a
Just
        ( Set PackageName
forall a. Set a
Set.empty
        , a -> Set a
forall a. a -> Set a
Set.singleton
            (a -> Set a) -> a -> Set a
forall a b. (a -> b) -> a -> b
$ [Char] -> a
forall a. IsString a => [Char] -> a
fromString
            ([Char] -> a) -> [Char] -> a
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack
            (Text -> [Char]) -> Text -> [Char]
forall a b. (a -> b) -> a -> b
$ OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode
            (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ByteString -> ByteString
S8.takeWhile (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
' ' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'(') ByteString
bs3
        )