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