{-# 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 ]
scriptCmd :: ScriptOpts -> RIO Runner ()
scriptCmd :: ScriptOpts -> RIO Runner ()
scriptCmd ScriptOpts
opts = do
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 ()
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
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
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
[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
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
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
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
-> 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
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
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
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
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
)