Skip to content

Commit

Permalink
Add prettyprinter, use for build plan errors #1912
Browse files Browse the repository at this point in the history
  • Loading branch information
@mgsloan
mgsloan committed Jun 4, 2016
1 parent 3103ebe commit befcb51
Show file tree
Hide file tree
Showing 6 changed files with 499 additions and 116 deletions.
114 changes: 111 additions & 3 deletions src/Stack/Build/ConstructPlan.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -29,15 +29,19 @@ import qualified Data.Map.Strict as Map
import Data.Maybe
import Data.Set (Set)
import qualified Data.Set as Set
import Data.String (fromString)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)
import Data.Typeable
import qualified Distribution.Package as Cabal
import qualified Distribution.Text as C
import qualified Distribution.Version as Cabal
import GHC.Generics (Generic)
import Generics.Deriving.Monoid (memptydefault, mappenddefault)
import Network.HTTP.Client.Conduit (HasHttpManager)
import Path
import Prelude hiding (pi, writeFile)
import Stack.Build.Cache
import Stack.Build.Haddock
Expand All @@ -48,6 +52,8 @@ import Stack.Package
import Stack.PackageDump
import Stack.PackageIndex
import Stack.Types
import Stack.Types.Internal (HasTerminal)
import Text.PrettyPrint.Leijen.Extended

data PackageInfo
= PIOnlyInstalled InstallLocation Installed
Expand Down Expand Up @@ -124,7 +130,7 @@ instance HasEnvConfig Ctx where
getEnvConfig = ctxEnvConfig

constructPlan :: forall env m.
(MonadCatch m, MonadReader env m, HasEnvConfig env, MonadIO m, MonadLoggerIO m, MonadBaseControl IO m, HasHttpManager env)
(MonadCatch m, MonadReader env m, HasEnvConfig env, MonadIO m, MonadLoggerIO m, MonadBaseControl IO m, HasHttpManager env, HasTerminal env)
=> MiniBuildPlan
-> BaseConfigOpts
-> [LocalPackage]
Expand Down Expand Up @@ -171,7 +177,9 @@ constructPlan mbp0 baseConfigOpts0 locals extraToBuild0 localDumpPkgs loadPackag
then installExes
else Map.empty
}
else throwM $ ConstructPlanExceptions errs (bcStackYaml $ getBuildConfig econfig)
else do
$displayError $ pprintExceptions errs (bcStackYaml (getBuildConfig econfig))
throwM $ ConstructPlanFailed "Plan construction failed."
where
ctx econfig getVersions0 lf = Ctx
{ mbp = mbp0
Expand Down Expand Up @@ -440,7 +448,7 @@ addPackageDeps treatAsDep package = do
let bd =
case e of
UnknownPackage name -> assert (name == depname) NotInBuildPlan
_ -> Couldn'tResolveItsDependencies
_ -> Couldn'tResolveItsDependencies (packageVersion package)
mlatestApplicable <- getLatestApplicable
return $ Left (depname, (range, mlatestApplicable, bd))
Right adr -> do
Expand Down Expand Up @@ -692,3 +700,103 @@ inSnapshot name version = do
guard $ not $ name `Set.member` ls
mpi <- Map.lookup name (mbpPackages p)
return $ mpiVersion mpi == version

data ConstructPlanException
= DependencyCycleDetected [PackageName]
| DependencyPlanFailures Package (Map PackageName (VersionRange, LatestApplicableVersion, BadDependency))
| UnknownPackage PackageName -- TODO perhaps this constructor will be removed, and BadDependency will handle it all
-- ^ Recommend adding to extra-deps, give a helpful version number?
deriving (Typeable, Eq)

-- | For display purposes only, Nothing if package not found
type LatestApplicableVersion = Maybe Version

-- | Reason why a dependency was not used
data BadDependency
= NotInBuildPlan
| Couldn'tResolveItsDependencies Version
| DependencyMismatch Version
deriving (Typeable, Eq)

pprintExceptions :: [ConstructPlanException] -> Path Abs File -> AnsiDoc
pprintExceptions exceptions stackYaml =
line <>
"While constructing the build plan, the following exceptions were encountered:" <> line <> line <>
mconcat (intersperse (line <> line) (mapMaybe pprintException exceptions')) <> line <>
if Map.null extras then "" else
line <>
"Recommended action: try adding the following to your extra-deps in" <+>
toAnsiDoc (display stackYaml) <> ":" <>
line <>
vsep (map pprintExtra (Map.toList extras)) <>
line <>
line <>
"You may also want to try the 'stack solver' command" <> line <> line
where
exceptions' = nub exceptions

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, Just version, NotInBuildPlan)) =
Map.singleton name version
go _ = Map.empty
pprintExtra (name, version) =
fromString (concat ["- ", packageNameString name, "-", versionString version])

pprintException (DependencyCycleDetected pNames) = Just $ dullred $
"Dependency cycle detected in packages:" <> line <>
indent 4 (encloseSep "[" "]" "," (map (fromString . packageNameString) pNames))
pprintException (DependencyPlanFailures pkg (Map.toList -> pDeps)) =
case mapMaybe pprintDep pDeps of
[] -> Nothing
depErrors -> Just $
"In the dependencies for" <+>
yellow (fromString (packageIdentifierString (packageIdentifier pkg))) <>
pprintFlags (packageFlags pkg) <> ":" <> line <>
indent 4 (vsep depErrors)
-- Skip these because they are redundant with 'NotInBuildPlan' info.
pprintException (UnknownPackage _) = Nothing

pprintFlags flags
| Map.null flags = ""
| otherwise = parens $ sep $ map pprintFlag $ Map.toList flags
pprintFlag (name, True) = "+" <> fromString (show name)
pprintFlag (name, False) = "-" <> fromString (show name)

pprintDep (name, (range, mlatestApplicable, badDep)) = case badDep of
NotInBuildPlan -> Just $
dullred pkgName <+>
align ("must match" <+> goodRange <> "," <> softline <>
"but the stack configuration has no specified version" <>
latestApplicable Nothing)
-- TODO: For local packages, suggest editing constraints
DependencyMismatch version -> Just $
dullred (pkgIdent version) <+>
align ("must match" <+> goodRange <>
latestApplicable (Just version))
-- TODO: optionally show these?
--
-- I think the main useful info is these explain why missing
-- packages are needed. Instead lets give the user the shortest
-- path from a target to the package.
Couldn'tResolveItsDependencies _version ->
Nothing
-- yellow (pkgIdent version <> ":") <+>
-- align ("couldn't resolve its dependencies" <>
-- latestApplicable (Just version))
where
goodRange = green (fromString (C.display range))
pkgName = fromString (packageNameString name)
pkgIdent version = fromString $ packageIdentifierString (PackageIdentifier name version)
latestApplicable mversion =
case mlatestApplicable of
Nothing -> ""
Just la
| mlatestApplicable == mversion -> softline <>
"(latest applicable is specified)"
| otherwise -> softline <>
"(latest applicable is " <> green (fromString (versionString la)) <> ")"
118 changes: 6 additions & 112 deletions src/Stack/Types/Build.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -32,10 +32,8 @@ module Stack.Types.Build
,TaskType(..)
,TaskConfigOpts(..)
,ConfigCache(..)
,ConstructPlanException(..)
,configureOpts
,isStackOpt
,BadDependency(..)
,wantedLocalPackages
,FileCacheInfo (..)
,ConfigureOpts (..)
Expand All @@ -50,7 +48,7 @@ import qualified Data.ByteString as S
import Data.Char (isSpace)
import Data.Data
import Data.Hashable
import Data.List (dropWhileEnd, nub, intercalate)
import Data.List (dropWhileEnd, intercalate)
import qualified Data.Map as Map
import Data.Map.Strict (Map)
import Data.Maybe
Expand All @@ -67,7 +65,7 @@ import Data.Time.Calendar
import Data.Time.Clock
import Distribution.PackageDescription (TestSuiteInterface)
import Distribution.System (Arch)
import Distribution.Text (display)
import qualified Distribution.Text as C
import GHC.Generics (Generic)
import Path (Path, Abs, File, Dir, mkRelDir, toFilePath, parseRelDir, (</>))
import Path.Extra (toFilePathNoTrailingSep)
Expand Down Expand Up @@ -104,9 +102,7 @@ data StackBuildException
(Path Abs File) -- stack.yaml
| TestSuiteFailure PackageIdentifier (Map Text (Maybe ExitCode)) (Maybe (Path Abs File)) S.ByteString
| TestSuiteTypeUnsupported TestSuiteInterface
| ConstructPlanExceptions
[ConstructPlanException]
(Path Abs File) -- stack.yaml
| ConstructPlanFailed String
| CabalExitedUnsuccessfully
ExitCode
PackageIdentifier
Expand Down Expand Up @@ -151,7 +147,7 @@ instance Show StackBuildException where
[ "Compiler version mismatched, found "
, compilerVersionString actual
, " ("
, display arch
, C.display arch
, ")"
, ", but expected "
]
Expand All @@ -161,7 +157,7 @@ instance Show StackBuildException where
NewerMinor -> "minor version match or newer with "
, compilerVersionString expected
, " ("
, display earch
, C.display earch
, ghcVariantSuffix ghcVariant
, ") (based on "
, case mstack of
Expand Down Expand Up @@ -217,34 +213,6 @@ instance Show StackBuildException where
doubleIndent = indent . indent
show (TestSuiteTypeUnsupported interface) =
("Unsupported test suite type: " <> show interface)
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, Just version, NotInBuildPlan)) =
Map.singleton name version
go _ = Map.empty
-- Supressing duplicate output
show (CabalExitedUnsuccessfully exitCode taskProvides' execName fullArgs logFiles bss) =
let fullCmd = unwords
Expand Down Expand Up @@ -354,6 +322,7 @@ instance Show StackBuildException where
, innerMsg
, "\n"
]
show (ConstructPlanFailed msg) = msg

missingExeError :: Bool -> String -> String
missingExeError isSimpleBuildType msg =
Expand All @@ -371,83 +340,8 @@ missingExeError isSimpleBuildType msg =

instance Exception StackBuildException

data ConstructPlanException
= DependencyCycleDetected [PackageName]
| DependencyPlanFailures Package (Map PackageName (VersionRange, LatestApplicableVersion, BadDependency))
| UnknownPackage PackageName -- TODO perhaps this constructor will be removed, and BadDependency will handle it all
-- ^ Recommend adding to extra-deps, give a helpful version number?
deriving (Typeable, Eq)

-- | For display purposes only, Nothing if package not found
type LatestApplicableVersion = Maybe Version

-- | Reason why a dependency was not used
data BadDependency
= NotInBuildPlan
| 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 pkg (Map.toList -> pDeps)) ->
"Failure when adding dependencies:" ++ doubleIndent (appendDeps pDeps) ++ "\n" ++
" needed for package " ++ packageIdentifierString (packageIdentifier pkg) ++
appendFlags (packageFlags pkg)
(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
appendFlags flags =
if Map.null flags
then ""
else " with flags:\n" ++
(doubleIndent . intercalate "\n" . map showFlag . Map.toList) flags
showFlag (name, bool) = show name ++ ": " ++ show bool
appendDeps = foldr (\dep-> (++) ("\n" ++ showDep dep)) ""
showDep (name, (range, mlatestApplicable, badDep)) = concat
[ show name
, ": needed ("
, display range
, ")"
, ", "
, let latestApplicableStr =
case mlatestApplicable of
Nothing -> ""
Just la -> " (latest applicable is " ++ versionString la ++ ")"
in case badDep of
NotInBuildPlan -> "stack configuration has no specified version" ++ latestApplicableStr
Couldn'tResolveItsDependencies -> "couldn't resolve its dependencies"
DependencyMismatch version ->
case mlatestApplicable of
Just la
| la == version ->
versionString version ++
" found (latest applicable version available)"
_ -> versionString version ++ " found" ++ latestApplicableStr
]
{- TODO Perhaps change the showDep function to look more like this:
dropQuotes = filter ((/=) '\"')
(VersionOutsideRange pName pIdentifier versionRange) ->
"Exception: Stack.Build.VersionOutsideRange\n" ++
" While adding dependency for package " ++ show pName ++ ",\n" ++
" " ++ dropQuotes (show pIdentifier) ++ " was found to be outside its allowed version range.\n" ++
" Allowed version range is " ++ display versionRange ++ ",\n" ++
" should you correct the version range for " ++ dropQuotes (show pIdentifier) ++ ", found in [extra-deps] in the project's stack.yaml?"
-}


----------------------------------------------


-- | Package dependency oracle.
newtype PkgDepsOracle =
PkgDeps PackageName
Expand Down
3 changes: 3 additions & 0 deletions src/Stack/Types/Internal.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -17,6 +17,7 @@ data Env config =
Env {envConfig :: !config
,envLogLevel :: !LogLevel
,envTerminal :: !Bool
,envAnsiTerminal :: !Bool
,envReExec :: !Bool
,envManager :: !Manager
,envSticky :: !Sticky
Expand Down Expand Up @@ -50,9 +51,11 @@ instance HasLogLevel LogLevel where

class HasTerminal r where
getTerminal :: r -> Bool
getAnsiTerminal :: r -> Bool

instance HasTerminal (Env config) where
getTerminal = envTerminal
getAnsiTerminal = envAnsiTerminal

class HasReExec r where
getReExec :: r -> Bool
Expand Down
Loading

0 comments on commit befcb51

Please sign in to comment.