{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# 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.PackageName (mkPackageName)
import           Distribution.Types.VersionRange (withinRange)
import           Distribution.System        (Platform (..))
import qualified Pantry.SHA256 as SHA256
#if MIN_VERSION_path(0,7,0)
import           Path hiding (replaceExtension)
#else
import           Path
#endif
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
        ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String
"No mutable packages are allowed in the `script` command. Mutable packages found:"
        String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (PackageName -> String) -> [PackageName] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\PackageName
name -> String
"- " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PackageName -> String
packageNameString PackageName
name) [PackageName]
names
    show (AmbiguousModuleName ModuleName
mname [PackageName]
pkgs) = [String] -> String
unlines
        ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (String
"Module " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ModuleName -> String
moduleNameString ModuleName
mname String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" appears in multiple packages: ")
        String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [[String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (PackageName -> String) -> [PackageName] -> [String]
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
    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
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 GlobalOpts -> StackYamlLoc
globalStackYaml) RIO Runner StackYamlLoc
-> (StackYamlLoc -> RIO Runner ()) -> RIO Runner ()
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
<>
        String -> Utf8Builder
forall a. IsString a => String -> a
fromString (Path Abs File -> String
forall b t. Path b t -> String
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 (m :: * -> *) a. Monad m => a -> m a
return ()
      SYLNoProject [PackageIdentifierRevision]
_ -> Bool -> RIO Runner () -> RIO Runner ()
forall a. HasCallStack => Bool -> a -> a
assert Bool
False (() -> RIO Runner ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())

    Path Abs File
file <- String -> RIO Runner (Path Abs File)
forall (m :: * -> *). MonadIO m => String -> m (Path Abs File)
resolveFile' (String -> RIO Runner (Path Abs File))
-> String -> RIO Runner (Path Abs File)
forall a b. (a -> b) -> a -> b
$ ScriptOpts -> String
soFile ScriptOpts
opts
    let scriptDir :: Path Abs Dir
scriptDir = Path Abs File -> Path Abs Dir
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 (Maybe Bool -> FirstTrue) -> Maybe Bool -> FirstTrue
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
                }
            , globalStackYaml :: StackYamlLoc
globalStackYaml = [PackageIdentifierRevision] -> StackYamlLoc
SYLNoProject ([PackageIdentifierRevision] -> StackYamlLoc)
-> [PackageIdentifierRevision] -> StackYamlLoc
forall a b. (a -> b) -> a -> b
$ ScriptOpts -> [PackageIdentifierRevision]
soScriptExtraDeps ScriptOpts
opts
            }

    -- Optimization: if we're compiling, and the executable is newer
    -- than the source file, run it immediately.
    (Runner -> Runner) -> RIO Runner () -> RIO Runner ()
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (ASetter Runner Runner GlobalOpts GlobalOpts
-> (GlobalOpts -> GlobalOpts) -> Runner -> Runner
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter Runner Runner GlobalOpts GlobalOpts
forall env. HasRunner env => Lens' env GlobalOpts
globalOptsL GlobalOpts -> GlobalOpts
modifyGO) (RIO Runner () -> RIO Runner ()) -> RIO Runner () -> RIO Runner ()
forall a b. (a -> b) -> a -> b
$
      case ScriptOpts -> ScriptExecute
soCompile ScriptOpts
opts of
        ScriptExecute
SEInterpret -> Path Abs File -> Path Abs Dir -> RIO Runner ()
forall b t b t a. Path b t -> Path b t -> RIO Runner a
longWay Path Abs File
file Path Abs Dir
scriptDir
        ScriptExecute
SECompile -> Path Abs File -> Path Abs Dir -> RIO Runner ()
forall b t b t a. Path b t -> Path b t -> RIO Runner a
shortCut Path Abs File
file Path Abs Dir
scriptDir
        ScriptExecute
SEOptimize -> Path Abs File -> Path Abs Dir -> RIO Runner ()
forall b t b t a. Path b t -> Path b t -> RIO Runner a
shortCut Path Abs File
file Path Abs Dir
scriptDir

  where
  shortCut :: Path b t -> Path b t -> RIO Runner a
shortCut Path b t
file Path b t
scriptDir = (IOException -> RIO Runner a) -> RIO Runner a -> RIO Runner a
forall (m :: * -> *) a.
MonadUnliftIO m =>
(IOException -> m a) -> m a -> m a
handleIO (RIO Runner a -> IOException -> RIO Runner a
forall a b. a -> b -> a
const (RIO Runner a -> IOException -> RIO Runner a)
-> RIO Runner a -> IOException -> RIO Runner a
forall a b. (a -> b) -> a -> b
$ Path b t -> Path b t -> RIO Runner a
forall b t b t a. Path b t -> Path b t -> RIO Runner a
longWay Path b t
file Path b t
scriptDir) (RIO Runner a -> RIO Runner a) -> RIO Runner a -> RIO Runner a
forall a b. (a -> b) -> a -> b
$ do
    UTCTime
srcMod <- Path b t -> RIO Runner UTCTime
forall (m :: * -> *) b t. MonadIO m => Path b t -> m UTCTime
getModificationTime Path b t
file
    UTCTime
exeMod <- String -> RIO Runner UTCTime
forall (m :: * -> *). MonadIO m => String -> m UTCTime
Dir.getModificationTime (String -> RIO Runner UTCTime) -> String -> RIO Runner UTCTime
forall a b. (a -> b) -> a -> b
$ ShowS
toExeName ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Path b t -> String
forall b t. Path b t -> String
toFilePath Path b t
file
    if UTCTime
srcMod UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
< UTCTime
exeMod
      then String -> [String] -> RIO Runner a
forall env b.
(HasProcessContext env, HasLogFunc env) =>
String -> [String] -> RIO env b
exec (ShowS
toExeName ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Path b t -> String
forall b t. Path b t -> String
toFilePath Path b t
file) (ScriptOpts -> [String]
soArgs ScriptOpts
opts)
      else Path b t -> Path b t -> RIO Runner a
forall b t b t a. Path b t -> Path b t -> RIO Runner a
longWay Path b t
file Path b t
scriptDir

  longWay :: Path b t -> Path b t -> RIO Runner a
longWay Path b t
file Path b t
scriptDir =
    ShouldReexec -> RIO Config a -> RIO Runner a
forall a. ShouldReexec -> RIO Config a -> RIO Runner a
withConfig ShouldReexec
YesReexec (RIO Config a -> RIO Runner a) -> RIO Config a -> RIO Runner a
forall a b. (a -> b) -> a -> b
$
    RIO EnvConfig a -> RIO Config a
forall a. RIO EnvConfig a -> RIO Config a
withDefaultEnvConfig (RIO EnvConfig a -> RIO Config a)
-> RIO EnvConfig a -> RIO Config a
forall a b. (a -> b) -> a -> b
$ do
      Config
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
configL
      ProcessContext
menv <- IO ProcessContext -> RIO EnvConfig ProcessContext
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ProcessContext -> RIO EnvConfig ProcessContext)
-> IO ProcessContext -> RIO EnvConfig ProcessContext
forall a b. (a -> b) -> a -> b
$ Config -> EnvSettings -> IO ProcessContext
configProcessContextSettings Config
config EnvSettings
defaultEnvSettings
      ProcessContext -> RIO EnvConfig a -> RIO EnvConfig a
forall env a.
HasProcessContext env =>
ProcessContext -> RIO env a -> RIO env a
withProcessContext ProcessContext
menv (RIO EnvConfig a -> RIO EnvConfig a)
-> RIO EnvConfig a -> RIO EnvConfig a
forall a b. (a -> b) -> a -> b
$ do
        Maybe String
colorFlag <- RIO EnvConfig (Maybe String)
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 = (String -> [String]) -> [String] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap String -> [String]
wordsComma [String]
packages
                    [PackageName]
targets' <- (String -> RIO EnvConfig PackageName)
-> [String] -> RIO EnvConfig [PackageName]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> RIO EnvConfig PackageName
forall (m :: * -> *). MonadThrow m => String -> m PackageName
parsePackageNameThrowing [String]
targets
                    Set PackageName -> RIO EnvConfig (Set PackageName)
forall (m :: * -> *) a. Monad m => a -> m a
return (Set PackageName -> RIO EnvConfig (Set PackageName))
-> Set PackageName -> RIO EnvConfig (Set PackageName)
forall a b. (a -> b) -> a -> b
$ [PackageName] -> Set PackageName
forall a. Ord a => [a] -> Set a
Set.fromList [PackageName]
targets'

        Bool -> RIO EnvConfig () -> RIO EnvConfig ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Set PackageName -> Bool
forall a. Set a -> Bool
Set.null Set PackageName
targetsSet) (RIO EnvConfig () -> RIO EnvConfig ())
-> RIO EnvConfig () -> RIO EnvConfig ()
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 <- Getting GhcPkgExe EnvConfig GhcPkgExe -> RIO EnvConfig GhcPkgExe
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting GhcPkgExe EnvConfig GhcPkgExe -> RIO EnvConfig GhcPkgExe)
-> Getting GhcPkgExe EnvConfig GhcPkgExe -> RIO EnvConfig GhcPkgExe
forall a b. (a -> b) -> a -> b
$ Getting GhcPkgExe EnvConfig CompilerPaths
forall env. HasCompiler env => SimpleGetter env CompilerPaths
compilerPathsLGetting GhcPkgExe EnvConfig CompilerPaths
-> ((GhcPkgExe -> Const GhcPkgExe GhcPkgExe)
    -> CompilerPaths -> Const GhcPkgExe CompilerPaths)
-> Getting GhcPkgExe EnvConfig GhcPkgExe
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(CompilerPaths -> GhcPkgExe)
-> SimpleGetter CompilerPaths GhcPkgExe
forall s a. (s -> a) -> SimpleGetter s a
to CompilerPaths -> GhcPkgExe
cpPkg
            [ByteString]
bss <- String
-> [String]
-> ConduitM ByteString Void (RIO EnvConfig) [ByteString]
-> RIO EnvConfig [ByteString]
forall env a.
(HasProcessContext env, HasLogFunc env, HasCallStack) =>
String
-> [String] -> ConduitM ByteString Void (RIO env) a -> RIO env a
sinkProcessStdout (Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
pkg)
                [String
"list", String
"--simple-output"] ConduitM ByteString Void (RIO EnvConfig) [ByteString]
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 = [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList
                          ([String] -> Set String) -> [String] -> Set String
forall a b. (a -> b) -> a -> b
$ ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ShowS
toPackageName
                          ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ String -> [String]
words
                          (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ ByteString -> String
S8.unpack
                          (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
S8.concat [ByteString]
bss
            if Set String -> Bool
forall a. Set a -> Bool
Set.null (Set String -> Bool) -> Set String -> Bool
forall a b. (a -> b) -> a -> b
$ Set String -> Set String -> Set String
forall a. Ord a => Set a -> Set a -> Set a
Set.difference ((PackageName -> String) -> Set PackageName -> Set String
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map PackageName -> String
packageNameString Set PackageName
targetsSet) Set String
installed
                then Utf8Builder -> RIO EnvConfig ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"All packages already installed"
                else do
                    Utf8Builder -> RIO EnvConfig ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Missing packages, performing installation"
                    let targets :: [Text]
targets = (PackageName -> Text) -> [PackageName] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Text
T.pack (String -> Text) -> (PackageName -> String) -> PackageName -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> String
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
                    [Text] -> RIO EnvConfig () -> RIO EnvConfig ()
forall env a. HasEnvConfig env => [Text] -> RIO env a -> RIO env a
withNewLocalBuildTargets [Text]
targets (RIO EnvConfig () -> RIO EnvConfig ())
-> RIO EnvConfig () -> RIO EnvConfig ()
forall a b. (a -> b) -> a -> b
$ Maybe (Set (Path Abs File) -> IO ()) -> RIO EnvConfig ()
forall env.
HasEnvConfig env =>
Maybe (Set (Path Abs File) -> IO ()) -> RIO env ()
Stack.Build.build Maybe (Set (Path Abs File) -> IO ())
forall a. Maybe a
Nothing

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

  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 :: String -> [String]
wordsComma = (Char -> Bool) -> String -> [String]
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
',')

  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) <- IO (Set PackageName, Set ModuleName)
-> RIO EnvConfig (Set PackageName, Set ModuleName)
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
<$> String -> IO ByteString
S8.readFile String
scriptFP
    if Set ModuleName -> Bool
forall a. Set a -> Bool
Set.null Set ModuleName
mns
        then Set PackageName -> RIO EnvConfig (Set PackageName)
forall (m :: * -> *) a. Monad m => a -> m a
return Set PackageName
pns
        else Set PackageName -> Set PackageName -> Set PackageName
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set PackageName
pns (Set PackageName -> Set PackageName)
-> RIO EnvConfig (Set PackageName)
-> RIO EnvConfig (Set PackageName)
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
    SnapshotCacheHash
-> RIO EnvConfig (Map PackageName (Set ModuleName))
-> ((ModuleName -> RIO EnvConfig [PackageName])
    -> RIO EnvConfig (Set PackageName))
-> RIO EnvConfig (Set PackageName)
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 (((ModuleName -> RIO EnvConfig [PackageName])
  -> RIO EnvConfig (Set PackageName))
 -> RIO EnvConfig (Set PackageName))
-> ((ModuleName -> RIO EnvConfig [PackageName])
    -> RIO EnvConfig (Set PackageName))
-> RIO EnvConfig (Set PackageName)
forall a b. (a -> b) -> a -> b
$ \ModuleName -> RIO EnvConfig [PackageName]
getModulePackages -> do
        [Set PackageName]
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
            [PackageName]
pkgs <- ModuleName -> RIO EnvConfig [PackageName]
getModulePackages ModuleName
mn
            case [PackageName]
pkgs of
                [] -> Set PackageName -> RIO EnvConfig (Set PackageName)
forall (m :: * -> *) a. Monad m => a -> m a
return Set PackageName
forall a. Set a
Set.empty
                [PackageName
pn] -> Set PackageName -> RIO EnvConfig (Set PackageName)
forall (m :: * -> *) a. Monad m => a -> m a
return (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]
_ -> StackScriptException -> RIO EnvConfig (Set PackageName)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (StackScriptException -> RIO EnvConfig (Set PackageName))
-> StackScriptException -> RIO EnvConfig (Set PackageName)
forall a b. (a -> b) -> a -> b
$ ModuleName -> [PackageName] -> StackScriptException
AmbiguousModuleName ModuleName
mn [PackageName]
pkgs
        Set PackageName -> RIO EnvConfig (Set PackageName)
forall (m :: * -> *) a. Monad m => a -> m a
return (Set PackageName -> RIO EnvConfig (Set PackageName))
-> Set PackageName -> RIO EnvConfig (Set PackageName)
forall a b. (a -> b) -> a -> b
$ [Set PackageName] -> Set PackageName
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions [Set PackageName]
pns Set PackageName -> Set PackageName -> Set PackageName
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 <- 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
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 EnvConfig -> SourceMap
envConfigSourceMap
    Builder
compilerInfo <- RIO EnvConfig Builder
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 =
                                    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 :: [(PackageName, DepPackage)]
deps = Map PackageName DepPackage -> [(PackageName, DepPackage)]
forall k a. Map k a -> [(k, a)]
Map.toList (SourceMap -> Map PackageName DepPackage
smDeps SourceMap
sourceMap)
    case [Either PackageName Builder] -> ([PackageName], [Builder])
forall a b. [Either a b] -> ([a], [b])
partitionEithers (((PackageName, DepPackage) -> Either PackageName Builder)
-> [(PackageName, DepPackage)] -> [Either PackageName Builder]
forall a b. (a -> b) -> [a] -> [b]
map (PackageName, DepPackage) -> Either PackageName Builder
forall a. (a, DepPackage) -> Either a Builder
eitherPliHash [(PackageName, DepPackage)]
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 (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]
_) ->
            StackScriptException -> RIO EnvConfig SnapshotCacheHash
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (StackScriptException -> RIO EnvConfig SnapshotCacheHash)
-> StackScriptException -> RIO EnvConfig SnapshotCacheHash
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 <- 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
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 EnvConfig -> SourceMap
envConfigSourceMap
    InstallMap
installMap <- SourceMap -> RIO EnvConfig InstallMap
forall (m :: * -> *). MonadIO m => SourceMap -> m InstallMap
toInstallMap SourceMap
sourceMap
    (InstalledMap
_installedMap, [DumpPackage]
globalDumpPkgs, [DumpPackage]
snapshotDumpPkgs, [DumpPackage]
_localDumpPkgs) <-
        InstallMap
-> RIO
     EnvConfig
     (InstalledMap, [DumpPackage], [DumpPackage], [DumpPackage])
forall env.
HasEnvConfig env =>
InstallMap
-> RIO
     env (InstalledMap, [DumpPackage], [DumpPackage], [DumpPackage])
getInstalled InstallMap
installMap
    let globals :: Map PackageName (Set ModuleName)
globals = Map PackageName GlobalPackage
-> [DumpPackage] -> Map PackageName (Set ModuleName)
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 = (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
. DepPackage -> Bool
dpHidden)
        notHiddenDeps :: Map PackageName DepPackage
notHiddenDeps = Map PackageName DepPackage -> Map PackageName DepPackage
forall k. Map k DepPackage -> Map k DepPackage
notHidden (Map PackageName DepPackage -> Map PackageName DepPackage)
-> Map PackageName DepPackage -> Map PackageName DepPackage
forall a b. (a -> b) -> a -> b
$ SourceMap -> Map PackageName DepPackage
smDeps SourceMap
sourceMap
        installedDeps :: Map PackageName (Set ModuleName)
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 :: Set PackageName
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
. DumpPackage -> PackageIdentifier
dpPackageIdent) [DumpPackage]
snapshotDumpPkgs
        notInstalledDeps :: Map PackageName DepPackage
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
    Map PackageName (Set ModuleName)
otherDeps <- Map PackageName DepPackage
-> (DepPackage -> RIO EnvConfig (Set ModuleName))
-> RIO EnvConfig (Map PackageName (Set ModuleName))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Map PackageName DepPackage
notInstalledDeps ((DepPackage -> RIO EnvConfig (Set ModuleName))
 -> RIO EnvConfig (Map PackageName (Set ModuleName)))
-> (DepPackage -> RIO EnvConfig (Set ModuleName))
-> RIO EnvConfig (Map PackageName (Set ModuleName))
forall a b. (a -> b) -> a -> b
$ \DepPackage
dep -> do
        GenericPackageDescription
gpd <- IO GenericPackageDescription
-> RIO EnvConfig GenericPackageDescription
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO GenericPackageDescription
 -> RIO EnvConfig GenericPackageDescription)
-> IO GenericPackageDescription
-> RIO EnvConfig GenericPackageDescription
forall a b. (a -> b) -> a -> b
$ CommonPackage -> IO GenericPackageDescription
cpGPD (DepPackage -> CommonPackage
dpCommon DepPackage
dep)
        [ModuleName] -> Set ModuleName
forall a. Ord a => [a] -> Set a
Set.fromList ([ModuleName] -> Set ModuleName)
-> RIO EnvConfig [ModuleName] -> RIO EnvConfig (Set ModuleName)
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
    Map PackageName (Set ModuleName)
-> RIO EnvConfig (Map PackageName (Set ModuleName))
forall (m :: * -> *) a. Monad m => a -> m a
return (Map PackageName (Set ModuleName)
 -> RIO EnvConfig (Map PackageName (Set ModuleName)))
-> Map PackageName (Set ModuleName)
-> RIO EnvConfig (Map PackageName (Set ModuleName))
forall a b. (a -> b) -> a -> b
$ Map PackageName (Set ModuleName)
globals Map PackageName (Set ModuleName)
-> Map PackageName (Set ModuleName)
-> Map PackageName (Set ModuleName)
forall a. Semigroup a => a -> a -> a
<> Map PackageName (Set ModuleName)
installedDeps Map PackageName (Set ModuleName)
-> Map PackageName (Set ModuleName)
-> Map PackageName (Set ModuleName)
forall a. Semigroup a => a -> a -> a
<> Map PackageName (Set ModuleName)
otherDeps

dumpedPackageModules :: Map PackageName a
                     -> [DumpPackage]
                     -> Map PackageName (Set ModuleName)
dumpedPackageModules :: 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, 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 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 Arch
curArch OS
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
platformL
  ActualCompiler
curCompiler <- Getting ActualCompiler EnvConfig ActualCompiler
-> RIO EnvConfig ActualCompiler
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ActualCompiler EnvConfig ActualCompiler
forall env. HasSourceMap env => SimpleGetter env ActualCompiler
actualCompilerVersionL
  let checkCond :: ConfVar -> Either ConfVar Bool
checkCond (PD.OS OS
os) = Bool -> Either ConfVar Bool
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 (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 (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 (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 :: Maybe Library
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
  [ModuleName] -> RIO EnvConfig [ModuleName]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([ModuleName] -> RIO EnvConfig [ModuleName])
-> [ModuleName] -> RIO EnvConfig [ModuleName]
forall a b. (a -> b) -> a -> b
$ case Maybe Library
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
PD.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
    [ 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 =
    [(Set PackageName, Set ModuleName)]
-> (Set PackageName, Set ModuleName)
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 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 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\r' = 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
        ByteString
bs1 <- ByteString -> ByteString -> Maybe ByteString
stripPrefix ByteString
"import " ByteString
bs0
        let bs2 :: ByteString
bs2 = (Char -> Bool) -> ByteString -> ByteString
S8.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') ByteString
bs1
            bs3 :: ByteString
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 ByteString -> ByteString -> Maybe ByteString
stripPrefix ByteString
"\"" ByteString
bs3 of
            Just ByteString
bs4 -> do
                PackageName
pn <- String -> Maybe PackageName
forall (m :: * -> *). MonadThrow m => String -> m PackageName
parsePackageNameThrowing (String -> Maybe PackageName) -> String -> Maybe PackageName
forall a b. (a -> b) -> a -> b
$ ByteString -> String
S8.unpack (ByteString -> String) -> ByteString -> String
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
                (Set PackageName, Set a) -> Maybe (Set PackageName, Set a)
forall a. a -> Maybe a
Just (PackageName -> Set PackageName
forall a. a -> Set a
Set.singleton PackageName
pn, Set a
forall a. Set a
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
$ String -> a
forall a. IsString a => String -> a
fromString
                    (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack
                    (Text -> String) -> Text -> String
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
                )