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

import           Stack.Prelude
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
import           Distribution.Types.PackageName (mkPackageName)
import           Distribution.Types.VersionRange (withinRange)
import           Distribution.System        (Platform (..))
import qualified Pantry.SHA256 as SHA256
import           Path hiding (replaceExtension)
import           Path.IO
import qualified Stack.Build
import           Stack.Build.Installed
import           Stack.Constants            (osIsWindows)
import           Stack.PackageDump
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)
import qualified RIO.Directory as Dir
import           RIO.Process
import qualified RIO.Text as T

data StackScriptException
    = MutableDependenciesForScript [PackageName]
    | AmbiguousModuleName ModuleName [PackageName]
  deriving Typeable

instance Exception StackScriptException

instance Show StackScriptException where
    show :: StackScriptException -> String
show (MutableDependenciesForScript [PackageName]
names) = [String] -> String
unlines
        forall a b. (a -> b) -> a -> b
$ 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
    show (AmbiguousModuleName ModuleName
mname [PackageName]
pkgs) = [String] -> String
unlines
        forall a b. (a -> b) -> a -> b
$ (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 ]

-- | 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 (m :: * -> *) a. Monad m => a -> m a
return ()
      SYLNoProject [PackageIdentifierRevision]
_ -> forall a. HasCallStack => Bool -> a -> a
assert Bool
False (forall (m :: * -> *) a. Monad m => a -> m a
return ())

    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 :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString String
"--no-run incompatible with arguments"
        case ScriptExecute
shouldCompile of
          ScriptExecute
SEInterpret -> forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString String
"--no-run requires either --compile or --optimize"
          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 (m :: * -> *) a. Monad m => a -> m a
return 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 (m :: * -> *) a. Monad m => a -> m a
return 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 (m :: * -> *) a. Monad m => a -> m a
return forall a. Set a
Set.empty
                [PackageName
pn] -> forall (m :: * -> *) a. Monad m => a -> m a
return 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] -> StackScriptException
AmbiguousModuleName ModuleName
mn [PackageName]
pkgs
        forall (m :: * -> *) a. Monad m => a -> m a
return 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] -> StackScriptException
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 (m :: * -> *) a. Monad m => a -> m a
return 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 PackageIdentifier
Maybe License
Set ModuleName
PackageIdentifier
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 return 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
                )