{-# LANGUAGE NoImplicitPrelude          #-}
{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE DeriveDataTypeable         #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings          #-}

-- | Build-specific types.

module Stack.Types.Build
  ( BuildException (..)
  , BuildPrettyException (..)
  , ConstructPlanException (..)
  , BadDependency (..)
  , ParentMap
  , FlagSource (..)
  , UnusedFlags (..)
  , InstallLocation (..)
  , Installed (..)
  , psVersion
  , Task (..)
  , taskIsTarget
  , taskLocation
  , taskTargetIsMutable
  , LocalPackage (..)
  , BaseConfigOpts (..)
  , Plan (..)
  , TestOpts (..)
  , BenchmarkOpts (..)
  , FileWatchOpts (..)
  , BuildOpts (..)
  , BuildSubset (..)
  , defaultBuildOpts
  , TaskType (..)
  , IsMutable (..)
  , installLocationIsMutable
  , TaskConfigOpts (..)
  , BuildCache (..)
  , ConfigCache (..)
  , configureOpts
  , CachePkgSrc (..)
  , toCachePkgSrc
  , isStackOpt
  , wantedLocalPackages
  , FileCacheInfo (..)
  , ConfigureOpts (..)
  , PrecompiledCache (..)
  ) where

import           Data.Aeson ( ToJSON, FromJSON )
import qualified Data.ByteString as S
import           Data.Char ( isSpace )
import           Data.List as L
import qualified Data.Map as Map
import qualified Data.Map.Strict as M
import           Data.Monoid.Map ( MonoidMap (..) )
import qualified Data.Set as Set
import qualified Data.Text as T
import           Database.Persist.Sql
                   ( PersistField (..), PersistFieldSql (..)
                   , PersistValue (PersistText), SqlType (SqlString)
                   )
import           Distribution.PackageDescription
                   ( TestSuiteInterface, mkPackageName )
import           Distribution.System ( Arch )
import qualified Distribution.Text as C
import qualified Distribution.Version as C
import           Path ( parseRelDir, (</>), parent )
import           Path.Extra ( toFilePathNoTrailingSep )
import           RIO.Process ( showProcessArgDebug )
import           Stack.Constants
import           Stack.Prelude
import           Stack.Types.Compiler
import           Stack.Types.CompilerBuild
import           Stack.Types.Config
import           Stack.Types.GhcPkgId
import           Stack.Types.NamedComponent
import           Stack.Types.Package
import           Stack.Types.Version
import           System.FilePath ( pathSeparator )

-- | Type representing exceptions thrown by functions exported by modules with
-- names beginning @Stack.Build@.
data BuildException
  = Couldn'tFindPkgId PackageName
  | CompilerVersionMismatch
        (Maybe (ActualCompiler, Arch)) -- found
        (WantedCompiler, Arch) -- expected
        GHCVariant -- expected
        CompilerBuild -- expected
        VersionCheck
        (Maybe (Path Abs File)) -- Path to the stack.yaml file
        Text -- recommended resolution
  | Couldn'tParseTargets [Text]
  | UnknownTargets
    (Set PackageName) -- no known version
    (Map PackageName Version) -- not in snapshot, here's the most recent version in the index
    (Path Abs File) -- stack.yaml
  | TestSuiteFailure PackageIdentifier (Map Text (Maybe ExitCode)) (Maybe (Path Abs File)) S.ByteString
  | TestSuiteTypeUnsupported TestSuiteInterface
  | LocalPackageDoesn'tMatchTarget
        PackageName
        Version -- local version
        Version -- version specified on command line
  | NoSetupHsFound (Path Abs Dir)
  | InvalidFlagSpecification (Set UnusedFlags)
  | InvalidGhcOptionsSpecification [PackageName]
  | TargetParseException [Text]
  | SomeTargetsNotBuildable [(PackageName, NamedComponent)]
  | TestSuiteExeMissing Bool String String String
  | CabalCopyFailed Bool String
  | LocalPackagesPresent [PackageIdentifier]
  | CouldNotLockDistDir !(Path Abs File)
  | TaskCycleBug PackageIdentifier
  | PackageIdMissingBug PackageIdentifier
  | AllInOneBuildBug
  | MulipleResultsBug PackageName [DumpPackage]
  | TemplateHaskellNotFoundBug
  | HaddockIndexNotFound
  | ShowBuildErrorBug
  deriving (Show, Typeable)

instance Exception BuildException where
    displayException (Couldn'tFindPkgId name) = bugReport "[S-7178]" $ concat
        [ "After installing "
        , packageNameString name
        ,", the package id couldn't be found (via ghc-pkg describe "
        , packageNameString name
        , ")."
        ]
    displayException (CompilerVersionMismatch mactual (expected, eArch) ghcVariant ghcBuild check mstack resolution) = concat
        [ "Error: [S-6362]\n"
        , case mactual of
            Nothing -> "No compiler found, expected "
            Just (actual, arch) -> concat
                [ "Compiler version mismatched, found "
                , compilerVersionString actual
                , " ("
                , C.display arch
                , ")"
                , ", but expected "
                ]
        , case check of
            MatchMinor -> "minor version match with "
            MatchExact -> "exact version "
            NewerMinor -> "minor version match or newer with "
        , T.unpack $ utf8BuilderToText $ display expected
        , " ("
        , C.display eArch
        , ghcVariantSuffix ghcVariant
        , compilerBuildSuffix ghcBuild
        , ") (based on "
        , case mstack of
            Nothing -> "command line arguments"
            Just stack -> "resolver setting in " ++ toFilePath stack
        , ").\n"
        , T.unpack resolution
        ]
    displayException (Couldn'tParseTargets targets) = unlines
        $ "Error: [S-3127]"
        : "The following targets could not be parsed as package names or \
          \directories:"
        : map T.unpack targets
    displayException (UnknownTargets noKnown notInSnapshot stackYaml) = unlines
        $ "Error: [S-2154]"
        : (noKnown' ++ notInSnapshot')
      where
        noKnown'
            | Set.null noKnown = []
            | otherwise = pure $
                "The following target packages were not found: " ++
                intercalate ", " (map packageNameString $ Set.toList noKnown) ++
                "\nSee https://docs.haskellstack.org/en/stable/build_command/#target-syntax for details."
        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)
    displayException (TestSuiteFailure ident codes mlogFile bs) = unlines
        $ "Error: [S-1995]"
        : 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: " ++ displayException ec
                ]
            , pure $ case mlogFile of
                Nothing -> "Logs printed to console"
                -- TODO Should we load up the full error output and print it here?
                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 (\l -> "  " ++ l) . lines
        doubleIndent = indent' . indent'
    displayException (TestSuiteTypeUnsupported interface) = concat
        [ "Error: [S-3819]\n"
        , "Unsupported test suite type: "
        , show interface
        ]
     -- Suppressing duplicate output
    displayException (LocalPackageDoesn'tMatchTarget name localV requestedV) = concat
        [ "Error: [S-5797]\n"
        , "Version for local package "
        , packageNameString name
        , " is "
        , versionString localV
        , ", but you asked for "
        , versionString requestedV
        , " on the command line"
        ]
    displayException (NoSetupHsFound dir) = concat
        [ "Error: [S-3118]\n"
        , "No Setup.hs or Setup.lhs file found in "
        , toFilePath dir
        ]
    displayException (InvalidFlagSpecification unused) = unlines
        $ "Error: [S-8664]"
        : "Invalid flag specification:"
        : map go (Set.toList unused)
      where
        showFlagSrc :: FlagSource -> String
        showFlagSrc FSCommandLine = " (specified on command line)"
        showFlagSrc FSStackYaml = " (specified in stack.yaml)"

        go :: UnusedFlags -> String
        go (UFNoPackage src name) = concat
            [ "- Package '"
            , packageNameString name
            , "' not found"
            , showFlagSrc src
            ]
        go (UFFlagsNotDefined src pname pkgFlags flags) = concat
            [ "- Package '"
            , name
            , "' does not define the following flags"
            , showFlagSrc src
            , ":\n"
            , intercalate "\n"
                          (map (\flag -> "  " ++ flagNameString flag)
                               (Set.toList flags))
            , "\n- Flags defined by package '" ++ name ++ "':\n"
            , intercalate "\n"
                          (map (\flag -> "  " ++ name ++ ":" ++ flagNameString flag)
                               (Set.toList pkgFlags))
            ]
          where name = packageNameString pname
        go (UFSnapshot name) = concat
            [ "- Attempted to set flag on snapshot package "
            , packageNameString name
            , ", please add to extra-deps"
            ]
    displayException (InvalidGhcOptionsSpecification unused) = unlines
        $ "Error: [S-4925]"
        : "Invalid GHC options specification:"
        : map showGhcOptionSrc unused
      where
        showGhcOptionSrc name = concat
            [ "- Package '"
            , packageNameString name
            , "' not found"
            ]
    displayException (TargetParseException [err]) = concat
        [ "Error: [S-8506]\n"
        , "Error parsing targets: "
        , T.unpack err
        ]
    displayException (TargetParseException errs) = unlines
        $ "Error [S-8506]"
        : "The following errors occurred while parsing the build targets:"
        : map (("- " ++) . T.unpack) errs
    displayException (SomeTargetsNotBuildable xs) = unlines
        [ "Error: [S-7086]"
        , "The following components have 'buildable: False' set in the Cabal \
          \configuration, and so cannot be targets:"
        , "    " <> T.unpack (renderPkgComponents xs)
        , "To resolve this, either provide flags such that these components \
          \are buildable, or only specify buildable targets."
        ]
    displayException (TestSuiteExeMissing isSimpleBuildType exeName pkgName' testName) =
        missingExeError "[S-7987]"
          isSimpleBuildType $ concat
            [ "Test suite executable \""
            , exeName
            , " not found for "
            , pkgName'
            , ":test:"
            , testName
            ]
    displayException (CabalCopyFailed isSimpleBuildType innerMsg) =
        missingExeError "[S-8027]"
          isSimpleBuildType $ concat
            [ "'cabal copy' failed.  Error message:\n"
            , innerMsg
            , "\n"
            ]
    displayException (LocalPackagesPresent locals) = unlines
        $ "Error: [S-5510]"
        : "Local packages are not allowed when using the 'script' command. \
          \Packages found:"
        : map (\ident -> "- " ++ packageIdentifierString ident) locals
    displayException (CouldNotLockDistDir lockFile) = unlines
        [ "Error: [S-7168]"
        , "Locking the dist directory failed, try to lock file:"
        , "  " ++ toFilePath lockFile
        , "Maybe you're running another copy of Stack?"
        ]
    displayException (TaskCycleBug pid) = bugReport "[S-7868]" $
        "Error: The impossible happened! Unexpected task cycle for "
        ++ packageNameString (pkgName pid)
    displayException (PackageIdMissingBug ident) = bugReport "[S-8923]" $
        "The impossible happened! singleBuild: missing package ID missing: "
        ++ show ident
    displayException AllInOneBuildBug = bugReport "[S-7371]"
        "Cannot have an all-in-one build that also has a final build step."
    displayException (MulipleResultsBug name dps) = bugReport "[S-6739]"
        "singleBuild: multiple results when describing installed package "
        ++ show (name, dps)
    displayException TemplateHaskellNotFoundBug = bugReport "[S-3121]"
        "template-haskell is a wired-in GHC boot library but it wasn't found."
    displayException HaddockIndexNotFound =
        "Error: [S-6901]\n"
        ++ "No local or snapshot doc index found to open."
    displayException ShowBuildErrorBug = bugReport "[S-5452]"
        "Unexpected case in showBuildError."

data BuildPrettyException
    = ConstructPlanFailed
        [ConstructPlanException]
        (Path Abs File)
        (Path Abs Dir)
        ParentMap
        (Set PackageName)
        (Map PackageName [PackageName])
    | ExecutionFailure [SomeException]
    | CabalExitedUnsuccessfully
        ExitCode
        PackageIdentifier
        (Path Abs File)  -- cabal Executable
        [String]         -- cabal arguments
        (Maybe (Path Abs File)) -- logfiles location
        [Text]     -- log contents
    | SetupHsBuildFailure
        ExitCode
        (Maybe PackageIdentifier) -- which package's custom setup, is simple setup if Nothing
        (Path Abs File)  -- ghc Executable
        [String]         -- ghc arguments
        (Maybe (Path Abs File)) -- logfiles location
        [Text]     -- log contents
    deriving (Show, Typeable)

instance Pretty BuildPrettyException where
    pretty ( ConstructPlanFailed errs stackYaml stackRoot parents wanted prunedGlobalDeps ) =
           "[S-4804]"
        <> line
        <> flow "Stack failed to construct a build plan."
        <> blankLine
        <> pprintExceptions
               errs stackYaml stackRoot parents wanted prunedGlobalDeps
    pretty (ExecutionFailure es) =
           "[S-7282]"
        <> line
        <> flow "Stack failed to execute the build plan."
        <> blankLine
        <> flow "While executing the build plan, Stack encountered the \
                \following errors:"
        <> blankLine
        <> hcat (L.intersperse blankLine (map ppExceptions es))
      where
        ppExceptions :: SomeException -> StyleDoc
        ppExceptions e = case fromException e of
            Just (PrettyException e') -> pretty e'
            Nothing -> (string . show) e
    pretty (CabalExitedUnsuccessfully exitCode taskProvides' execName fullArgs logFiles bss) =
        showBuildError "[S-7011]"
            False exitCode (Just taskProvides') execName fullArgs logFiles bss
    pretty (SetupHsBuildFailure exitCode mtaskProvides execName fullArgs logFiles bss) =
        showBuildError "[S-6374]"
            True exitCode mtaskProvides execName fullArgs logFiles bss

instance Exception BuildPrettyException

pprintExceptions
    :: [ConstructPlanException]
    -> Path Abs File
    -> Path Abs Dir
    -> ParentMap
    -> Set PackageName
    -> Map PackageName [PackageName]
    -> StyleDoc
pprintExceptions exceptions stackYaml stackRoot parentMap wanted' prunedGlobalDeps =
    mconcat $
      [ flow "While constructing the build plan, Stack encountered the \
             \following errors:"
      , blankLine
      , mconcat (L.intersperse blankLine (mapMaybe pprintException exceptions'))
      ] ++ if L.null recommendations
               then []
               else
                   [ blankLine
                   , flow "Some different approaches to resolving this:"
                   , blankLine
                   ] ++ recommendations

  where
    exceptions' = {- should we dedupe these somehow? nubOrd -} exceptions

    recommendations =
        if not onlyHasDependencyMismatches
            then []
            else
                [ "  *" <+> align
                    (   flow "Set 'allow-newer: true' in "
                    <+> pretty (defaultUserConfigPath stackRoot)
                    <+> "to ignore all version constraints and build anyway."
                    )
                , blankLine
                ]
        ++ addExtraDepsRecommendations

    addExtraDepsRecommendations
      | Map.null extras = []
      | (Just _) <- Map.lookup (mkPackageName "base") extras =
          [ "  *" <+> align (flow "Build requires unattainable version of base. Since base is a part of GHC, you most likely need to use a different GHC version with the matching base.")
           , line
          ]
      | otherwise =
         [ "  *" <+> align
           (style Recommendation (flow "Recommended action:") <+>
            flow "try adding the following to your extra-deps in" <+>
            pretty stackYaml <> ":")
         , blankLine
         , vsep (map pprintExtra (Map.toList extras))
         , line
         ]

    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
       -- TODO: Likely a good idea to distinguish these to the user.  In particular, for DependencyMismatch
       go (name, (_range, Just (version,cabalHash), NotInBuildPlan)) =
           Map.singleton name (version,cabalHash)
       go (name, (_range, Just (version,cabalHash), DependencyMismatch{})) =
           Map.singleton name (version, cabalHash)
       go _ = Map.empty
    pprintExtra (name, (version, BlobKey cabalHash cabalSize)) =
      let cfInfo = CFIHash cabalHash (Just cabalSize)
          packageIdRev = PackageIdentifierRevision name version cfInfo
       in fromString ("- " ++ T.unpack (utf8BuilderToText (display packageIdRev)))

    allNotInBuildPlan = Set.fromList $ concatMap toNotInBuildPlan exceptions'
    toNotInBuildPlan (DependencyPlanFailures _ pDeps) =
      map fst $ filter (\(_, (_, _, badDep)) -> badDep == NotInBuildPlan) $ Map.toList pDeps
    toNotInBuildPlan _ = []

    -- This checks if 'allow-newer: true' could resolve all issues.
    onlyHasDependencyMismatches = all go exceptions'
      where
        go DependencyCycleDetected{} = False
        go UnknownPackage{} = False
        go (DependencyPlanFailures _ m) =
          all (\(_, _, depErr) -> isMismatch depErr) (M.elems m)
        isMismatch DependencyMismatch{} = True
        isMismatch Couldn'tResolveItsDependencies{} = True
        isMismatch _ = False

    pprintException (DependencyCycleDetected pNames) = Just $
        flow "Dependency cycle detected in packages:" <> line <>
        indent 4 (encloseSep "[" "]" "," (map (style Error . fromString . packageNameString) pNames))
    pprintException (DependencyPlanFailures pkg pDeps) =
        case mapMaybe pprintDep (Map.toList pDeps) of
            [] -> Nothing
            depErrors -> Just $
                flow "In the dependencies for" <+> pkgIdent <>
                pprintFlags (packageFlags pkg) <> ":" <> line <>
                indent 4 (vsep depErrors) <>
                case getShortestDepsPath parentMap wanted' (packageName pkg) of
                    Nothing -> line <> flow "needed for unknown reason - stack invariant violated."
                    Just [] -> line <> flow "needed since" <+> pkgName' <+> flow "is a build target."
                    Just (target:path) -> line <> flow "needed due to" <+> encloseSep "" "" " -> " pathElems
                      where
                        pathElems =
                            [style Target . fromString . packageIdentifierString $ target] ++
                            map (fromString . packageIdentifierString) path ++
                            [pkgIdent]
              where
                pkgName' = style Current . fromString . packageNameString $ packageName pkg
                pkgIdent = style Current . fromString . packageIdentifierString $ packageIdentifier pkg
    -- Skip these when they are redundant with 'NotInBuildPlan' info.
    pprintException (UnknownPackage name)
        | name `Set.member` allNotInBuildPlan = Nothing
        | name `Set.member` wiredInPackages =
            Just $ flow "Can't build a package with same name as a wired-in-package:" <+> (style Current . fromString . packageNameString $ name)
        | Just pruned <- Map.lookup name prunedGlobalDeps =
            let prunedDeps = map (style Current . fromString . packageNameString) pruned
            in Just $ flow "Can't use GHC boot package" <+>
                      (style Current . fromString . packageNameString $ name) <+>
                      flow "when it has an overridden dependency (issue #4510);" <+>
                      flow "you need to add the following as explicit dependencies to the project:" <+>
                      line <+> encloseSep "" "" ", " prunedDeps
        | otherwise = Just $ flow "Unknown package:" <+> (style Current . fromString . packageNameString $ name)

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

    pprintDep (name, (range, mlatestApplicable, badDep)) = case badDep of
        NotInBuildPlan
          | name `elem` fold prunedGlobalDeps -> Just $
              style Error (fromString $ packageNameString name) <+>
              align ((if range == C.anyVersion
                        then flow "needed"
                        else flow "must match" <+> goodRange) <> "," <> softline <>
                     flow "but this GHC boot package has been pruned (issue #4510);" <+>
                     flow "you need to add the package explicitly to extra-deps" <+>
                     latestApplicable Nothing)
          | otherwise -> Just $
              style Error (fromString $ packageNameString name) <+>
              align ((if range == C.anyVersion
                        then flow "needed"
                        else flow "must match" <+> goodRange) <> "," <> softline <>
                     flow "but the Stack configuration has no specified version" <+>
                     latestApplicable Nothing)
        -- TODO: For local packages, suggest editing constraints
        DependencyMismatch version -> Just $
            (style Error . fromString . packageIdentifierString) (PackageIdentifier name version) <+>
            align (flow "from Stack configuration does not match" <+> goodRange <+>
                   latestApplicable (Just version))
        -- 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
        HasNoLibrary -> Just $
            style Error (fromString $ packageNameString name) <+>
            align (flow "is a library dependency, but the package provides no library")
        BDDependencyCycleDetected names -> Just $
            style Error (fromString $ packageNameString name) <+>
            align (flow $ "dependency cycle detected: " ++ L.intercalate ", " (map packageNameString names))
      where
        goodRange = style Good (fromString (C.display range))
        latestApplicable mversion =
            case mlatestApplicable of
                Nothing
                    | isNothing mversion ->
                        flow "(no package with that name found, perhaps there \
                             \is a typo in a package's build-depends or an \
                             \omission from the stack.yaml packages list?)"
                    | otherwise -> ""
                Just (laVer, _)
                    | Just laVer == mversion ->
                        flow "(latest matching version is specified)"
                    | otherwise ->
                        fillSep
                          [ flow "(latest matching version is"
                          , style Good (fromString $ versionString laVer) <> ")"
                          ]

-- | Get the shortest reason for the package to be in the build plan. In
-- other words, trace the parent dependencies back to a 'wanted'
-- package.
getShortestDepsPath
    :: ParentMap
    -> Set PackageName
    -> PackageName
    -> Maybe [PackageIdentifier]
getShortestDepsPath (MonoidMap parentsMap) wanted' name =
    if Set.member name wanted'
        then Just []
        else case M.lookup name parentsMap of
            Nothing -> Nothing
            Just (_, parents) -> Just $ findShortest 256 paths0
              where
                paths0 = M.fromList $ map (\(ident, _) -> (pkgName ident, startDepsPath ident)) parents
  where
    -- The 'paths' map is a map from PackageName to the shortest path
    -- found to get there. It is the frontier of our breadth-first
    -- search of dependencies.
    findShortest :: Int -> Map PackageName DepsPath -> [PackageIdentifier]
    findShortest fuel _ | fuel <= 0 =
        [PackageIdentifier (mkPackageName "stack-ran-out-of-jet-fuel") (C.mkVersion [0])]
    findShortest _ paths | M.null paths = []
    findShortest fuel paths =
        case targets of
            [] -> findShortest (fuel - 1) $ M.fromListWith chooseBest $ concatMap extendPath recurses
            _ -> let (DepsPath _ _ path) = L.minimum (map snd targets) in path
      where
        (targets, recurses) = L.partition (\(n, _) -> n `Set.member` wanted') (M.toList paths)
    chooseBest :: DepsPath -> DepsPath -> DepsPath
    chooseBest x y = max x y
    -- Extend a path to all its parents.
    extendPath :: (PackageName, DepsPath) -> [(PackageName, DepsPath)]
    extendPath (n, dp) =
        case M.lookup n parentsMap of
            Nothing -> []
            Just (_, parents) -> map (\(pkgId, _) -> (pkgName pkgId, extendDepsPath pkgId dp)) parents

startDepsPath :: PackageIdentifier -> DepsPath
startDepsPath ident = DepsPath
    { dpLength = 1
    , dpNameLength = length (packageNameString (pkgName ident))
    , dpPath = [ident]
    }

extendDepsPath :: PackageIdentifier -> DepsPath -> DepsPath
extendDepsPath ident dp = DepsPath
    { dpLength = dpLength dp + 1
    , dpNameLength = dpNameLength dp + length (packageNameString (pkgName ident))
    , dpPath = [ident]
    }

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, Show)

-- | The latest applicable version and it's latest Cabal file revision.
-- For display purposes only, Nothing if package not found
type LatestApplicableVersion = Maybe (Version, BlobKey)

-- | Reason why a dependency was not used
data BadDependency
    = NotInBuildPlan
    | Couldn'tResolveItsDependencies Version
    | DependencyMismatch Version
    | HasNoLibrary
    -- ^ See description of 'DepType'
    | BDDependencyCycleDetected ![PackageName]
    deriving (Typeable, Eq, Ord, Show)

type ParentMap = MonoidMap PackageName (First Version, [(PackageIdentifier, VersionRange)])

data DepsPath = DepsPath
    { dpLength :: Int -- ^ Length of dpPath
    , dpNameLength :: Int -- ^ Length of package names combined
    , dpPath :: [PackageIdentifier] -- ^ A path where the packages later
                                    -- in the list depend on those that
                                    -- come earlier
    }
    deriving (Eq, Ord, Show)

data FlagSource = FSCommandLine | FSStackYaml
    deriving (Show, Eq, Ord)

data UnusedFlags = UFNoPackage FlagSource PackageName
                 | UFFlagsNotDefined
                       FlagSource
                       PackageName
                       (Set FlagName) -- defined in package
                       (Set FlagName) -- not defined
                 | UFSnapshot PackageName
    deriving (Show, Eq, Ord)

missingExeError :: String -> Bool -> String -> String
missingExeError errorCode isSimpleBuildType msg = unlines
    $ "Error: " <> errorCode
    : msg
    : "Possible causes of this issue:"
    : map ("* " <>) possibleCauses
  where
    possibleCauses
        = "No module named \"Main\". The 'main-is' source file should usually \
          \have a header indicating that it's a 'Main' module."
        : "A Cabal file that refers to nonexistent other files (e.g. a \
          \license-file that doesn't exist). Running 'cabal check' may point \
          \out these issues."
        : if isSimpleBuildType
            then []
            else ["The Setup.hs file is changing the installation target dir."]

showBuildError
  :: String
  -> Bool
  -> ExitCode
  -> Maybe PackageIdentifier
  -> Path Abs File
  -> [String]
  -> Maybe (Path Abs File)
  -> [Text]
  -> StyleDoc
showBuildError errorCode isBuildingSetup exitCode mtaskProvides execName fullArgs logFiles bss =
  let fullCmd = unwords
              $ dropQuotes (toFilePath execName)
              : map (T.unpack . showProcessArgDebug) fullArgs
      logLocations =
          maybe
              mempty
              (\fp -> line <> flow "Logs have been written to:" <+>
                        style File (pretty fp))
              logFiles
  in     fromString errorCode
      <> line
      <> flow "While building" <+>
         ( case (isBuildingSetup, mtaskProvides) of
             (False, Nothing) -> impureThrow ShowBuildErrorBug
             (False, Just taskProvides') ->
                "package" <+>
                  style
                    Target
                    (fromString $ dropQuotes (packageIdentifierString taskProvides'))
             (True, Nothing) -> "simple" <+> style File "Setup.hs"
             (True, Just taskProvides') ->
                "custom" <+>
                  style File "Setup.hs" <+>
                  flow "for package" <+>
                  style
                    Target
                    (fromString $ dropQuotes (packageIdentifierString taskProvides'))
         ) <+>
         flow "(scroll up to its section to see the error) using:"
      <> line
      <> style Shell (fromString fullCmd)
      <> line
      <> flow "Process exited with code:" <+> (fromString . show) exitCode <+>
         ( if exitCode == ExitFailure (-9)
             then flow "(THIS MAY INDICATE OUT OF MEMORY)"
             else mempty
         )
      <> logLocations
      <> if null bss
           then mempty
           else blankLine <> string (removeTrailingSpaces (map T.unpack bss))
   where
    removeTrailingSpaces = dropWhileEnd isSpace . unlines
    dropQuotes = filter ('\"' /=)

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

-- | Package dependency oracle.
newtype PkgDepsOracle =
    PkgDeps PackageName
    deriving (Show,Typeable,Eq,NFData)

-- | Stored on disk to know whether the files have changed.
newtype BuildCache = BuildCache
    { buildCacheTimes :: Map FilePath FileCacheInfo
      -- ^ Modification times of files.
    }
    deriving (Generic, Eq, Show, Typeable, ToJSON, FromJSON)
instance NFData BuildCache

-- | Stored on disk to know whether the flags have changed.
data ConfigCache = ConfigCache
    { configCacheOpts :: !ConfigureOpts
      -- ^ All options used for this package.
    , configCacheDeps :: !(Set GhcPkgId)
      -- ^ The GhcPkgIds of all of the dependencies. Since Cabal doesn't take
      -- the complete GhcPkgId (only a PackageIdentifier) in the configure
      -- options, just using the previous value is insufficient to know if
      -- dependencies have changed.
    , configCacheComponents :: !(Set S.ByteString)
      -- ^ The components to be built. It's a bit of a hack to include this in
      -- here, as it's not a configure option (just a build option), but this
      -- is a convenient way to force compilation when the components change.
    , configCacheHaddock :: !Bool
      -- ^ Are haddocks to be built?
    , configCachePkgSrc :: !CachePkgSrc
    , configCachePathEnvVar :: !Text
    -- ^ Value of the PATH env var, see <https://github.com/commercialhaskell/stack/issues/3138>
    }
    deriving (Generic, Eq, Show, Data, Typeable)
instance NFData ConfigCache

data CachePkgSrc = CacheSrcUpstream | CacheSrcLocal FilePath
    deriving (Generic, Eq, Read, Show, Data, Typeable)
instance NFData CachePkgSrc

instance PersistField CachePkgSrc where
    toPersistValue CacheSrcUpstream = PersistText "upstream"
    toPersistValue (CacheSrcLocal fp) = PersistText ("local:" <> T.pack fp)
    fromPersistValue (PersistText t) = do
        if t == "upstream"
            then Right CacheSrcUpstream
            else case T.stripPrefix "local:" t of
                Just fp -> Right $ CacheSrcLocal (T.unpack fp)
                Nothing -> Left $ "Unexpected CachePkgSrc value: " <> t
    fromPersistValue _ = Left "Unexpected CachePkgSrc type"

instance PersistFieldSql CachePkgSrc where
    sqlType _ = SqlString

toCachePkgSrc :: PackageSource -> CachePkgSrc
toCachePkgSrc (PSFilePath lp) = CacheSrcLocal (toFilePath (parent (lpCabalFile lp)))
toCachePkgSrc PSRemote{} = CacheSrcUpstream

-- | A task to perform when building
data Task = Task
    { taskProvides        :: !PackageIdentifier -- FIXME turn this into a function on taskType?
    -- ^ the package/version to be built
    , taskType            :: !TaskType
    -- ^ the task type, telling us how to build this
    , taskConfigOpts      :: !TaskConfigOpts
    , taskBuildHaddock    :: !Bool
    , taskPresent         :: !(Map PackageIdentifier GhcPkgId)
    -- ^ GhcPkgIds of already-installed dependencies
    , taskAllInOne        :: !Bool
    -- ^ indicates that the package can be built in one step
    , taskCachePkgSrc     :: !CachePkgSrc
    , taskAnyMissing      :: !Bool
    -- ^ Were any of the dependencies missing? The reason this is
    -- necessary is... hairy. And as you may expect, a bug in
    -- Cabal. See:
    -- <https://github.com/haskell/cabal/issues/4728#issuecomment-337937673>. The
    -- problem is that Cabal may end up generating the same package ID
    -- for a dependency, even if the ABI has changed. As a result,
    -- without this field, Stack would think that a reconfigure is
    -- unnecessary, when in fact we _do_ need to reconfigure. The
    -- details here suck. We really need proper hashes for package
    -- identifiers.
    , taskBuildTypeConfig :: !Bool
    -- ^ Is the build type of this package Configure. Check out
    -- ensureConfigureScript in Stack.Build.Execute for the motivation
    }
    deriving Show

-- | Given the IDs of any missing packages, produce the configure options
data TaskConfigOpts = TaskConfigOpts
    { tcoMissing :: !(Set PackageIdentifier)
      -- ^ Dependencies for which we don't yet have an GhcPkgId
    , tcoOpts    :: !(Map PackageIdentifier GhcPkgId -> ConfigureOpts)
      -- ^ Produce the list of options given the missing @GhcPkgId@s
    }
instance Show TaskConfigOpts where
    show (TaskConfigOpts missing f) = concat
        [ "Missing: "
        , show missing
        , ". Without those: "
        , show $ f Map.empty
        ]

-- | The type of a task, either building local code or something from the
-- package index (upstream)
data TaskType
  = TTLocalMutable LocalPackage
  | TTRemotePackage IsMutable Package PackageLocationImmutable
    deriving Show

data IsMutable
    = Mutable
    | Immutable
    deriving (Eq, Show)

instance Semigroup IsMutable where
    Mutable <> _ = Mutable
    _ <> Mutable = Mutable
    Immutable <> Immutable = Immutable

instance Monoid IsMutable where
    mempty = Immutable
    mappend = (<>)

taskIsTarget :: Task -> Bool
taskIsTarget t =
    case taskType t of
        TTLocalMutable lp -> lpWanted lp
        _ -> False

taskLocation :: Task -> InstallLocation
taskLocation task =
    case taskType task of
        TTLocalMutable _ -> Local
        TTRemotePackage Mutable _ _ -> Local
        TTRemotePackage Immutable _ _ -> Snap

taskTargetIsMutable :: Task -> IsMutable
taskTargetIsMutable task =
    case taskType task of
        TTLocalMutable _ -> Mutable
        TTRemotePackage mutable _ _ -> mutable

installLocationIsMutable :: InstallLocation -> IsMutable
installLocationIsMutable Snap = Immutable
installLocationIsMutable Local = Mutable

-- | A complete plan of what needs to be built and how to do it
data Plan = Plan
    { planTasks :: !(Map PackageName Task)
    , planFinals :: !(Map PackageName Task)
    -- ^ Final actions to be taken (test, benchmark, etc)
    , planUnregisterLocal :: !(Map GhcPkgId (PackageIdentifier, Text))
    -- ^ Text is reason we're unregistering, for display only
    , planInstallExes :: !(Map Text InstallLocation)
    -- ^ Executables that should be installed after successful building
    }
    deriving Show

-- | Basic information used to calculate what the configure options are
data BaseConfigOpts = BaseConfigOpts
    { bcoSnapDB :: !(Path Abs Dir)
    , bcoLocalDB :: !(Path Abs Dir)
    , bcoSnapInstallRoot :: !(Path Abs Dir)
    , bcoLocalInstallRoot :: !(Path Abs Dir)
    , bcoBuildOpts :: !BuildOpts
    , bcoBuildOptsCLI :: !BuildOptsCLI
    , bcoExtraDBs :: ![Path Abs Dir]
    }
    deriving Show

-- | Render a @BaseConfigOpts@ to an actual list of options
configureOpts :: EnvConfig
              -> BaseConfigOpts
              -> Map PackageIdentifier GhcPkgId -- ^ dependencies
              -> Bool -- ^ local non-extra-dep?
              -> IsMutable
              -> Package
              -> ConfigureOpts
configureOpts econfig bco deps isLocal isMutable package = ConfigureOpts
    { coDirs = configureOptsDirs bco isMutable package
    , coNoDirs = configureOptsNoDir econfig bco deps isLocal package
    }

-- options set by stack
isStackOpt :: Text -> Bool
isStackOpt t = any (`T.isPrefixOf` t)
    [ "--dependency="
    , "--constraint="
    , "--package-db="
    , "--libdir="
    , "--bindir="
    , "--datadir="
    , "--libexecdir="
    , "--sysconfdir"
    , "--docdir="
    , "--htmldir="
    , "--haddockdir="
    , "--enable-tests"
    , "--enable-benchmarks"
    , "--exact-configuration"
    -- Treat these as causing dirtiness, to resolve
    -- https://github.com/commercialhaskell/stack/issues/2984
    --
    -- , "--enable-library-profiling"
    -- , "--enable-executable-profiling"
    -- , "--enable-profiling"
    ] || t == "--user"

configureOptsDirs :: BaseConfigOpts
                  -> IsMutable
                  -> Package
                  -> [String]
configureOptsDirs bco isMutable package = concat
    [ ["--user", "--package-db=clear", "--package-db=global"]
    , map (("--package-db=" ++) . toFilePathNoTrailingSep) $ case isMutable of
        Immutable -> bcoExtraDBs bco ++ [bcoSnapDB bco]
        Mutable -> bcoExtraDBs bco ++ [bcoSnapDB bco] ++ [bcoLocalDB bco]
    , [ "--libdir=" ++ toFilePathNoTrailingSep (installRoot </> relDirLib)
      , "--bindir=" ++ toFilePathNoTrailingSep (installRoot </> bindirSuffix)
      , "--datadir=" ++ toFilePathNoTrailingSep (installRoot </> relDirShare)
      , "--libexecdir=" ++ toFilePathNoTrailingSep (installRoot </> relDirLibexec)
      , "--sysconfdir=" ++ toFilePathNoTrailingSep (installRoot </> relDirEtc)
      , "--docdir=" ++ toFilePathNoTrailingSep docDir
      , "--htmldir=" ++ toFilePathNoTrailingSep docDir
      , "--haddockdir=" ++ toFilePathNoTrailingSep docDir]
    ]
  where
    installRoot =
        case isMutable of
            Immutable -> bcoSnapInstallRoot bco
            Mutable -> bcoLocalInstallRoot bco
    docDir =
        case pkgVerDir of
            Nothing -> installRoot </> docDirSuffix
            Just dir -> installRoot </> docDirSuffix </> dir
    pkgVerDir =
        parseRelDir (packageIdentifierString (PackageIdentifier (packageName package)
                                                                (packageVersion package)) ++
                     [pathSeparator])

-- | Same as 'configureOpts', but does not include directory path options
configureOptsNoDir :: EnvConfig
                   -> BaseConfigOpts
                   -> Map PackageIdentifier GhcPkgId -- ^ dependencies
                   -> Bool -- ^ is this a local, non-extra-dep?
                   -> Package
                   -> [String]
configureOptsNoDir econfig bco deps isLocal package = concat
    [ depOptions
    , ["--enable-library-profiling" | boptsLibProfile bopts || boptsExeProfile bopts]
    -- Cabal < 1.21.1 does not support --enable-profiling, use --enable-executable-profiling instead
    , let profFlag = "--enable-" <> concat ["executable-" | not newerCabal] <> "profiling"
      in [ profFlag | boptsExeProfile bopts && isLocal]
    , ["--enable-split-objs" | boptsSplitObjs bopts]
    , ["--disable-library-stripping" | not $ boptsLibStrip bopts || boptsExeStrip bopts]
    , ["--disable-executable-stripping" | not (boptsExeStrip bopts) && isLocal]
    , map (\(name,enabled) ->
                       "-f" <>
                       (if enabled
                           then ""
                           else "-") <>
                       flagNameString name)
                    (Map.toList flags)
    , map T.unpack $ packageCabalConfigOpts package
    , processGhcOptions (packageGhcOptions package)
    , map ("--extra-include-dirs=" ++) (configExtraIncludeDirs config)
    , map ("--extra-lib-dirs=" ++) (configExtraLibDirs config)
    , maybe [] (\customGcc -> ["--with-gcc=" ++ toFilePath customGcc]) (configOverrideGccPath config)
    , ["--exact-configuration"]
    , ["--ghc-option=-fhide-source-paths" | hideSourcePaths cv]
    ]
  where
    -- This function parses the GHC options that are providing in the
    -- stack.yaml file. In order to handle RTS arguments correctly, we need
    -- to provide the RTS arguments as a single argument.
    processGhcOptions :: [Text] -> [String]
    processGhcOptions args =
        let
            (preRtsArgs, mid) =
                break ("+RTS" ==) args
            (rtsArgs, end) =
                break ("-RTS" ==) mid
            fullRtsArgs =
                case rtsArgs of
                    [] ->
                        -- This means that we didn't have any RTS args - no
                        -- `+RTS` - and therefore no need for a `-RTS`.
                        []
                    _ ->
                        -- In this case, we have some RTS args. `break`
                        -- puts the `"-RTS"` string in the `snd` list, so
                        -- we want to append it on the end of `rtsArgs`
                        -- here.
                        --
                        -- We're not checking that `-RTS` is the first
                        -- element of `end`. This is because the GHC RTS
                        -- allows you to omit a trailing -RTS if that's the
                        -- last of the arguments. This permits a GHC
                        -- options in stack.yaml that matches what you
                        -- might pass directly to GHC.
                        [T.unwords $ rtsArgs ++ ["-RTS"]]
            -- We drop the first element from `end`, because it is always
            -- either `"-RTS"` (and we don't want that as a separate
            -- argument) or the list is empty (and `drop _ [] = []`).
            postRtsArgs =
                drop 1 end
            newArgs =
                concat [preRtsArgs, fullRtsArgs, postRtsArgs]
        in
            concatMap (\x -> [compilerOptionsCabalFlag wc, T.unpack x]) newArgs

    wc = view (actualCompilerVersionL.to whichCompiler) econfig
    cv = view (actualCompilerVersionL.to getGhcVersion) econfig

    hideSourcePaths ghcVersion = ghcVersion >= C.mkVersion [8, 2] && configHideSourcePaths config

    config = view configL econfig
    bopts = bcoBuildOpts bco

    newerCabal = view cabalVersionL econfig >= C.mkVersion [1, 22]

    -- Unioning atop defaults is needed so that all flags are specified
    -- with --exact-configuration.
    flags = packageFlags package `Map.union` packageDefaultFlags package

    depOptions = map (uncurry toDepOption) $ Map.toList deps
      where
        toDepOption = if newerCabal then toDepOption1_22 else toDepOption1_18

    toDepOption1_22 (PackageIdentifier name _) gid = concat
        [ "--dependency="
        , packageNameString name
        , "="
        , ghcPkgIdString gid
        ]

    toDepOption1_18 ident _gid = concat
        [ "--constraint="
        , packageNameString name
        , "=="
        , versionString version'
        ]
      where
        PackageIdentifier name version' = ident

-- | Get set of wanted package names from locals.
wantedLocalPackages :: [LocalPackage] -> Set PackageName
wantedLocalPackages = Set.fromList . map (packageName . lpPackage) . filter lpWanted

-- | Configure options to be sent to Setup.hs configure
data ConfigureOpts = ConfigureOpts
    { coDirs :: ![String]
    -- ^ Options related to various paths. We separate these out since they do
    -- not have an impact on the contents of the compiled binary for checking
    -- if we can use an existing precompiled cache.
    , coNoDirs :: ![String]
    }
    deriving (Show, Eq, Generic, Data, Typeable)
instance NFData ConfigureOpts

-- | Information on a compiled package: the library conf file (if relevant),
-- the sublibraries (if present) and all of the executable paths.
data PrecompiledCache base = PrecompiledCache
    { pcLibrary :: !(Maybe (Path base File))
    -- ^ .conf file inside the package database
    , pcSubLibs :: ![Path base File]
    -- ^ .conf file inside the package database, for each of the sublibraries
    , pcExes    :: ![Path base File]
    -- ^ Full paths to executables
    }
    deriving (Show, Eq, Generic, Typeable)
instance NFData (PrecompiledCache Abs)
instance NFData (PrecompiledCache Rel)
