{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
module Stack.Script
    ( scriptCmd
    ) where

import           Data.ByteString.Builder ( toLazyByteString )
import qualified Data.ByteString.Char8 as S8
import qualified Data.Conduit.List as CL
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 ( parent )
import           Path.IO ( getModificationTime, resolveFile' )
import qualified RIO.Directory as Dir
import           RIO.Process ( exec, proc, readProcessStdout_, withWorkingDir )
import qualified RIO.Text as T
import qualified Stack.Build
import           Stack.Build.Installed
import           Stack.Constants ( osIsWindows )
import           Stack.PackageDump
import           Stack.Prelude
import           Stack.Options.ScriptParser
import           Stack.Runners
import           Stack.Setup ( withNewLocalBuildTargets )
import           Stack.SourceMap ( getCompilerInfo, immutableLocSha )
import           Stack.Types.Compiler
import           Stack.Types.Config
import           Stack.Types.SourceMap
import           System.FilePath ( dropExtension, replaceExtension )

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

-- "Stack.Script" module.

data ScriptException
    = MutableDependenciesForScript [PackageName]
    | AmbiguousModuleName ModuleName [PackageName]
    | ArgumentsWithNoRunInvalid
    | NoRunWithoutCompilationInvalid
  deriving (Int -> ScriptException -> ShowS
[ScriptException] -> ShowS
ScriptException -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ScriptException] -> ShowS
$cshowList :: [ScriptException] -> ShowS
show :: ScriptException -> String
$cshow :: ScriptException -> String
showsPrec :: Int -> ScriptException -> ShowS
$cshowsPrec :: Int -> ScriptException -> ShowS
Show, Typeable)

instance Exception ScriptException where
    displayException :: ScriptException -> String
displayException (MutableDependenciesForScript [PackageName]
names) = [String] -> String
unlines
        forall a b. (a -> b) -> a -> b
$ String
"Error: [S-4994]"
        forall a. a -> [a] -> [a]
: String
"No mutable packages are allowed in the 'script' command. Mutable \
          \packages found:"
        forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (\PackageName
name -> String
"- " forall a. [a] -> [a] -> [a]
++ PackageName -> String
packageNameString PackageName
name) [PackageName]
names
    displayException (AmbiguousModuleName ModuleName
mname [PackageName]
pkgs) = [String] -> String
unlines
        forall a b. (a -> b) -> a -> b
$ String
"Error: [S-1691]"
        forall a. a -> [a] -> [a]
: (  String
"Module "
          forall a. [a] -> [a] -> [a]
++ ModuleName -> String
moduleNameString ModuleName
mname
          forall a. [a] -> [a] -> [a]
++ String
" appears in multiple packages: "
          )
        forall a. a -> [a] -> [a]
: [ [String] -> String
unwords forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map PackageName -> String
packageNameString [PackageName]
pkgs ]
    displayException ScriptException
ArgumentsWithNoRunInvalid =
        String
"Error: [S-5067]\n"
        forall a. [a] -> [a] -> [a]
++ String
"'--no-run' incompatible with arguments."
    displayException ScriptException
NoRunWithoutCompilationInvalid =
        String
"Error: [S-9469]\n"
        forall a. [a] -> [a] -> [a]
++ String
"'--no-run' requires either '--compile' or '--optimize'."

-- | 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

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

    Path Abs File
file <- forall (m :: * -> *). MonadIO m => String -> m (Path Abs File)
resolveFile' forall a b. (a -> b) -> a -> b
$ ScriptOpts -> String
soFile ScriptOpts
opts

    Bool
isNoRunCompile <- FirstFalse -> Bool
fromFirstFalse forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConfigMonoid -> FirstFalse
configMonoidNoRunCompile forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                             forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (forall env. HasRunner env => Lens' env GlobalOpts
globalOptsLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to GlobalOpts -> ConfigMonoid
globalConfigMonoid)

    let scriptDir :: Path Abs Dir
scriptDir = forall b t. Path b t -> Path b Dir
parent Path Abs File
file
        modifyGO :: GlobalOpts -> GlobalOpts
modifyGO GlobalOpts
go = GlobalOpts
go
            { globalConfigMonoid :: ConfigMonoid
globalConfigMonoid = (GlobalOpts -> ConfigMonoid
globalConfigMonoid GlobalOpts
go)
                { configMonoidInstallGHC :: FirstTrue
configMonoidInstallGHC = Maybe Bool -> FirstTrue
FirstTrue forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Bool
True
                }
            , globalStackYaml :: StackYamlLoc
globalStackYaml = [PackageIdentifierRevision] -> StackYamlLoc
SYLNoProject forall a b. (a -> b) -> a -> b
$ ScriptOpts -> [PackageIdentifierRevision]
soScriptExtraDeps ScriptOpts
opts
            }
        (ShouldRun
shouldRun, ScriptExecute
shouldCompile) = if Bool
isNoRunCompile
          then (ShouldRun
NoRun, ScriptExecute
SECompile)
          else (ScriptOpts -> ShouldRun
soShouldRun ScriptOpts
opts, ScriptOpts -> ScriptExecute
soCompile ScriptOpts
opts)

    case ShouldRun
shouldRun of
      ShouldRun
YesRun -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      ShouldRun
NoRun -> do
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$ ScriptOpts -> [String]
soArgs ScriptOpts
opts) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO ScriptException
ArgumentsWithNoRunInvalid
        case ScriptExecute
shouldCompile of
          ScriptExecute
SEInterpret -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO ScriptException
NoRunWithoutCompilationInvalid
          ScriptExecute
SECompile -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          ScriptExecute
SEOptimize -> 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.

    forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over forall env. HasRunner env => Lens' env GlobalOpts
globalOptsL GlobalOpts -> GlobalOpts
modifyGO) forall a b. (a -> b) -> a -> b
$
      case ScriptExecute
shouldCompile of
        ScriptExecute
SEInterpret -> forall {b} {t} {b} {t}.
ShouldRun -> ScriptExecute -> Path b t -> Path b t -> RIO Runner ()
longWay ShouldRun
shouldRun ScriptExecute
shouldCompile Path Abs File
file Path Abs Dir
scriptDir
        ScriptExecute
SECompile -> forall {b} {t} {b} {t}.
ShouldRun -> ScriptExecute -> Path b t -> Path b t -> RIO Runner ()
shortCut ShouldRun
shouldRun ScriptExecute
shouldCompile Path Abs File
file Path Abs Dir
scriptDir
        ScriptExecute
SEOptimize -> forall {b} {t} {b} {t}.
ShouldRun -> ScriptExecute -> Path b t -> Path b t -> RIO Runner ()
shortCut ShouldRun
shouldRun ScriptExecute
shouldCompile Path Abs File
file Path Abs Dir
scriptDir

  where
  runCompiled :: ShouldRun -> Path b t -> RIO env ()
runCompiled ShouldRun
shouldRun Path b t
file = do
    let exeName :: String
exeName = ShowS
toExeName forall a b. (a -> b) -> a -> b
$ forall b t. Path b t -> String
toFilePath Path b t
file
    case ShouldRun
shouldRun of
      ShouldRun
YesRun -> forall env b.
(HasProcessContext env, HasLogFunc env) =>
String -> [String] -> RIO env b
exec String
exeName (ScriptOpts -> [String]
soArgs ScriptOpts
opts)
      ShouldRun
NoRun -> forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Compilation finished, executable available at " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => String -> a
fromString String
exeName

  shortCut :: ShouldRun -> ScriptExecute -> Path b t -> Path b t -> RIO Runner ()
shortCut ShouldRun
shouldRun ScriptExecute
shouldCompile Path b t
file Path b t
scriptDir =
    forall (m :: * -> *) a.
MonadUnliftIO m =>
(IOException -> m a) -> m a -> m a
handleIO (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall {b} {t} {b} {t}.
ShouldRun -> ScriptExecute -> Path b t -> Path b t -> RIO Runner ()
longWay ShouldRun
shouldRun ScriptExecute
shouldCompile Path b t
file Path b t
scriptDir) forall a b. (a -> b) -> a -> b
$ do
      UTCTime
srcMod <- forall (m :: * -> *) b t. MonadIO m => Path b t -> m UTCTime
getModificationTime Path b t
file
      UTCTime
exeMod <- forall (m :: * -> *). MonadIO m => String -> m UTCTime
Dir.getModificationTime forall a b. (a -> b) -> a -> b
$ ShowS
toExeName forall a b. (a -> b) -> a -> b
$ forall b t. Path b t -> String
toFilePath Path b t
file
      if UTCTime
srcMod forall a. Ord a => a -> a -> Bool
< UTCTime
exeMod
        then forall {env} {b} {t}.
(HasProcessContext env, HasLogFunc env) =>
ShouldRun -> Path b t -> RIO env ()
runCompiled ShouldRun
shouldRun Path b t
file
        else forall {b} {t} {b} {t}.
ShouldRun -> ScriptExecute -> Path b t -> Path b t -> RIO Runner ()
longWay ShouldRun
shouldRun ScriptExecute
shouldCompile Path b t
file Path b t
scriptDir

  longWay :: ShouldRun -> ScriptExecute -> Path b t -> Path b t -> RIO Runner ()
longWay ShouldRun
shouldRun ScriptExecute
shouldCompile Path b t
file Path b t
scriptDir =
    forall a. ShouldReexec -> RIO Config a -> RIO Runner a
withConfig ShouldReexec
YesReexec forall a b. (a -> b) -> a -> b
$
    forall a. RIO EnvConfig a -> RIO Config a
withDefaultEnvConfig forall a b. (a -> b) -> a -> b
$ do
      Config
config <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasConfig env => Lens' env Config
configL
      ProcessContext
menv <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Config -> EnvSettings -> IO ProcessContext
configProcessContextSettings Config
config EnvSettings
defaultEnvSettings
      forall env a.
HasProcessContext env =>
ProcessContext -> RIO env a -> RIO env a
withProcessContext ProcessContext
menv forall a b. (a -> b) -> a -> b
$ do
        Maybe String
colorFlag <- forall env.
(HasRunner env, HasEnvConfig env) =>
RIO env (Maybe String)
appropriateGhcColorFlag

        Set PackageName
targetsSet <-
            case ScriptOpts -> [String]
soPackages ScriptOpts
opts of
                [] -> do
                    -- Using the import parser

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

        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall a. Set a -> Bool
Set.null Set PackageName
targetsSet) forall a b. (a -> b) -> a -> b
$ 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.

            GhcPkgExe Path Abs File
pkg <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasCompiler env => SimpleGetter env CompilerPaths
compilerPathsLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to CompilerPaths -> GhcPkgExe
cpPkg
            -- https://github.com/haskell/process/issues/251

            [ByteString]
bss <- forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e o env.
(HasProcessContext env, HasLogFunc env, HasCallStack) =>
String
-> [String]
-> ConduitM ByteString Void (RIO env) e
-> ConduitM ByteString Void (RIO env) o
-> RIO env (e, o)
sinkProcessStderrStdout (forall b t. Path b t -> String
toFilePath Path Abs File
pkg)
                [String
"list", String
"--simple-output"] forall (m :: * -> *) i o. Monad m => ConduitT i o m ()
CL.sinkNull forall (m :: * -> *) a o. Monad m => ConduitT a o m [a]
CL.consume -- FIXME use the package info from envConfigPackages, or is that crazy?

            let installed :: Set String
installed = forall a. Ord a => [a] -> Set a
Set.fromList
                          forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ShowS
toPackageName
                          forall a b. (a -> b) -> a -> b
$ String -> [String]
words
                          forall a b. (a -> b) -> a -> b
$ ByteString -> String
S8.unpack
                          forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
S8.concat [ByteString]
bss
            if forall a. Set a -> Bool
Set.null forall a b. (a -> b) -> a -> b
$ forall a. Ord a => Set a -> Set a -> Set a
Set.difference (forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map PackageName -> String
packageNameString Set PackageName
targetsSet) Set String
installed
                then forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"All packages already installed"
                else do
                    forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Missing packages, performing installation"
                    let targets :: [Text]
targets = forall a b. (a -> b) -> [a] -> [b]
map (String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> String
packageNameString) forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
Set.toList Set PackageName
targetsSet
                    forall env a. HasEnvConfig env => [Text] -> RIO env a -> RIO env a
withNewLocalBuildTargets [Text]
targets forall a b. (a -> b) -> a -> b
$ forall env.
HasEnvConfig env =>
Maybe (Set (Path Abs File) -> IO ()) -> RIO env ()
Stack.Build.build forall a. Maybe a
Nothing

        let ghcArgs :: [String]
ghcArgs = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                [ [String
"-i", String
"-i" forall a. [a] -> [a] -> [a]
++ forall b t. Path b t -> String
toFilePath Path b t
scriptDir]
                , [String
"-hide-all-packages"]
                , forall a. Maybe a -> [a]
maybeToList Maybe String
colorFlag
                , forall a b. (a -> b) -> [a] -> [b]
map (\String
x -> String
"-package" forall a. [a] -> [a] -> [a]
++ String
x)
                    forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
Set.toList
                    forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> Set a -> Set a
Set.insert String
"base"
                    forall a b. (a -> b) -> a -> b
$ forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map PackageName -> String
packageNameString Set PackageName
targetsSet
                , case ScriptExecute
shouldCompile of
                    ScriptExecute
SEInterpret -> []
                    ScriptExecute
SECompile -> []
                    ScriptExecute
SEOptimize -> [String
"-O2"]
                , ScriptOpts -> [String]
soGhcOptions ScriptOpts
opts
                ]
        case ScriptExecute
shouldCompile of
          ScriptExecute
SEInterpret -> do
            Path Abs File
interpret <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasCompiler env => SimpleGetter env CompilerPaths
compilerPathsLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to CompilerPaths -> Path Abs File
cpInterpreter
            forall env b.
(HasProcessContext env, HasLogFunc env) =>
String -> [String] -> RIO env b
exec (forall b t. Path b t -> String
toFilePath Path Abs File
interpret)
                ([String]
ghcArgs forall a. [a] -> [a] -> [a]
++ forall b t. Path b t -> String
toFilePath Path b t
file forall a. a -> [a] -> [a]
: ScriptOpts -> [String]
soArgs ScriptOpts
opts)
          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.

            String
compilerExeName <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasCompiler env => SimpleGetter env CompilerPaths
compilerPathsLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to CompilerPaths -> Path Abs File
cpCompilerforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to forall b t. Path b t -> String
toFilePath
            forall env (m :: * -> *) a.
(HasProcessContext env, MonadReader env m, MonadIO m) =>
String -> m a -> m a
withWorkingDir (forall b t. Path b t -> String
toFilePath Path b t
scriptDir) forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
 MonadIO m, HasCallStack) =>
String -> [String] -> (ProcessConfig () () () -> m a) -> m a
proc
              String
compilerExeName
              ([String]
ghcArgs forall a. [a] -> [a] -> [a]
++ [forall b t. Path b t -> String
toFilePath Path b t
file])
              (forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) stdin stdoutIgnored stderr.
MonadIO m =>
ProcessConfig stdin stdoutIgnored stderr -> m ByteString
readProcessStdout_)
            forall {env} {b} {t}.
(HasProcessContext env, HasLogFunc env) =>
ShouldRun -> Path b t -> RIO env ()
runCompiled ShouldRun
shouldRun Path b t
file

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

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

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

  toExeName :: ShowS
toExeName String
fp =
    if Bool
osIsWindows
      then String -> ShowS
replaceExtension String
fp String
"exe"
      else ShowS
dropExtension String
fp

getPackagesFromImports
  :: FilePath -- ^ script filename

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

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

hashSnapshot :: RIO EnvConfig SnapshotCacheHash
hashSnapshot :: RIO EnvConfig SnapshotCacheHash
hashSnapshot = do
    SourceMap
sourceMap <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasEnvConfig env => Lens' env EnvConfig
envConfigL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. (s -> a) -> SimpleGetter s a
to EnvConfig -> SourceMap
envConfigSourceMap
    Builder
compilerInfo <- forall env. (HasConfig env, HasCompiler env) => RIO env Builder
getCompilerInfo
    let eitherPliHash :: (a, DepPackage) -> Either a Builder
eitherPliHash (a
pn, DepPackage
dep) | PLImmutable PackageLocationImmutable
pli <- DepPackage -> PackageLocation
dpLocation DepPackage
dep =
                                    forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ PackageLocationImmutable -> Builder
immutableLocSha PackageLocationImmutable
pli
                                | Bool
otherwise =
                                    forall a b. a -> Either a b
Left a
pn
        deps :: [(PackageName, DepPackage)]
deps = forall k a. Map k a -> [(k, a)]
Map.toList (SourceMap -> Map PackageName DepPackage
smDeps SourceMap
sourceMap)
    case forall a b. [Either a b] -> ([a], [b])
partitionEithers (forall a b. (a -> b) -> [a] -> [b]
map forall {a}. (a, DepPackage) -> Either a Builder
eitherPliHash [(PackageName, DepPackage)]
deps) of
        ([], [Builder]
pliHashes) -> do
            let hashedContent :: Builder
hashedContent = forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ Builder
compilerInfo forall a. a -> [a] -> [a]
: [Builder]
pliHashes
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ SHA256 -> SnapshotCacheHash
SnapshotCacheHash (ByteString -> SHA256
SHA256.hashLazyBytes forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
toLazyByteString Builder
hashedContent)
        ([PackageName]
mutables, [Builder]
_) ->
            forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM 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
sourceMap <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasEnvConfig env => Lens' env EnvConfig
envConfigL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. (s -> a) -> SimpleGetter s a
to EnvConfig -> SourceMap
envConfigSourceMap
    InstallMap
installMap <- forall (m :: * -> *). MonadIO m => SourceMap -> m InstallMap
toInstallMap SourceMap
sourceMap
    (InstalledMap
_installedMap, [DumpPackage]
globalDumpPkgs, [DumpPackage]
snapshotDumpPkgs, [DumpPackage]
_localDumpPkgs) <-
        forall env.
HasEnvConfig env =>
InstallMap
-> RIO
     env (InstalledMap, [DumpPackage], [DumpPackage], [DumpPackage])
getInstalled InstallMap
installMap
    let globals :: Map PackageName (Set ModuleName)
globals = forall a.
Map PackageName a
-> [DumpPackage] -> Map PackageName (Set ModuleName)
dumpedPackageModules (SourceMap -> Map PackageName GlobalPackage
smGlobal SourceMap
sourceMap) [DumpPackage]
globalDumpPkgs
        notHidden :: Map k DepPackage -> Map k DepPackage
notHidden = forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. DepPackage -> Bool
dpHidden)
        notHiddenDeps :: Map PackageName DepPackage
notHiddenDeps = forall {k}. Map k DepPackage -> Map k DepPackage
notHidden forall a b. (a -> b) -> a -> b
$ SourceMap -> Map PackageName DepPackage
smDeps SourceMap
sourceMap
        installedDeps :: Map PackageName (Set ModuleName)
installedDeps = forall a.
Map PackageName a
-> [DumpPackage] -> Map PackageName (Set ModuleName)
dumpedPackageModules Map PackageName DepPackage
notHiddenDeps [DumpPackage]
snapshotDumpPkgs
        dumpPkgs :: Set PackageName
dumpPkgs = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (PackageIdentifier -> PackageName
pkgName forall b c a. (b -> c) -> (a -> b) -> a -> c
. DumpPackage -> PackageIdentifier
dpPackageIdent) [DumpPackage]
snapshotDumpPkgs
        notInstalledDeps :: Map PackageName DepPackage
notInstalledDeps = forall k a. Ord k => Map k a -> Set k -> Map k a
Map.withoutKeys Map PackageName DepPackage
notHiddenDeps Set PackageName
dumpPkgs
    Map PackageName (Set ModuleName)
otherDeps <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Map PackageName DepPackage
notInstalledDeps forall a b. (a -> b) -> a -> b
$ \DepPackage
dep -> do
        GenericPackageDescription
gpd <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ CommonPackage -> IO GenericPackageDescription
cpGPD (DepPackage -> CommonPackage
dpCommon DepPackage
dep)
        forall a. Ord a => [a] -> Set a
Set.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenericPackageDescription -> RIO EnvConfig [ModuleName]
allExposedModules GenericPackageDescription
gpd
    -- source map construction process should guarantee unique package names

    -- in these maps

    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Map PackageName (Set ModuleName)
globals forall a. Semigroup a => a -> a -> a
<> Map PackageName (Set ModuleName)
installedDeps forall a. Semigroup a => a -> a -> a
<> Map PackageName (Set ModuleName)
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 = forall k a. Map k a -> Set k
Map.keysSet Map PackageName a
pkgs forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set PackageName
blacklist
    in forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
           [ (PackageName
pn, Set ModuleName
dpExposedModules)
           | DumpPackage {Bool
[String]
[Text]
[GhcPkgId]
Maybe String
Maybe License
Maybe PackageIdentifier
PackageIdentifier
Set ModuleName
GhcPkgId
dpIsExposed :: DumpPackage -> Bool
dpHaddockHtml :: DumpPackage -> Maybe String
dpHaddockInterfaces :: DumpPackage -> [String]
dpDepends :: DumpPackage -> [GhcPkgId]
dpExposedModules :: DumpPackage -> Set ModuleName
dpHasExposedModules :: DumpPackage -> Bool
dpLibraries :: DumpPackage -> [Text]
dpLibDirs :: DumpPackage -> [String]
dpLicense :: DumpPackage -> Maybe License
dpParentLibIdent :: DumpPackage -> Maybe PackageIdentifier
dpGhcPkgId :: DumpPackage -> GhcPkgId
dpIsExposed :: Bool
dpHaddockHtml :: Maybe String
dpHaddockInterfaces :: [String]
dpDepends :: [GhcPkgId]
dpHasExposedModules :: Bool
dpLibraries :: [Text]
dpLibDirs :: [String]
dpLicense :: Maybe License
dpParentLibIdent :: Maybe PackageIdentifier
dpPackageIdent :: PackageIdentifier
dpGhcPkgId :: GhcPkgId
dpExposedModules :: Set ModuleName
dpPackageIdent :: DumpPackage -> PackageIdentifier
..} <- [DumpPackage]
dumpPkgs
           , let PackageIdentifier PackageName
pn Version
_ = PackageIdentifier
dpPackageIdent
           , PackageName
pn 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 Arch
curArch OS
curOs <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasPlatform env => Lens' env Platform
platformL
  ActualCompiler
curCompiler <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasSourceMap env => SimpleGetter env ActualCompiler
actualCompilerVersionL
  let checkCond :: ConfVar -> Either ConfVar Bool
checkCond (PD.OS OS
os) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ OS
os forall a. Eq a => a -> a -> Bool
== OS
curOs
      checkCond (PD.Arch Arch
arch) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Arch
arch forall a. Eq a => a -> a -> Bool
== Arch
curArch
      checkCond (PD.Impl CompilerFlavor
compiler VersionRange
range) = case ActualCompiler
curCompiler of
        ACGhc Version
version ->
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ CompilerFlavor
compiler forall a. Eq a => a -> a -> Bool
== CompilerFlavor
GHC Bool -> Bool -> Bool
&& Version
version Version -> VersionRange -> Bool
`withinRange` VersionRange
range
        ACGhcGit {} ->
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ CompilerFlavor
compiler forall a. Eq a => a -> a -> Bool
== CompilerFlavor
GHC
      -- currently we don't do flag checking here

      checkCond ConfVar
other = forall a b. a -> Either a b
Left ConfVar
other
      mlibrary :: Maybe Library
mlibrary = forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenericPackageDescription
-> Maybe (CondTree ConfVar [Dependency] Library)
PD.condLibrary GenericPackageDescription
gpd
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case Maybe Library
mlibrary  of
    Just Library
lib -> Library -> [ModuleName]
PD.exposedModules Library
lib forall a. [a] -> [a] -> [a]
++
                forall a b. (a -> b) -> [a] -> [b]
map ModuleReexport -> ModuleName
moduleReexportName (Library -> [ModuleReexport]
PD.reexportedModules Library
lib)
    Maybe Library
Nothing  -> 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 = forall a. Ord a => [a] -> Set a
Set.fromList
    [ String -> PackageName
mkPackageName String
"async-dejafu"
    , String -> PackageName
mkPackageName String
"monads-tf"
    , String -> PackageName
mkPackageName String
"crypto-api"
    , String -> PackageName
mkPackageName String
"fay-base"
    , String -> PackageName
mkPackageName String
"hashmap"
    , String -> PackageName
mkPackageName String
"hxt-unicode"
    , String -> PackageName
mkPackageName String
"hledger-web"
    , String -> PackageName
mkPackageName String
"plot-gtk3"
    , String -> PackageName
mkPackageName String
"gtk3"
    , String -> PackageName
mkPackageName String
"regex-pcre-builtin"
    , String -> PackageName
mkPackageName String
"regex-compat-tdfa"
    , String -> PackageName
mkPackageName String
"log"
    , String -> PackageName
mkPackageName String
"zip"
    , String -> PackageName
mkPackageName String
"monad-extras"
    , String -> PackageName
mkPackageName String
"control-monad-free"
    , String -> PackageName
mkPackageName String
"prompt"
    , String -> PackageName
mkPackageName String
"kawhi"
    , String -> PackageName
mkPackageName String
"language-c"
    , String -> PackageName
mkPackageName String
"gl"
    , String -> PackageName
mkPackageName String
"svg-tree"
    , String -> PackageName
mkPackageName String
"Glob"
    , String -> PackageName
mkPackageName String
"nanospec"
    , String -> PackageName
mkPackageName String
"HTF"
    , String -> PackageName
mkPackageName String
"courier"
    , String -> PackageName
mkPackageName String
"newtype-generics"
    , String -> PackageName
mkPackageName String
"objective"
    , String -> PackageName
mkPackageName String
"binary-ieee754"
    , String -> PackageName
mkPackageName String
"rerebase"
    , String -> PackageName
mkPackageName String
"cipher-aes"
    , String -> PackageName
mkPackageName String
"cipher-blowfish"
    , String -> PackageName
mkPackageName String
"cipher-camellia"
    , String -> PackageName
mkPackageName String
"cipher-des"
    , String -> PackageName
mkPackageName String
"cipher-rc4"
    , String -> PackageName
mkPackageName String
"crypto-cipher-types"
    , String -> PackageName
mkPackageName String
"crypto-numbers"
    , String -> PackageName
mkPackageName String
"crypto-pubkey"
    , String -> PackageName
mkPackageName String
"crypto-random"
    , String -> PackageName
mkPackageName String
"cryptohash"
    , String -> PackageName
mkPackageName String
"cryptohash-conduit"
    , String -> PackageName
mkPackageName String
"cryptohash-md5"
    , String -> PackageName
mkPackageName String
"cryptohash-sha1"
    , String -> PackageName
mkPackageName String
"cryptohash-sha256"
    ]

parseImports :: ByteString -> (Set PackageName, Set ModuleName)
parseImports :: ByteString -> (Set PackageName, Set ModuleName)
parseImports =
    forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall {a}.
IsString a =>
ByteString -> Maybe (Set PackageName, Set a)
parseLine forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
stripCR') 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 forall a. Eq a => a -> a -> Bool
== Char
'\r' = HasCallStack => 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 = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
S8.drop (ByteString -> Int
S8.length ByteString
x) ByteString
y
      | Bool
otherwise = forall a. Maybe a
Nothing

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