module Stack.Build.Types
(StackBuildException(..)
,InstallLocation(..)
,ModTime
,modTime
,Installed(..)
,PackageInstallInfo(..)
,Task(..)
,LocalPackage(..)
,BaseConfigOpts(..)
,Plan(..)
,FinalAction(..)
,BuildOpts(..)
,TaskType(..)
,TaskConfigOpts(..)
,ConfigCache(..)
,ConstructPlanException(..)
,configureOpts
,BadDependency(..)
,wantedLocalPackages)
where
import Control.DeepSeq
import Control.Exception
import Data.Binary (Binary(..))
import qualified Data.ByteString as S
import Data.Char (isSpace)
import Data.Data
import Data.Hashable
import Data.List (dropWhileEnd, nub, intercalate)
import qualified Data.Map as Map
import Data.Map.Strict (Map)
import Data.Maybe
import Data.Monoid
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)
import Data.Time.Calendar
import Data.Time.Clock
import Distribution.System (Arch)
import Distribution.Text (display)
import GHC.Generics
import Path (Path, Abs, File, Dir, mkRelDir, toFilePath, parseRelDir, (</>))
import Prelude
import Stack.Package
import Stack.Types
import System.Exit (ExitCode)
import System.FilePath (dropTrailingPathSeparator, pathSeparator)
data StackBuildException
= Couldn'tFindPkgId PackageName
| GHCVersionMismatch (Maybe (Version, Arch)) (Version, Arch) (Maybe (Path Abs File))
| Couldn'tParseTargets [Text]
| UnknownTargets
(Set PackageName)
(Map PackageName Version)
(Path Abs File)
| TestSuiteFailure PackageIdentifier (Map Text (Maybe ExitCode)) (Maybe (Path Abs File)) S.ByteString
| ConstructPlanExceptions
[ConstructPlanException]
(Path Abs File)
| CabalExitedUnsuccessfully
ExitCode
PackageIdentifier
(Path Abs File)
[String]
(Maybe (Path Abs File))
S.ByteString
| ExecutionFailure [SomeException]
deriving Typeable
instance Show StackBuildException where
show (Couldn'tFindPkgId name) =
("After installing " <> packageNameString name <>
", the package id couldn't be found " <> "(via ghc-pkg describe " <>
packageNameString name <> "). This shouldn't happen, " <>
"please report as a bug")
show (GHCVersionMismatch mactual (expected, earch) mstack) = concat
[ case mactual of
Nothing -> "No GHC found, expected version "
Just (actual, arch) -> concat
[ "GHC version mismatched, found "
, versionString actual
, " ("
, display arch
, ")"
, ", but expected version "
]
, versionString expected
, " ("
, display earch
, ") (based on "
, case mstack of
Nothing -> "command line arguments"
Just stack -> "resolver setting in " ++ toFilePath stack
, "). Try running stack setup"
]
show (Couldn'tParseTargets targets) = unlines
$ "The following targets could not be parsed as package names or directories:"
: map T.unpack targets
show (UnknownTargets noKnown notInSnapshot stackYaml) =
unlines $ noKnown' ++ notInSnapshot'
where
noKnown'
| Set.null noKnown = []
| otherwise = return $
"The following target packages were not found: " ++
intercalate ", " (map packageNameString $ Set.toList noKnown)
notInSnapshot'
| Map.null notInSnapshot = []
| otherwise =
"The following packages are not in your snapshot, but exist"
: "in your package index. Recommended action: add them to your"
: ("extra-deps in " ++ toFilePath stackYaml)
: "(Note: these are the most recent versions,"
: "but there's no guarantee that they'll build together)."
: ""
: map
(\(name, version) -> "- " ++ packageIdentifierString
(PackageIdentifier name version))
(Map.toList notInSnapshot)
show (TestSuiteFailure ident codes mlogFile bs) = unlines $ concat
[ ["Test suite failure for package " ++ packageIdentifierString ident]
, flip map (Map.toList codes) $ \(name, mcode) -> concat
[ " "
, T.unpack name
, ": "
, case mcode of
Nothing -> " executable not found"
Just ec -> " exited with: " ++ show ec
]
, return $ case mlogFile of
Nothing -> "Logs printed to console"
Just logFile -> "Full log available at " ++ toFilePath logFile
, if S.null bs
then []
else ["", "", doubleIndent $ T.unpack $ decodeUtf8With lenientDecode bs]
]
where
indent = dropWhileEnd isSpace . unlines . fmap (\line -> " " ++ line) . lines
doubleIndent = indent . indent
show (ConstructPlanExceptions exceptions stackYaml) =
"While constructing the BuildPlan the following exceptions were encountered:" ++
appendExceptions exceptions' ++
if Map.null extras then "" else (unlines
$ ("\n\nRecommended action: try adding the following to your extra-deps in "
++ toFilePath stackYaml)
: map (\(name, version) -> concat
[ "- "
, packageNameString name
, "-"
, versionString version
]) (Map.toList extras)
++ ["", "You may also want to try the 'stack solver' command"]
)
where
exceptions' = removeDuplicates exceptions
appendExceptions = foldr (\e -> (++) ("\n\n--" ++ show e)) ""
removeDuplicates = nub
extras = Map.unions $ map getExtras exceptions'
getExtras (DependencyCycleDetected _) = Map.empty
getExtras (UnknownPackage _) = Map.empty
getExtras (DependencyPlanFailures _ m) =
Map.unions $ map go $ Map.toList m
where
go (name, (_range, NotInBuildPlan (Just version))) =
Map.singleton name version
go _ = Map.empty
show (CabalExitedUnsuccessfully exitCode taskProvides' execName fullArgs logFiles bs) =
let fullCmd = (dropQuotes (show execName) ++ " " ++ (unwords fullArgs))
logLocations = maybe "" (\fp -> "\n Logs have been written to: " ++ show fp) logFiles
in "\n-- While building package " ++ dropQuotes (show taskProvides') ++ " using:\n" ++
" " ++ fullCmd ++ "\n" ++
" Process exited with code: " ++ show exitCode ++
logLocations ++
(if S.null bs
then ""
else "\n\n" ++ doubleIndent (T.unpack $ decodeUtf8With lenientDecode bs))
where
indent = dropWhileEnd isSpace . unlines . fmap (\line -> " " ++ line) . lines
dropQuotes = filter ('\"' /=)
doubleIndent = indent . indent
show (ExecutionFailure es) = intercalate "\n\n" $ map show es
instance Exception StackBuildException
data ConstructPlanException
= DependencyCycleDetected [PackageName]
| DependencyPlanFailures PackageIdentifier (Map PackageName (VersionRange, BadDependency))
| UnknownPackage PackageName
deriving (Typeable, Eq)
data BadDependency
= NotInBuildPlan
(Maybe Version)
| Couldn'tResolveItsDependencies
| DependencyMismatch Version
deriving (Typeable, Eq)
instance Show ConstructPlanException where
show e =
let details = case e of
(DependencyCycleDetected pNames) ->
"While checking call stack,\n" ++
" dependency cycle detected in packages:" ++ indent (appendLines pNames)
(DependencyPlanFailures pIdent (Map.toList -> pDeps)) ->
"Failure when adding dependencies:" ++ doubleIndent (appendDeps pDeps) ++ "\n" ++
" needed for package: " ++ packageIdentifierString pIdent
(UnknownPackage pName) ->
"While attempting to add dependency,\n" ++
" Could not find package " ++ show pName ++ " in known packages"
in indent details
where
appendLines = foldr (\pName-> (++) ("\n" ++ show pName)) ""
indent = dropWhileEnd isSpace . unlines . fmap (\line -> " " ++ line) . lines
doubleIndent = indent . indent
appendDeps = foldr (\dep-> (++) ("\n" ++ showDep dep)) ""
showDep (name, (range, badDep)) = concat
[ show name
, ": needed ("
, display range
, "), but "
, case badDep of
NotInBuildPlan mlatest -> "not present in build plan" ++
(case mlatest of
Nothing -> ""
Just latest -> ", latest is " ++ versionString latest)
Couldn'tResolveItsDependencies -> "couldn't resolve its dependencies"
DependencyMismatch version -> versionString version ++ " found"
]
data BuildOpts =
BuildOpts {boptsTargets :: ![Text]
,boptsLibProfile :: !Bool
,boptsExeProfile :: !Bool
,boptsEnableOptimizations :: !(Maybe Bool)
,boptsHaddock :: !Bool
,boptsHaddockDeps :: !(Maybe Bool)
,boptsFinalAction :: !FinalAction
,boptsDryrun :: !Bool
,boptsGhcOptions :: ![Text]
,boptsFlags :: !(Map (Maybe PackageName) (Map FlagName Bool))
,boptsInstallExes :: !Bool
,boptsPreFetch :: !Bool
,boptsTestArgs :: ![String]
,boptsOnlySnapshot :: !Bool
,boptsCoverage :: !Bool
}
deriving (Show)
data FinalAction
= DoTests
| DoBenchmarks
| DoNothing
deriving (Eq,Bounded,Enum,Show)
newtype PkgDepsOracle =
PkgDeps PackageName
deriving (Show,Typeable,Eq,Hashable,Binary,NFData)
data InstallLocation = Snap | Local
deriving (Show, Eq)
instance Monoid InstallLocation where
mempty = Snap
mappend Local _ = Local
mappend _ Local = Local
mappend Snap Snap = Snap
class PackageInstallInfo a where
piiVersion :: a -> Version
piiLocation :: a -> InstallLocation
data LocalPackage = LocalPackage
{ lpPackage :: !Package
, lpPackageFinal :: !Package
, lpWanted :: !Bool
, lpDir :: !(Path Abs Dir)
, lpCabalFile :: !(Path Abs File)
, lpDirtyFiles :: !Bool
, lpComponents :: !(Set Text)
}
deriving Show
data ConfigCache = ConfigCache
{ configCacheOpts :: ![S.ByteString]
, configCacheDeps :: !(Set GhcPkgId)
, configCacheComponents :: !(Set S.ByteString)
, configCacheHaddock :: !Bool
}
deriving (Generic,Eq,Show)
instance Binary ConfigCache
data Task = Task
{ taskProvides :: !PackageIdentifier
, taskType :: !TaskType
, taskConfigOpts :: !TaskConfigOpts
, taskPresent :: !(Set GhcPkgId)
}
deriving Show
data TaskConfigOpts = TaskConfigOpts
{ tcoMissing :: !(Set PackageIdentifier)
, tcoOpts :: !(Set GhcPkgId -> [Text])
}
instance Show TaskConfigOpts where
show (TaskConfigOpts missing f) = concat
[ "Missing: "
, show missing
, ". Without those: "
, show $ f Set.empty
]
data TaskType = TTLocal LocalPackage
| TTUpstream Package InstallLocation
deriving Show
data Plan = Plan
{ planTasks :: !(Map PackageName Task)
, planFinals :: !(Map PackageName Task)
, planUnregisterLocal :: !(Map GhcPkgId Text)
, planInstallExes :: !(Map Text InstallLocation)
}
deriving Show
data BaseConfigOpts = BaseConfigOpts
{ bcoSnapDB :: !(Path Abs Dir)
, bcoLocalDB :: !(Path Abs Dir)
, bcoSnapInstallRoot :: !(Path Abs Dir)
, bcoLocalInstallRoot :: !(Path Abs Dir)
, bcoBuildOpts :: !BuildOpts
}
configureOpts :: EnvConfig
-> BaseConfigOpts
-> Set GhcPkgId
-> Bool
-> InstallLocation
-> Package
-> [Text]
configureOpts econfig bco deps wanted loc package = map T.pack $ concat
[ ["--user", "--package-db=clear", "--package-db=global"]
, map (("--package-db=" ++) . toFilePath) $ case loc of
Snap -> [bcoSnapDB bco]
Local -> [bcoSnapDB bco, bcoLocalDB bco]
, depOptions
, [ "--libdir=" ++ toFilePathNoTrailingSlash (installRoot </> $(mkRelDir "lib"))
, "--bindir=" ++ toFilePathNoTrailingSlash (installRoot </> bindirSuffix)
, "--datadir=" ++ toFilePathNoTrailingSlash (installRoot </> $(mkRelDir "share"))
, "--docdir=" ++ toFilePathNoTrailingSlash docDir
, "--htmldir=" ++ toFilePathNoTrailingSlash docDir
, "--haddockdir=" ++ toFilePathNoTrailingSlash docDir]
, ["--enable-library-profiling" | boptsLibProfile bopts || boptsExeProfile bopts]
, ["--enable-executable-profiling" | boptsExeProfile bopts]
, map (\(name,enabled) ->
"-f" <>
(if enabled
then ""
else "-") <>
flagNameString name)
(Map.toList (packageFlags package))
, if wanted
then concatMap (\x -> ["--ghc-options", T.unpack x]) (boptsGhcOptions bopts)
else []
, map (("--extra-include-dirs=" ++) . T.unpack) (Set.toList (configExtraIncludeDirs config))
, map (("--extra-lib-dirs=" ++) . T.unpack) (Set.toList (configExtraLibDirs config))
]
where
config = getConfig econfig
bopts = bcoBuildOpts bco
toFilePathNoTrailingSlash = dropTrailingPathSeparator . toFilePath
docDir =
case pkgVerDir of
Nothing -> installRoot </> docdirSuffix
Just dir -> installRoot </> docdirSuffix </> dir
installRoot =
case loc of
Snap -> bcoSnapInstallRoot bco
Local -> bcoLocalInstallRoot bco
pkgVerDir =
parseRelDir (packageIdentifierString (PackageIdentifier (packageName package)
(packageVersion package)) ++
[pathSeparator])
depOptions = map toDepOption $ Set.toList deps
where
toDepOption =
if envConfigCabalVersion econfig >= $(mkVersion "1.22")
then toDepOption1_22
else toDepOption1_18
toDepOption1_22 gid = concat
[ "--dependency="
, packageNameString $ packageIdentifierName $ ghcPkgIdPackageIdentifier gid
, "="
, ghcPkgIdString gid
]
toDepOption1_18 gid = concat
[ "--constraint="
, packageNameString name
, "=="
, versionString version
]
where
PackageIdentifier name version = ghcPkgIdPackageIdentifier gid
wantedLocalPackages :: [LocalPackage] -> Set PackageName
wantedLocalPackages = Set.fromList . map (packageName . lpPackage) . filter lpWanted
newtype ModTime = ModTime (Integer,Rational)
deriving (Ord,Show,Generic,Eq)
instance Binary ModTime
modTime :: UTCTime -> ModTime
modTime x =
ModTime
( toModifiedJulianDay
(utctDay x)
, toRational
(utctDayTime x))
data Installed = Library GhcPkgId | Executable PackageIdentifier
deriving (Show, Eq, Ord)