Plan.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

-- | "Tilia.Fixity" resolves a module's operators exactly, given a function
-- that says what each imported module exports. This is that function, built
-- from what the project itself is compiled against.
module Tilia.Fixity.Plan
  ( -- * Build plans
    PlanPackage (..),
    PackageSource (..),
    isFetchable,
    sourceHashOf,
    BuildPlan (..),
    readBuildPlan,
    planToken,
    tokenFor,
    macrosOf,

    -- * Readiness
    Readiness (..),
    PlanComponent (..),
    spellComponent,
    plannedComponents,
    planPathFor,
    checkReadiness,
    plannedTarballs,
    packageCacheRoot,
    guessedPackageCacheRoot,
    Solves (..),
    forgetfulSolves,
    prepareWith,
    loadPlan,

    -- * Resolving
    Route (..),
    Resolver (..),
    newResolver,
    newResolverVia,
    withReexports,
    scopeFor,
  )
where

import Codec.Archive.Tar qualified as Tar
import Codec.Compression.GZip qualified as GZip
import Control.Applicative ((<|>))
import Control.Monad (filterM, foldM, join)
import Crypto.Hash.SHA256 qualified as SHA256
import Data.Aeson
  ( FromJSON (..),
    Value,
    decodeStrict,
    eitherDecodeFileStrict,
    withObject,
    (.:),
    (.:?),
  )
import Data.Aeson.Types (parseMaybe)
import Data.ByteString qualified as BS
import Data.ByteString.Base16 qualified as B16
import Data.ByteString.Lazy qualified as BL
import Data.Choice (Choice, fromBool)
import Data.Foldable (toList, traverse_)
import Data.IORef
import Data.List (isSuffixOf)
import Data.List qualified
import Data.List.NonEmpty (NonEmpty ((:|)))
import Data.List.NonEmpty qualified as NE
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Maybe (catMaybes, fromMaybe, listToMaybe, mapMaybe)
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.Encoding qualified as T
import Data.Text.Read qualified as T
import GHC.Hs (HsModule)
import GHC.Hs.Extension (GhcPs)
import GHC.IO.Handle (hDuplicate)
import GHC.LanguageExtensions.Type (Extension (ImplicitPrelude))
import System.Directory
  ( XdgDirectory (XdgCache),
    doesFileExist,
    getAppUserDataDirectory,
    getModificationTime,
    getXdgDirectory,
    listDirectory,
  )
import System.Environment (lookupEnv)
import System.Exit (ExitCode (..))
import System.FilePath (takeDirectory, (</>))
import System.IO (hFlush, stderr)
import System.Info qualified
import System.Process
  ( StdStream (Inherit, UseHandle),
    createProcess,
    cwd,
    proc,
    std_err,
    std_out,
    waitForProcess,
  )
import Tilia.Cpp (branchLeaves, withoutRuledOut)
import Tilia.Cpp.Macros (Macros (..))
import Tilia.Fixity
import Tilia.Fixity.Builtin (builtinFixities)
import Tilia.Fixity.ByHand (byHandFixities, hscFixities)
import Tilia.Fixity.Cabal
  ( cabalFileAtTop,
    cabalFileInArchive,
    containedModules,
    declaredExtensions,
    entryPosixPath,
    packageModules,
    sourceDirs,
  )
import Tilia.Fixity.Cache
import Tilia.Fixity.Interface
import Tilia.Fixity.PackageDb
import Tilia.Package (newPackageReader)
import Tilia.Parser
import Tilia.Pragma (effectiveExtensions)
import Tilia.Process (readProgramOutput)
import Tilia.Utils (quietly)

----------------------------------------------------------------------------
-- The plan

-- | One package of a build plan.
data PlanPackage = PlanPackage
  { -- | Package name
    ppName :: Text,
    -- | Package version
    ppVersion :: Text,
    -- | Package source
    ppSource :: PackageSource,
    -- | Which components of the package the entry is about.
    --
    -- Usually one, because @cabal@ configures a package one component at a
    -- time and gives each its own entry. A package it cannot take apart—one
    -- with a @Custom@ build type, whose @Setup.hs@ is entitled to do as it
    -- pleases—is planned whole instead, and its entry is about every
    -- component at once. Empty where the entry is about none of them.
    ppComponents :: [Text]
  }
  deriving (Eq, Show)

-- | Where a package's source is, if anywhere.
--
-- A plan contains exactly three kinds of entry and they are mutually
-- exclusive, which two independent flags could not say: a package cannot be
-- both shipped with the compiler and fetched from Hackage. Each carries
-- what is peculiar to it and nothing else, so there is no hash to consult
-- on a package that has no tarball, and no tarball to look for on one that
-- is a directory.
data PackageSource
  = -- | Already installed, so @cabal@ will not build it.
    --
    -- Not the same as "ships with the compiler", though it includes those.
    PreExisting
  | -- | A directory on this machine—the project being formatted, or a
    -- sibling of it in the same repository.
    LocalPackage FilePath
  | -- | Fetched from a repository as a tarball, with the SHA-256 the plan
    -- expects it to have and where it was fetched from.
    --
    -- Hackage is one such repository and not a special one. A company that
    -- runs its own has packages here exactly as Hackage does, and the only
    -- difference that reaches us is where the tarball landed.
    RepoPackage (Maybe Text) Repository
  | -- | A @source-repository-package@ we have not found the sources of.
    --
    -- The plan says where the repository is, which is of no use: what is
    -- wanted is where @cabal@ put the clone, and the plan does not say. A
    -- package that stays this way is one nothing can be read from, which is
    -- what every one of them was before 'checkedOutIn' went looking.
    SourceRepo
  | -- | The same, found unpacked under the project's own @dist-newstyle@.
    --
    -- A directory of sources like 'LocalPackage', and read the same way.
    -- Kept apart from it because a dependency is not one of the project's
    -- own packages: its components are not components a run formats, and
    -- its @.cabal@ file being newer than the plan says nothing about
    -- whether the plan is stale.
    CheckedOut FilePath
  deriving (Eq, Show)

-- | Which repository a package was fetched from, as far as it bears on
-- finding the tarball afterwards.
data Repository
  = -- | One @cabal@ downloads from, named by its URI. The tarball goes into
    -- the package cache, in a directory named after the repository as the
    -- configuration spells it.
    Downloaded Text
  | -- | A directory of tarballs, named by @file+noindex@. Nothing is
    -- downloaded and nothing is cached: the tarball is already sitting
    -- there, beside the index @cabal@ wrote for it.
    ADirectory FilePath
  | -- | A plan that does not say. Older @cabal@ wrote nothing here, and
    -- Hackage is the only guess worth making.
    Unsaid
  deriving (Eq, Show)

-- | Is there a tarball to go and read?
isFetchable :: PlanPackage -> Bool
isFetchable p = case ppSource p of
  RepoPackage _ _ -> True
  _ -> False

-- | Every package the compiler can see.
whatTheCompilerSees :: Maybe Cache -> IO [InstalledPackage]
whatTheCompilerSees cache =
  remembered >>= \case
    Just packages -> pure packages
    Nothing -> do
      found <- readInstalledPackages
      traverse_ (`storeInstalled` found) cache
      pure (installedPackages found)
  where
    remembered = maybe (pure Nothing) cachedInstalled cache

-- | Summarize a 'BuildPlan', and the environment it will be read in, by
-- hashing over both.
--
-- The plan alone would not do. What a failure to read a module leans on is
-- partly the plan and partly the compiler this run can ask: a package the
-- plan names is unreadable where @ghc-pkg@ does not expose it and readable
-- where it does, and one shell can differ from another in that while
-- solving the very same plan. Tying failures to the plan alone would let
-- one shell's \"could not be read\" be handed to a shell that can.
tokenFor :: BuildPlan -> IO PlanToken
tokenFor plan = flip planToken plan <$> compilerIdentity

-- | 'tokenFor' without the asking, so that what goes into the token is
-- visible in one place.
planToken :: Text -> BuildPlan -> PlanToken
planToken environment plan =
  PlanToken
    . T.take 16
    . T.decodeUtf8Lenient
    . B16.encode
    . SHA256.hash
    . T.encodeUtf8
    $ T.intercalate
      "\n"
      (environment : bpCompiler plan : Data.List.sort (map cacheKey (bpPackages plan)))

-- | The SHA-256 the plan expects this package's tarball to have.
sourceHashOf :: PlanPackage -> Maybe Text
sourceHashOf p = case ppSource p of
  RepoPackage hash _ -> hash
  _ -> Nothing

-- | A resolved build plan.
data BuildPlan = BuildPlan
  { bpCompiler :: Text,
    bpPackages :: [PlanPackage]
  }
  deriving (Eq, Show)

instance FromJSON BuildPlan where
  parseJSON = withObject "BuildPlan" $ \o ->
    BuildPlan
      <$> o .: "compiler-id"
      <*> o .: "install-plan"

instance FromJSON PlanPackage where
  parseJSON = withObject "PlanPackage" $ \o -> do
    name <- o .: "pkg-name"
    version <- o .: "pkg-version"
    kind <- o .:? "type"
    sourceKind <- o .:? "pkg-src" >>= traverse (.: "type")
    sourcePath <- o .:? "pkg-src" >>= traverse (.:? "path")
    sourceHash <- o .:? "pkg-src-sha256"
    repo <- o .:? "pkg-src" >>= traverse (.:? "repo")
    repoKind <- traverse (traverse (.:? "type")) repo
    repoUri <- traverse (traverse (.:? "uri")) repo
    repoPath <- traverse (traverse (.:? "path")) repo
    named <- o .:? "component-name"
    whole <- o .:? "components"
    pure
      PlanPackage
        { ppName = name,
          ppVersion = version,
          ppComponents = componentsOf named whole,
          ppSource = case (kind :: Maybe Text, sourceKind :: Maybe Text) of
            (Just "pre-existing", _) -> PreExisting
            (_, Just "repo-tar") ->
              RepoPackage
                sourceHash
                ( case (join (join repoKind) :: Maybe Text, join (join repoPath), join (join repoUri)) of
                    (Just "local-repo-no-index", Just dir, _) -> ADirectory (T.unpack dir)
                    (_, _, Just uri) -> Downloaded uri
                    _ -> Unsaid
                )
            (_, Just "local") -> LocalPackage (maybe "" T.unpack (join sourcePath))
            (_, Just "source-repo") -> SourceRepo
            -- Anything else is treated as already present.
            _ -> PreExisting
        }

-- | The components one plan entry is about.
--
-- @cabal@ writes this two ways. An entry for a single component names it in
-- @component-name@; an entry for a package planned whole carries a
-- @components@ object instead, keyed by the very same spellings. Reading
-- only the first would leave every @Custom@ package looking like one the
-- plan says nothing about, and a run would keep asking @cabal@ to solve
-- again for components a fresh solve would file exactly where this one did.
--
-- @setup@ is dropped. It is the @Setup.hs@ program @cabal@ builds in order
-- to build the package, not a component of the package, and nothing in the
-- project will ever be formatted as part of it.
componentsOf :: Maybe Text -> Maybe (Map Text Value) -> [Text]
componentsOf named whole = case named of
  Just component -> [component]
  Nothing -> filter (/= "setup") (Map.keys (fromMaybe Map.empty whole))

-- | Read @plan.json@.
readBuildPlan :: FilePath -> IO (Either Text BuildPlan)
readBuildPlan path =
  doesFileExist path >>= \case
    False -> pure (Left ("no build plan at " <> T.pack path))
    True ->
      eitherDecodeFileStrict path >>= \case
        Left why -> pure (Left (T.pack why))
        Right plan -> Right <$> checkedOutIn (takeDirectory (takeDirectory path)) plan

-- | Find where @cabal@ unpacked each @source-repository-package@.
checkedOutIn :: FilePath -> BuildPlan -> IO BuildPlan
checkedOutIn distDir plan = do
  packages <- traverse locate (bpPackages plan)
  pure plan {bpPackages = packages}
  where
    locate p = case ppSource p of
      SourceRepo ->
        clonesOf p >>= \case
          (dir : _) -> pure p {ppSource = CheckedOut dir}
          [] -> pure p
      _ -> pure p
    clonesOf p = quietly [] $ do
      entries <- listDirectory (distDir </> "src")
      filterM
        (isThePackage p)
        [ distDir </> "src" </> e
        | e <- Data.List.sort entries,
          (ppName p <> "-") `T.isPrefixOf` T.pack e
        ]
    isThePackage p dir = quietly False $ do
      contents <- readFileText (dir </> T.unpack (ppName p) <> ".cabal")
      pure (maybe False (describes p) contents)
    describes p text =
      any (names "name:" (ppName p)) (T.lines text)
        && any (names "version:" (ppVersion p)) (T.lines text)
    names field value line = case T.stripPrefix field (T.toLower (T.strip line)) of
      Just rest -> T.strip rest == T.toLower value
      Nothing -> False

-- | The version macros a plan settles.
macrosOf :: BuildPlan -> Macros
macrosOf plan =
  Macros
    { macroVersions =
        Map.fromList
          ( [ ("MIN_VERSION_" <> underscored name, version)
            | (name, [version]) <- Map.toList (Map.map Set.toList versions)
            ]
              <> [("MIN_VERSION_GLASGOW_HASKELL", v) | v <- toList compiler]
          ),
      macroNumbers =
        Map.fromList
          [ entry
          | (major : minor : patches) <- toList compiler,
            entry <-
              [ ("__GLASGOW_HASKELL__", major * 100 + minor),
                ("__GLASGOW_HASKELL_PATCHLEVEL1__", nth 0 patches),
                ("__GLASGOW_HASKELL_PATCHLEVEL2__", nth 1 patches)
              ]
          ]
    }
  where
    versions =
      Map.fromListWith
        Set.union
        [ (ppName p, Set.singleton v)
        | p <- bpPackages plan,
          Just v <- [numberedVersion (ppVersion p)]
        ]
    compiler = do
      version <- T.stripPrefix "ghc-" (bpCompiler plan)
      parts <- numberedVersion version
      case parts of
        _ : _ : _ -> Just (take 4 (parts <> repeat 0))
        _ -> Nothing
    nth i xs = if i < length xs then xs !! i else 0

-- | The modules @cabal@ writes itself for a plan's packages, and which are
-- therefore in nobody's sources.
generatedModules :: BuildPlan -> Set Text
generatedModules plan =
  Set.fromList
    [ prefix <> underscored (ppName p)
    | p <- bpPackages plan,
      prefix <- ["Paths_", "PackageInfo_"]
    ]

-- | A package's name as a module name spells it, which is with the hyphens
-- turned into underscores. @cabal@ does this for the version macros and for
-- the modules it generates alike.
underscored :: Text -> Text
underscored = T.map (\c -> if c == '-' then '_' else c)

-- | A version as its numbers, or 'Nothing' where any of them is not one.
numberedVersion :: Text -> Maybe [Integer]
numberedVersion = traverse number . T.splitOn "."
  where
    number part = case T.decimal part of
      Right (n, rest) | T.null rest -> Just n
      _ -> Nothing

----------------------------------------------------------------------------
-- Readiness

-- | A component of the project, named the way a build plan names one.
data PlanComponent = PlanComponent
  { -- | The package it belongs to.
    pcPackage :: Text,
    -- | @lib@, @exe:name@, @test:name@, @bench:name@.
    pcName :: Text
  }
  deriving (Eq, Ord, Show)

-- | A component as it would be written on the command line.
spellComponent :: PlanComponent -> Text
spellComponent c = pcPackage c <> ":" <> pcName c

-- | The components of the project's own packages that a plan covers.
plannedComponents :: BuildPlan -> [PlanComponent]
plannedComponents plan =
  [ PlanComponent (ppName p) component
  | p <- bpPackages plan,
    LocalPackage _ <- [ppSource p],
    component <- ppComponents p
  ]

-- | Whether everything the resolver needs is on disk.
data Readiness
  = -- | Nothing to do.
    Ready
  | -- | No build plan; @cabal@ has not solved this project yet.
    PlanMissing
  | -- | The plan is older than the files that determine it.
    PlanStale [FilePath]
  | -- | The plan says nothing about components the run is about to format.
    PlanNarrow [Text]
  | -- | The plan is there, and some packages have neither been downloaded
    -- nor built. The names are listed so that a caller can say what it is
    -- waiting for.
    --
    -- Built counts as having them: their interfaces answer everything the
    -- source would have been read for, so a package the compiler already
    -- holds is not missing however absent its tarball is.
    SourcesMissing [Text]
  deriving (Eq, Show)

-- | Where @cabal@ writes the plan for a project.
planPathFor :: FilePath -> FilePath
planPathFor projectDir = projectDir </> "dist-newstyle" </> "cache" </> "plan.json"

-- | Check what is missing, cheaply.
--
-- One read of the plan and one @stat@ per package, so this is fast enough
-- to run before every format without anyone noticing.
checkReadiness :: [PlanComponent] -> FilePath -> IO Readiness
checkReadiness wanted projectDir =
  readBuildPlan (planPathFor projectDir) >>= \case
    Left _ -> pure PlanMissing
    Right plan -> do
      newer <- filesNewerThanPlan plan projectDir
      let covered = plannedComponents plan
          missing = [spellComponent c | c <- wanted, c `notElem` covered]
      case (newer, missing) of
        (_ : _, _) -> pure (PlanStale newer)
        ([], _ : _) -> pure (PlanNarrow missing)
        ([], []) ->
          sourcesShortOf plan >>= \case
            [] -> pure Ready
            ns -> pure (SourcesMissing ns)

-- | The packages the plan expects to fetch whose sources are not here.
--
-- Asked apart from the rest of 'checkReadiness' because it is a different
-- question with a different answer. Whether the plan covers the components
-- a run is about to format is about the plan; whether the sources it names
-- are on this machine is about the machine, and a plan that will never
-- cover everything—one component of the project does not build, and the
-- solver leaves it out—must not stop the sources for the rest being
-- fetched.
sourcesShortOf :: BuildPlan -> IO [Text]
sourcesShortOf plan = do
  tarballs <- filter (isFetchable . fst) <$> plannedTarballs plan
  absent <- map fst <$> filterM (fmap not . doesFileExist . snd) tarballs
  short <-
    if null absent
      then pure []
      else do
        cache <- openCache =<< tokenFor plan
        installed <- whatTheCompilerSees cache
        pure (filter (not . builtAlready installed) absent)
  pure (map ppName short)

-- | Has the compiler got this package already?
builtAlready :: [InstalledPackage] -> PlanPackage -> Bool
builtAlready installed p = any matches installed
  where
    matches i = ipName i == ppName p && ipVersion i == ppVersion p

-- | The project files that have changed since the plan was written.
--
-- A plan describes the dependencies as they were when @cabal@ last solved.
-- Edit a @build-depends@ and the plan on disk is about a different project,
-- and resolving fixities against it would answer for packages that are no
-- longer in play. Comparing modification times is one @stat@ each, so this
-- costs nothing to check every time.
filesNewerThanPlan :: BuildPlan -> FilePath -> IO [FilePath]
filesNewerThanPlan plan projectDir = quietly [] $ do
  planTime <- getModificationTime (planPathFor projectDir)
  atRoot <- quietly [] (listDirectory projectDir)
  inPackages <- concat <$> traverse cabalFilesIn (localDirs plan)
  let candidates =
        [projectDir </> f | f <- atRoot, f `elem` projectFiles]
          <> [projectDir </> f | f <- atRoot, ".cabal" `isSuffixOf` f]
          <> inPackages
  newer <- traverse (isNewerThan planTime) candidates
  pure [f | Just f <- newer]
  where
    projectFiles =
      ["cabal.project", "cabal.project.local", "cabal.project.freeze"]
    localDirs p =
      Data.List.nub [dir | LocalPackage dir <- map ppSource (bpPackages p)]
    cabalFilesIn dir = quietly [] $ do
      entries <- listDirectory dir
      pure [dir </> f | f <- entries, ".cabal" `isSuffixOf` f]
    isNewerThan planTime path = quietly Nothing $ do
      t <- getModificationTime path
      pure (if t > planTime then Just path else Nothing)

-- | Do whatever is missing, by asking @cabal@.
--
-- Neither of these builds anything: a dry run only solves, and
-- @--only-download@ only fetches. Both are one-time costs, and @cabal@'s
-- package cache is shared between projects, so a machine that has seen a
-- dependency once never fetches it again.
--
-- This runs a subprocess and may reach the network, so it is a separate
-- call rather than something 'newResolver' does behind the caller's back.
-- An editor formatting on save must not block on it.
prepare :: [PlanComponent] -> FilePath -> Readiness -> IO (Either Text ())
prepare wanted projectDir readiness =
  prepareWith (runCabal projectDir) (solvesFor projectDir) wanted projectDir readiness

-- | What a run knows about the asking earlier runs did, and how to add to
-- it.
--
-- Both halves are the same idea: @cabal@ was asked for something, it did
-- not help, and asking again will not help either. A run that formats on
-- save would otherwise ask on every save.
data Solves = Solves
  { -- | Has solving this plan already been tried and left it as narrow?
    solveWasFutile :: IO Bool,
    -- | Remember that it has.
    rememberFutileSolve :: IO (),
    -- | The packages an earlier fetch was still short of afterwards.
    fetchWasFutileFor :: IO [Text],
    -- | Remember what a fetch left missing.
    rememberFutileFetch :: [Text] -> IO ()
  }

-- | Solves remembered nowhere, for a caller with nothing to remember them
-- in.
forgetfulSolves :: Solves
forgetfulSolves =
  Solves
    { solveWasFutile = pure False,
      rememberFutileSolve = pure (),
      fetchWasFutileFor = pure [],
      rememberFutileFetch = const (pure ())
    }

-- | Solves remembered in the cache, under the plan the project has now.
--
-- A project with no readable plan has no token to file anything under, and
-- nothing to remember either: a solve is exactly what it needs.
solvesFor :: FilePath -> Solves
solvesFor projectDir =
  Solves
    { solveWasFutile = withCache False cachedFutileSolve,
      rememberFutileSolve = withCache () storeFutileSolve,
      fetchWasFutileFor = withCache [] cachedFutileFetch,
      rememberFutileFetch = \packages -> withCache () (`storeFutileFetch` packages)
    }
  where
    withCache fallback use =
      readBuildPlan (planPathFor projectDir) >>= \case
        Left _ -> pure fallback
        Right plan -> do
          opened <- openCache =<< tokenFor plan
          maybe (pure fallback) use opened

-- | 'prepare', given a way to run @cabal@ and a memory of earlier solves.
prepareWith ::
  -- | Run @cabal@ with these arguments
  ([String] -> IO (Either Text ())) ->
  -- | What is known about solves already asked for
  Solves ->
  -- | The components the run is about to format
  [PlanComponent] ->
  -- | The project being prepared
  FilePath ->
  -- | What it was found to be short of
  Readiness ->
  IO (Either Text ())
prepareWith cabal solves wanted projectDir = \case
  Ready -> pure (Right ())
  SourcesMissing _ -> fetch
  PlanMissing -> solveThenFetch
  PlanStale _ -> solveThenFetch
  PlanNarrow _ ->
    solveWasFutile solves >>= \case
      True -> fetchWhatIsShort
      False -> solveThenFetch
  where
    wholeProject = ["--enable-tests", "--enable-benchmarks"]
    tryWholeProject args =
      cabal (args <> wholeProject) >>= \case
        Right () -> pure (Right ())
        Left _ -> cabal args
    fetch = tryWholeProject ["build", "all", "--only-download"]
    fetchWhatIsShort =
      readBuildPlan (planPathFor projectDir) >>= \case
        Left _ -> pure (Right ())
        Right plan -> do
          short <- sourcesShortOf plan
          refused <- fetchWasFutileFor solves
          if null short || all (`elem` refused) short
            then pure (Right ())
            else
              fetch >>= \case
                Left err -> pure (Left err)
                Right () -> do
                  left <- sourcesShortOf plan
                  rememberFutileFetch solves left
                  pure (Right ())
    solveThenFetch =
      tryWholeProject ["build", "all", "--dry-run"] >>= \case
        Left err -> pure (Left err)
        Right () ->
          checkReadiness wanted projectDir >>= \case
            SourcesMissing _ -> fetch
            PlanNarrow _ -> rememberFutileSolve solves >> fetchWhatIsShort
            _ -> pure (Right ())

-- | Run @cabal@ in a project directory, letting it speak for itself.
runCabal :: FilePath -> [String] -> IO (Either Text ())
runCabal projectDir args = quietly (Left "could not run cabal") $ do
  hFlush stderr
  -- A duplicate because 'createProcess' closes the handle it is given once
  -- the child has it, and closing the real standard error would leave
  -- nothing to report the failure on.
  passed <- hDuplicate stderr
  (_, _, _, running) <-
    createProcess
      (proc "cabal" args)
        { cwd = Just projectDir,
          std_out = UseHandle passed,
          std_err = Inherit
        }
  code <- waitForProcess running
  pure $ case code of
    ExitSuccess -> Right ()
    _ -> Left ("cabal " <> T.unwords (map T.pack args) <> " failed; see above")

-- | Get a plan that is safe to use, doing whatever @cabal@ work is needed.
--
-- This is the call most users want. It checks, asks @cabal@ if anything is
-- missing or possibly out of date, and then reads the plan. 'prepare' does
-- at most one solve and one fetch however much is missing, so a project
-- whose files are merely newer than its plan cannot send this into a loop,
-- and the plan is read once at the end rather than judged again.
loadPlan :: [PlanComponent] -> FilePath -> IO (Either Text BuildPlan)
loadPlan wanted projectDir = do
  readiness <- checkReadiness wanted projectDir
  prepare wanted projectDir readiness >>= \case
    Left err -> pure (Left err)
    _ -> readBuildPlan (planPathFor projectDir)

-- | Every planned package whose source could be in the package cache, with
-- where that would be.
--
-- Not only the ones the plan will fetch. A package already installed still
-- has a tarball in the cache if anything ever downloaded it, and under Nix
-- that is the normal case for every dependency. A package with no tarball
-- costs one @stat@ and falls through.
--
-- Local packages are excluded: they are directories, not archives.
plannedTarballs :: BuildPlan -> IO [(PlanPackage, FilePath)]
plannedTarballs plan = do
  cacheRoot <- packageCacheRoot
  -- Listed once rather than once per package: a plan holds hundreds of
  -- these and the answer is the same for every one of them.
  repos <- quietly [] (Data.List.sort <$> listDirectory cacheRoot)
  traverse
    (\p -> (,) p <$> tarballFor cacheRoot repos p)
    [p | p <- bpPackages plan, not (isLocal p)]
  where
    isLocal p = case ppSource p of
      LocalPackage _ -> True
      CheckedOut _ -> True
      _ -> False

-- | Where @cabal@ keeps downloaded package sources, one directory per
-- repository it downloads from.
packageCacheRoot :: IO FilePath
packageCacheRoot =
  readProgramOutput "cabal" ["path", "--remote-repo-cache", "--output-format=json"] >>= \case
    Just said | Just dir <- remoteRepoCacheIn said -> pure dir
    _ -> guessedPackageCacheRoot

-- | The package cache directory, out of what @cabal path@ printed.
remoteRepoCacheIn :: Text -> Maybe FilePath
remoteRepoCacheIn said = do
  spoken <- listToMaybe (reverse (filter (not . T.null) (map T.strip (T.lines said))))
  value <- decodeStrict (T.encodeUtf8 spoken)
  parseMaybe (withObject "cabal path" (.: "remote-repo-cache")) value

-- | Where @cabal@ probably keeps them, for a @cabal@ that will not say.
guessedPackageCacheRoot :: IO FilePath
guessedPackageCacheRoot =
  lookupEnv "CABAL_DIR" >>= \case
    Just dir -> pure (dir </> "packages")
    Nothing -> do
      places <- cabalDirs
      found <- filterM holdsAnIndex (toList places)
      pure (fromMaybe (NE.head places) (listToMaybe found))
  where
    holdsAnIndex dir =
      quietly False (doesFileExist (dir </> hackage </> "01-index.tar"))
    hackage = "hackage.haskell.org"

-- | Every directory @cabal@ could be keeping a package cache in, the
-- platform's own default first.
cabalDirs :: IO (NonEmpty FilePath)
cabalDirs = do
  appData <- getAppUserDataDirectory "cabal"
  xdg <- quietly Nothing (Just <$> getXdgDirectory XdgCache "cabal")
  pure . fmap (</> "packages") $ case xdg of
    Just dir | not onWindows -> dir :| [appData]
    Just dir -> appData :| [dir]
    Nothing -> appData :| []

-- | Whether this is a Windows build, for the places that differ there.
onWindows :: Bool
onWindows = System.Info.os == "mingw32"

-- | The repository @cabal@ would have kept a package's sources under.
hackageByDefault :: FilePath
hackageByDefault = "hackage.haskell.org"

-- | Where a package's source tarball is, or where fetching would put it.
tarballFor :: FilePath -> [FilePath] -> PlanPackage -> IO FilePath
tarballFor cacheRoot repos p = case repositoryOf p of
  ADirectory dir -> pure (dir </> flat)
  Downloaded uri -> searched (hostOf uri)
  Unsaid -> searched Nothing
  where
    flat = T.unpack (ppName p <> "-" <> ppVersion p <> ".tar.gz")
    under repo =
      cacheRoot </> repo </> T.unpack (ppName p) </> T.unpack (ppVersion p) </> flat
    searched preferred = do
      let first' = fromMaybe hackageByDefault preferred
          rest = filter (/= first') repos
      found <- filterM doesFileExist (map under (first' : rest))
      pure (fromMaybe (under first') (listToMaybe found))

-- | Which repository a package came from, where it came from one.
repositoryOf :: PlanPackage -> Repository
repositoryOf p = case ppSource p of
  RepoPackage _ repo -> repo
  _ -> Unsaid

-- | The host a URI names, which is what @cabal@ conventionally calls the
-- repository that lives there.
hostOf :: Text -> Maybe FilePath
hostOf uri = case T.breakOn "//" uri of
  (_, rest)
    | not (T.null rest),
      host <- T.takeWhile (/= '/') (T.drop 2 rest),
      not (T.null host) ->
        Just (T.unpack host)
  _ -> Nothing

----------------------------------------------------------------------------
-- Resolving

-- | Where a module's fixities can be read from.
data Route
  = -- | The compiled interface the package database points at. Cheap, and
    -- authoritative where it exists, since it is the compiler's own account
    -- of what it settled on.
    FromInterface
  | -- | The module's source, out of the package's tarball in Cabal's
    -- package cache. Slower, and the only route for a package that is
    -- planned but not built.
    FromSource
  deriving (Eq, Show)

-- | What can be asked about a module, once a plan says where to look.
--
-- The three questions "Tilia.Fixity" has, answered against the outside
-- world. They come back together because they share everything—the module
-- index, the cache, the packages the compiler holds, the memo of what has
-- been read—and answering them apart would settle all of it three times.
data Resolver = Resolver
  { -- | What a module exports, with 'Nothing' for one that could not be
    -- read, which is not the same as its having no operators; see
    -- 'Tilia.Fixity.resolveScope' for why the difference has to survive.
    askFixities :: Text -> IO (Maybe (Fixities)),
    -- | What a module keeps under each of its names, for the sake of a
    -- @T(..)@ in an import list.
    askChildren :: Text -> IO (Map OpName (Set OpName)),
    -- | The operators an unread module's export list names, asked only of
    -- the modules 'askFixities' gave up on, and what keeps a module that
    -- plainly has no such operator from being blamed for one.
    askExportNames :: Text -> IO (Maybe (Set OpName)),
    -- | The modules reading a module went through before giving up, the one
    -- it gave up on last. Asked only of the modules 'askFixities' gave up
    -- on, and only so that a message can name the module really in the way
    -- rather than the import that happens to sit above it.
    askChain :: Text -> IO [Text]
  }

-- | Build the answers to what "Tilia.Fixity" asks.
--
-- Answers are remembered on disk between runs by "Tilia.Fixity.Cache", so a
-- package is decompressed and parsed once per machine rather than once per
-- file.
newResolver ::
  -- | The build plan to use
  BuildPlan ->
  IO Resolver
newResolver = newResolverVia [FromInterface, FromSource]

-- | 'newResolver', restricted to the routes given.
newResolverVia ::
  -- | Which readings to try, in order
  [Route] ->
  -- | The build plan to use
  BuildPlan ->
  IO Resolver
newResolverVia routes plan = do
  tarballs <- plannedTarballs plan
  cache <- openCache =<< tokenFor plan
  installed <- whatTheCompilerSees cache
  index <- buildModuleIndex cache installed tarballs
  let interfaces = interfaceIndex installed
  local <- localModules plan
  memo <- newIORef Map.empty
  childrenRead <- newIORef Map.empty
  askPackage <- newPackageReader
  extensionsRead <- newIORef Map.empty
  exportsRead <- newIORef Map.empty
  interfacesRead <- newIORef Map.empty
  let interfaceOf modName = do
        seen <- readIORef interfacesRead
        case Map.lookup modName seen of
          Just interface -> pure interface
          Nothing -> do
            found <- case Map.lookup modName interfaces of
              Nothing -> pure Nothing
              Just (_, path) -> readInterface modName path
            -- Being listed is not the same as being readable: @ghc-pkg@
            -- names @GHC.Prim@ among @ghc-prim@'s modules and there is no
            -- file at the path that implies. So the table answers for a
            -- module with nothing to read, however it came to have nothing.
            let interface = case found of
                  Just _ -> found
                  Nothing -> asInterface <$> Map.lookup modName builtinFixities
            atomicModifyIORef' interfacesRead (\m -> (Map.insert modName interface m, ()))
            pure interface
  let workings =
        Workings
          { wkRoutes = routes,
            wkCache = cache,
            wkLocal = local,
            wkIndex = index,
            wkInterfaces = interfaces,
            wkInterfaceOf = interfaceOf,
            wkReach = reach,
            wkReachChildren = children,
            wkReachExports = exports,
            wkExtensionsOf = extensionsOf,
            wkMacros = macrosOf plan,
            wkGenerated = generatedModules plan
          }
      resolved visiting modName = do
        known <- readIORef memo
        case Map.lookup modName known of
          Just answer -> pure answer
          Nothing -> do
            answer <- resolveModule workings visiting modName
            atomicModifyIORef' memo (\m -> (Map.insert modName answer m, ()))
            pure answer
      reach visiting modName
        | modName `Set.member` visiting = pure Nothing
        | otherwise = fixitiesEstablished <$> resolved visiting modName
      chain visiting = go Set.empty
        where
          go seen modName
            | modName `Set.member` seen = pure []
            | otherwise =
                resolved visiting modName >>= \case
                  Unreadable (Just below) ->
                    (below :) <$> go (Set.insert modName seen) below
                  _ -> pure []
      exports visiting modName
        | modName `Set.member` visiting = pure Nothing
        | otherwise = do
            seen <- readIORef exportsRead
            case Map.lookup modName seen of
              Just names -> pure names
              Nothing -> do
                names <- exportNamesOfModule workings visiting modName
                atomicModifyIORef' exportsRead (\m -> (Map.insert modName names m, ()))
                pure names
      extensionsOf modName
        | Just path <- Map.lookup modName local =
            either (const []) id <$> askPackage path
        | Just (package, tarball) <- Map.lookup modName index = do
            seen <- readIORef extensionsRead
            case Map.lookup package seen of
              Just extensions -> pure extensions
              Nothing -> do
                extensions <- fromTarball tarball
                atomicModifyIORef' extensionsRead (\m -> (Map.insert package extensions m, ()))
                pure extensions
        | otherwise = pure []
      fromTarball tarball =
        quietly [] $ do
          bytes <- BL.readFile tarball
          pure (foldMap declaredExtensions (cabalFileInArchive (Tar.read (GZip.decompress bytes))))
      children visiting modName
        | modName `Set.member` visiting = pure Map.empty
        | otherwise = do
            seen <- readIORef childrenRead
            case Map.lookup modName seen of
              Just kept -> pure kept
              Nothing -> do
                kept <- childrenOfModule workings visiting modName
                atomicModifyIORef' childrenRead (\m -> (Map.insert modName kept m, ()))
                pure kept
  pure
    Resolver
      { askFixities = reach Set.empty,
        askChildren = children Set.empty,
        askExportNames = exports Set.empty,
        askChain = chain Set.empty
      }

-- | The operators a module's export list names, where that list can be
-- enumerated without reading what it passes on.
--
-- Asked only about modules whose fixities could not be established, and
-- only to decide which of them an unsettled operator can be blamed on. A
-- module that exports whole modules keeps its own counsel and answers
-- 'Nothing'; one with no export list exports what it declares, which is
-- every fixity it could supply.
exportNamesOfModule :: Workings -> Set Text -> Text -> IO (Maybe (Set OpName))
exportNamesOfModule
  Workings {wkCache, wkLocal, wkIndex, wkReachChildren, wkReachExports, wkMacros}
  visiting
  modName
    | Just path <- Map.lookup modName wkLocal,
      writtenForHsc path =
        pure (Just (hscSupplies modName))
    | Just path <- Map.lookup modName wkLocal = namesIn =<< readFileText path
    | Just (package, tarball) <- Map.lookup modName wkIndex =
        remembered package >>= \case
          Just answer -> pure (exportedNames answer)
          Nothing ->
            readModule tarball modName >>= \case
              Nothing -> pure Nothing
              Just ForHsc -> do
                let names = Just (hscSupplies modName)
                store package (asExported names)
                pure names
              Just (Haskell text) -> do
                names <- namesIn (Just text)
                store package (asExported names)
                pure names
    | otherwise = pure Nothing
    where
      remembered package = case wkCache of
        Nothing -> pure Nothing
        Just c -> cachedExportNames c package modName
      store package answer = case wkCache of
        Nothing -> pure ()
        Just c -> storeExportNames c package modName answer
      namesIn text = case parsedLeaves =<< text of
        Nothing -> pure Nothing
        Just modules ->
          fmap Set.unions . sequence <$> traverse readOne modules
      readOne (implicitPrelude, hsModule) =
        exportNamesWithReexports
          implicitPrelude
          (wkReachExports visiting')
          (wkReachChildren visiting')
          modName
          hsModule
      visiting' = Set.insert modName visiting
      parsedLeaves = configurationsOf wkMacros Nothing modName

-- | What a module keeps under each of its names, so that a @T(..)@ in an
-- import list can be told what it brings in.
childrenOfModule :: Workings -> Set Text -> Text -> IO (Map OpName (Set OpName))
childrenOfModule
  Workings
    { wkRoutes,
      wkCache,
      wkLocal,
      wkIndex,
      wkInterfaces,
      wkInterfaceOf,
      wkReachChildren,
      wkExtensionsOf,
      wkMacros
    }
  visiting
  modName
    | Just path <- Map.lookup modName wkLocal,
      writtenForHsc path =
        pure Map.empty
    | Just path <- Map.lookup modName wkLocal =
        readFileText path >>= \case
          Nothing -> pure Map.empty
          Just text -> inSource text
    | otherwise = firstAnswer (map taking wkRoutes)
    where
      taking = \case
        FromInterface -> case Map.lookup modName wkInterfaces of
          Nothing -> pure Nothing
          Just (key, _) -> keptUnder key outOfInterface
        FromSource -> case Map.lookup modName wkIndex of
          Nothing -> pure Nothing
          Just (package, tarball) ->
            keptUnder package $
              readModule tarball modName >>= \case
                Nothing -> pure Nothing
                Just ForHsc -> pure (Just Map.empty)
                Just (Haskell text) -> Just <$> inSource text
      firstAnswer [] = pure Map.empty
      firstAnswer (route : rest) =
        route >>= \case
          Just kept -> pure kept
          Nothing -> firstAnswer rest
      keptUnder package readIt =
        remembered package >>= \case
          Just kept -> pure (Just kept)
          Nothing -> do
            kept <- readIt
            traverse_ (store package) kept
            pure kept
      remembered package = case wkCache of
        Nothing -> pure Nothing
        Just c -> cachedChildren c package modName
      store package kept = case wkCache of
        Nothing -> pure ()
        Just c -> storeChildren c package modName kept
      outOfInterface = fmap interfaceChildren <$> wkInterfaceOf modName
      inSource text = do
        extensions <- wkExtensionsOf modName
        case parsedLeaves extensions text of
          Nothing -> pure Map.empty
          Just modules ->
            Map.unionsWith Set.union
              <$> traverse readOne modules
      readOne (implicitPrelude, hsModule) =
        childrenWithReexports
          implicitPrelude
          (wkReachChildren visiting')
          modName
          hsModule
      visiting' = Set.insert modName visiting
      parsedLeaves extensions = configurationsOf wkMacros (Just extensions) modName

-- | Work out what a module can see, using a resolver to reach its imports.
--
-- This is the join between the pure half of "Tilia.Fixity" and the half
-- that touches the disk: the imports are resolved first, and the scope is
-- then computed from the answers. Note that an import the resolver could
-- not read arrives as 'Nothing' and stays 'Nothing', which is what lets
-- 'Tilia.Fixity.lookupFixity' distinguish a conclusion from a guess.
scopeFor ::
  -- | What can be asked about the modules it imports
  Resolver ->
  -- | Whether @ImplicitPrelude@ is on, which the module's own pragmas
  -- and its package's @default-extensions@ decide between them
  Choice "implicitPrelude" ->
  -- | The module whose scope is wanted, already parsed
  HsModule GhcPs ->
  -- | Everything that module can see, and what it could not find out
  IO Scope
scopeFor resolver implicitPrelude hsModule = do
  let imports = moduleImports implicitPrelude hsModule
  answers <- traverse (\m -> (m,) <$> askFixities resolver m) (map importModule imports)
  let table = Map.fromList answers
      unread = [m | (m, Nothing) <- answers]
  names <- Map.fromList <$> traverse (\m -> (m,) <$> askExportNames resolver m) unread
  chains <- Map.fromList <$> traverse (\m -> (m,) <$> askChain resolver m) unread
  kept <-
    Map.fromList
      <$> traverse
        (\m -> (m,) <$> askChildren resolver m)
        (Set.toList (Set.fromList (map importModule (filter expands imports))))
  pure $
    resolveScope
      implicitPrelude
      Known
        { knownFixities = \m -> Map.findWithDefault Nothing m table,
          knownChildren = \m -> Map.findWithDefault Map.empty m kept,
          knownExportNames = \m -> Map.findWithDefault Nothing m names,
          knownChain = \m -> Map.findWithDefault [] m chains
        }
      hsModule
  where
    expands i = case importNames i of
      Nothing -> False
      Just (_, items) -> any isAll items
    isAll = \case
      ImportedAll _ -> True
      _ -> False

-- | Everything a resolver consults, and the way back into it.
--
-- None of it changes from one module to the next, which is why
-- 'newResolverVia' builds it once and hands it over whole. What comes back
-- out of that is the 'Resolver'; this is what is behind it.
data Workings = Workings
  { -- | Which readings to try, in the order given.
    wkRoutes :: [Route],
    -- | Where to remember answers between runs.
    wkCache :: Maybe Cache,
    -- | The modules of the project's own packages, which are read straight
    -- from disk rather than out of an archive.
    wkLocal :: Map Text FilePath,
    -- | Which package holds each module, and the tarball to find it in; the
    -- package is the cache key, which carries the hash the tarball was
    -- verified against.
    wkIndex :: Map Text (Text, FilePath),
    -- | What to file an answer read out of each module's interface under.
    wkInterfaces :: Map Text (Text, FilePath),
    -- | A module's interface, read at most once a run.
    wkInterfaceOf :: Text -> IO (Maybe Interface),
    -- | How to reach another module. Tied back on itself by
    -- 'newResolverVia', so that the memo it keeps covers the recursive
    -- calls too.
    wkReach :: Set Text -> Text -> IO (Maybe (Fixities)),
    -- | How to reach another module for what its names carry with them,
    -- tied back the same way and against a visiting set of its own.
    wkReachChildren :: Set Text -> Text -> IO (Map OpName (Set OpName)),
    -- | How to reach another module for what its export list names, tied
    -- back the same way again.
    wkReachExports :: Set Text -> Text -> IO (Maybe (Set OpName)),
    -- | What the package a module belongs to puts in force. A module that
    -- leans on its package's @default-extensions@ does not parse without
    -- them, and one that does not parse cannot be read for anything.
    wkExtensionsOf :: Text -> IO [Extension],
    -- | What the plan settles about the questions a module's conditionals
    -- ask, so that a branch written for another version of a dependency is
    -- not read as part of it.
    wkMacros :: Macros,
    -- | The modules @cabal@ writes itself, which are therefore in no
    -- package's sources. See 'generatedModules'.
    wkGenerated :: Set Text
  }

-- | Where a module's fixities come from, in order of cost.
resolveModule ::
  -- | Where to look, and how to get back to the resolver.
  Workings ->
  -- | Modules currently being resolved further up the call chain.
  --
  -- Only passed through, so that a chase started here carries where it came
  -- from. What is done about a module already in it belongs to
  -- 'newResolverVia', which decides it before anything is remembered.
  Set Text ->
  -- | The module to resolve.
  Text ->
  -- | Its operator fixities, or, where they could not be established, the
  -- module below it that stopped us if there was one.
  IO Established
resolveModule
  Workings
    { wkRoutes,
      wkCache,
      wkLocal,
      wkIndex,
      wkInterfaces,
      wkInterfaceOf,
      wkReach,
      wkReachChildren,
      wkExtensionsOf,
      wkMacros,
      wkGenerated
    }
  visiting
  modName
    | Just builtin <- Map.lookup modName builtinFixities = pure (Declares builtin)
    | Just path <- Map.lookup modName wkLocal,
      writtenForHsc path =
        pure (hscDeclares modName)
    | Just path <- Map.lookup modName wkLocal =
        readFileText path >>= \case
          Nothing -> pure (Unreadable Nothing)
          Just source -> do
            extensions <- wkExtensionsOf modName
            fromText
              wkMacros
              extensions
              (wkReach visiting')
              (wkReachChildren visiting')
              visiting'
              source
              modName
    | otherwise = answered <$> firstAnswer (map taking wkRoutes)
    where
      visiting' = Set.insert modName visiting

      taking = \case
        FromInterface -> viaInterface
        FromSource -> viaArchive

      firstAnswer = go Nothing
        where
          go blamed [] = pure (Unreadable blamed)
          go blamed (route : rest) =
            route >>= \case
              Just (Declares fixities) -> pure (Declares fixities)
              Just (Unreadable below) -> go (blamed <|> below) rest
              Nothing -> go blamed rest

      viaInterface = case Map.lookup modName wkInterfaces of
        Nothing -> pure Nothing
        Just (key, _) ->
          cachedFor key >>= \case
            Just remembered -> pure (Just remembered)
            Nothing -> do
              established <- fromInterface wkInterfaceOf modName
              storeFor key established
              pure (Just established)

      viaArchive = case Map.lookup modName wkIndex of
        Nothing -> pure Nothing
        Just (package, tarball) ->
          cachedFor package >>= \case
            Just remembered -> pure (Just remembered)
            Nothing -> do
              extensions <- wkExtensionsOf modName
              fromSource
                wkMacros
                extensions
                (wkReach visiting')
                (wkReachChildren visiting')
                visiting'
                tarball
                modName
                >>= \case
                  NoArchive -> pure Nothing
                  FromArchive established -> do
                    storeFor package established
                    pure (Just established)

      answered = \case
        Declares fixities -> Declares fixities
        Unreadable below
          | Set.member modName wkGenerated -> Declares Map.empty
          | otherwise -> maybe (Unreadable below) Declares (byHand modName)
      byHand = fmap inBothNamespaces . (`Map.lookup` byHandFixities)
      cachedFor package = case wkCache of
        Nothing -> pure Nothing
        Just c -> cachedFixities c package modName
      storeFor package fixities = case wkCache of
        Nothing -> pure ()
        Just c -> storeFixities c package modName fixities

-- | Which package and tarball holds each module.
--
-- The module list of a package is itself cached: it comes from a @.cabal@
-- file inside an archive, and reading seventy of those is the bulk of what
-- starting up costs.
--
-- Where two packages expose the same module the first is kept. A plan that
-- builds cannot contain such a pair for any module the project imports, so
-- the choice only ever falls on a module nothing will ask about.
buildModuleIndex ::
  -- | Where to remember each package's module list, if anywhere.
  Maybe Cache ->
  -- | What the compiler says is installed. Empty if @ghc-pkg@ could not be
  -- run, in which case every package falls back to its @.cabal@ file.
  [InstalledPackage] ->
  -- | Every package that might have a tarball, and where it would be.
  [(PlanPackage, FilePath)] ->
  -- | For each module, the package that exposes it (as a cache key) and
  -- the tarball holding its source.
  IO (Map Text (Text, FilePath))
buildModuleIndex cache installed tarballs =
  Map.fromListWith (\_ first' -> first') . concat <$> traverse one tarballs
  where
    byNameVersion =
      Map.fromList [((ipName i, ipVersion i), ipModules i) | i <- installed]
    one (p, tarball) = do
      let key = cacheKey p
      let exposed = Map.lookup (ppName p, ppVersion p) byNameVersion
      held <- fromCabalFile cache key tarball p
      let modules = case (exposed, held) of
            (Nothing, Nothing) -> []
            (a, b) -> concat (catMaybes [a, b])
      pure [(m, (key, tarball)) | m <- modules]

-- | Where each installed module's compiled interface is.
--
-- Filed under the directory it was found in rather than under the package's
-- name and version, because those do not say which build: the same version
-- compiled with different flags can declare different fixities, and under
-- Nix a different build is a different directory.
interfaceIndex :: [InstalledPackage] -> Map Text (Text, FilePath)
interfaceIndex installed =
  Map.fromListWith
    (\_ first' -> first')
    [ (m, (key, dir </> T.unpack (T.replace "." "/" m) <> ".hi"))
    | i <- installed,
      dir <- ipImportDirs i,
      -- Bound out here so that the directory is hashed once rather than
      -- once for each of the modules found in it.
      let key = keyFor dir,
      m <- ipModules i
    ]
  where
    keyFor dir =
      "interface-"
        <> T.take 24 (T.decodeUtf8Lenient (B16.encode (SHA256.hash (T.encodeUtf8 (T.pack dir)))))

-- | Present a fixity map as an 'Interface'.
asInterface :: Fixities -> Interface
asInterface fixities =
  Interface
    { interfaceDeclares = fixities,
      interfacePassedOn = [],
      interfaceChildren = Map.empty
    }

-- | The fixities a compiled interface reports, and those it passes on.
fromInterface ::
  -- | A module's interface, if it has one
  (Text -> IO (Maybe Interface)) ->
  -- | The module to read
  Text ->
  IO Established
fromInterface interfaceOf modName =
  interfaceOf modName >>= \case
    Nothing -> pure (Unreadable Nothing)
    Just iface -> do
      declarers <- traverse asked (distinct (map fst (interfacePassedOn iface)))
      pure $ case [m | (m, Nothing) <- declarers] of
        (m : _) -> Unreadable (Just m)
        [] ->
          Declares . Map.union (interfaceDeclares iface) . Map.unions $
            [ Map.filterWithKey (\(_, o) _ -> o == op) (interfaceDeclares declarer)
            | (m, op) <- interfacePassedOn iface,
              Just (Just declarer) <- [lookup m declarers]
            ]
  where
    asked m = do
      interface <- interfaceOf m
      pure (m, interface)
    distinct = Map.keys . Map.fromList . map (,())

-- | A package's module list from the @.cabal@ file in its tarball.
fromCabalFile ::
  -- | Where to remember the answer, if anywhere.
  Maybe Cache ->
  -- | What to file it under. Carries the hash the tarball was verified
  -- against, so a changed tarball misses rather than matching stale data.
  Text ->
  -- | The tarball to read the @.cabal@ file out of.
  FilePath ->
  -- | The package it belongs to, consulted for the hash to verify against.
  PlanPackage ->
  -- | The modules it exposes, or 'Nothing' if the tarball is absent, fails
  -- verification, or holds no @.cabal@ file.
  IO (Maybe [Text])
fromCabalFile cache key tarball p = do
  remembered <- case cache of
    Nothing -> pure Nothing
    Just c -> cachedModules c key
  case remembered of
    -- A cached entry was written after the tarball was verified, and the
    -- key it is filed under contains the hash it was verified against, so a
    -- changed tarball simply misses rather than matching the wrong data.
    Just ms -> pure (Just ms)
    Nothing ->
      verified p tarball >>= \case
        False -> pure Nothing
        True ->
          packageModules tarball >>= \case
            Nothing -> pure Nothing
            Just ms -> do
              case cache of
                Nothing -> pure ()
                Just c -> storeModules c key ms
              pure (Just ms)

-- | How a package's cached answers are filed.
--
-- The expected hash is part of the key, so everything derived from a
-- tarball is bound to the exact bytes it was derived from. A package with
-- no hash in the plan is keyed by name and version alone.
cacheKey :: PlanPackage -> Text
cacheKey p =
  ppName p <> "-" <> ppVersion p <> maybe "" (("-" <>) . T.take 16) (sourceHashOf p)

-- | Does the tarball hash to what the plan says it should?
--
-- Hashing a few megabytes is not free, which is why it happens only on a
-- cache miss: once per package version per machine.
verified :: PlanPackage -> FilePath -> IO Bool
verified p tarball = case sourceHashOf p of
  Nothing -> pure True
  Just expected ->
    quietly False $ do
      actual <- sha256OfFile tarball
      pure (actual == T.toLower expected)

-- | The SHA-256 of a file, as lower-case hex.
sha256OfFile :: FilePath -> IO Text
sha256OfFile path = do
  bytes <- BL.readFile path
  pure (T.decodeUtf8Lenient (B16.encode (SHA256.hashlazy bytes)))

-- | Read a module's fixities out of a tarball, following re-exports.
fromSource ::
  -- | What the plan settles about its conditionals.
  Macros ->
  -- | What the module's package puts in force, before its own pragmas.
  [Extension] ->
  -- | How to reach another module, for chasing re-exports. This is
  -- 'resolveModule' tied back on itself, with the visiting set already
  -- extended.
  (Text -> IO (Maybe (Fixities))) ->
  -- | How to reach another module for what its names carry with them.
  (Text -> IO (Map OpName (Set OpName))) ->
  -- | Modules currently being resolved, passed through so that a
  -- re-export chain cannot loop.
  Set Text ->
  -- | The tarball holding this module's source.
  FilePath ->
  -- | The module to read.
  Text ->
  -- | What it declares, including what it only passes on, and whether that
  -- is worth remembering.
  IO Reading
fromSource macros extensions reach reachChildren visiting tarball modName =
  doesFileExist tarball >>= \case
    False -> pure NoArchive
    True ->
      readModule tarball modName >>= \case
        Nothing -> pure (FromArchive (Unreadable Nothing))
        Just ForHsc -> pure (FromArchive (hscDeclares modName))
        Just (Haskell source) ->
          FromArchive
            <$> fromText macros extensions reach reachChildren visiting source modName

-- | What came of looking for a module in an archive.
data Reading
  = -- | The archive was there, and this is what reading it established.
    FromArchive Established
  | -- | There was no archive to open. That is a fact about this machine and
    -- not about the module—the plan can stay exactly as it is while
    -- somebody downloads the sources—so it is never remembered.
    NoArchive

-- | The fixities a module's text declares and passes on.
fromText ::
  -- | What the plan settles about its conditionals.
  Macros ->
  -- | What the module's package puts in force, before its own pragmas.
  [Extension] ->
  -- | How to reach another module, for chasing re-exports. This is
  -- 'resolveModule' tied back on itself, with the visiting set already
  -- extended.
  (Text -> IO (Maybe (Fixities))) ->
  -- | How to reach another module for what its names carry with them.
  (Text -> IO (Map OpName (Set OpName))) ->
  -- | Modules currently being resolved, passed through so that a
  -- re-export chain cannot loop.
  Set Text ->
  -- | The module's source.
  Text ->
  -- | Its name.
  Text ->
  IO Established
fromText macros extensions reach reachChildren visiting source modName =
  case configurationsOf macros (Just extensions) modName source of
    Nothing -> pure (Unreadable Nothing)
    Just modules ->
      agreeing <$> traverse readOne modules
  where
    readOne (implicitPrelude, hsModule) =
      withReexports
        implicitPrelude
        reach
        reachChildren
        visiting
        modName
        hsModule

-- | One answer from every configuration that could be read, if they agree.
--
-- A module may declare a fixity in one configuration and a different one in
-- another. Which of them holds depends on how the module is compiled, which
-- is not ours to decide, so disagreement is not an answer. Agreement across
-- the ones we could read is one, and a stronger one than the blanked text
-- could give: it is a fact about the module rather than about a reading.
--
-- A configuration whose imports could not be resolved is passed over rather
-- than counted against the rest, because almost every one of those is a
-- branch meant for somewhere else. @System.IO.CodePage@ imports
-- @System.Win32.CodePage@ under @#ifdef WINDOWS@, and no plan solved on
-- Linux has Win32 anywhere in it. Refusing the whole module over a branch
-- that will never be compiled here would be letting a fact about this
-- machine stand as a fact about the module.
--
-- Every configuration unresolvable is still no answer. There is nothing
-- left to agree, and saying the module declares nothing would be a guess
-- rather than the silence it deserves. What is passed on then is the first
-- reason any configuration gave, which is as good as any: they are branches
-- of one module, and whichever of them is reported the reader is being sent
-- to a real module that really could not be read.
agreeing :: NonEmpty Established -> Established
agreeing answers = case [fixities | Declares fixities <- toList answers] of
  [] -> Unreadable (listToMaybe (catMaybes [below | Unreadable below <- toList answers]))
  readable ->
    maybe (Unreadable Nothing) Declares (foldM together Map.empty readable)
  where
    together settled found
      | and (Map.intersectionWith (==) settled found) = Just (Map.union settled found)
      | otherwise = Nothing

-- | Where each module that lives in a directory rather than an archive is.
localModules :: BuildPlan -> IO (Map Text FilePath)
localModules plan =
  Map.unions <$> traverse forPackage (concatMap directoryOf (bpPackages plan))
  where
    directoryOf p = case ppSource p of
      LocalPackage dir -> [dir]
      CheckedOut dir -> [dir]
      _ -> []
    forPackage dir = quietly Map.empty $ do
      entries <- listDirectory dir
      case filter (".cabal" `isSuffixOf`) entries of
        [] -> pure Map.empty
        (cabalFile : _) -> do
          contents <- readFileText (dir </> cabalFile)
          case contents of
            Nothing -> pure Map.empty
            Just text ->
              Map.fromList . concat
                <$> traverse (locate dir (sourceDirs text)) (containedModules text)

    -- A package may list several source directories and the @.cabal@ file
    -- does not say which one holds which module, so they are tried in turn
    -- and the first that has the file wins.
    locate dir dirs m = do
      found <-
        filterM
          doesFileExist
          [ dir </> T.unpack d </> modulePath m ending
          | d <- dirs,
            ending <- moduleEndings
          ]
      pure [(m, path) | path <- take 1 found]

    modulePath m ending = T.unpack (T.replace "." "/" m) <> ending

-- | Read a file, if it is there and is text.
readFileText :: FilePath -> IO (Maybe Text)
readFileText path = quietly Nothing $ do
  there <- doesFileExist path
  if there
    then Just . T.decodeUtf8Lenient <$> BS.readFile path
    else pure Nothing

-- | What a module passes on, as well as what it declares.
--
-- A module that exports an operator it did not declare carries no fixity of
-- its own for it, so the declaration is chased through the export list into
-- whichever module the name came from.
withReexports ::
  -- | Whether @ImplicitPrelude@ is on in the module being read.
  Choice "implicitPrelude" ->
  -- | How to reach another module, for names this one only passes on.
  (Text -> IO (Maybe (Fixities))) ->
  -- | How to reach another module for what its names carry with them,
  -- which is what a @T(..)@ this module hands on amounts to.
  (Text -> IO (Map OpName (Set OpName))) ->
  -- | Modules currently being resolved. A candidate already in here is
  -- skipped rather than followed.
  Set Text ->
  -- | The name this module was looked up under, used to recognise a
  -- @module M@ export that refers to the module itself.
  Text ->
  -- | The module, already parsed.
  HsModule GhcPs ->
  -- | What it declares together with what it re-exports, or the module it
  -- passes names on from that could not be read.
  IO Established
withReexports implicitPrelude reach reachChildren visiting modName hsModule =
  case moduleExports hsModule of
    Nothing -> pure (Declares own)
    Just items -> do
      carried <- carriedNames implicitPrelude reachChildren hsModule items
      let wanted = wantedNames items <> fromCarried carried
      visible <-
        if null wanted
          then pure []
          else
            traverse
              (\i -> (,) i <$> fromModule (importModule i))
              (moduleImports implicitPrelude hsModule)
      let handedOnWhole =
            wantedModules implicitPrelude modName hsModule items
      wholeModules <- traverse (\m -> (,) m <$> fromModule m) handedOnWhole
      pure $ case stoppedAt visible wholeModules of
        Just below -> Unreadable (Just below)
        Nothing ->
          let seen = [(i, exported) | (i, Just exported) <- visible]
              whole = [exported | (_, Just exported) <- wholeModules]
              passedOn =
                Map.unions
                  [ found
                  | (qualifier, op) <- wanted,
                    found <- take 1 (from qualifier op seen)
                  ]
           in Declares (Map.unions (own : passedOn : whole))
  where
    stoppedAt visible wholeModules =
      listToMaybe $
        [importModule i | (i, Nothing) <- visible]
          <> [m | (m, Nothing) <- wholeModules]
    own = declaredFixities hsModule
    defined = declaredNames hsModule
    wantedNames items =
      [(qualifier, op) | ExportName qualifier op <- items, not (Set.member op defined)]
        <> [(qualifier, op) | ExportAll qualifier op <- items, not (Set.member op defined)]
    fromCarried carried =
      [ (qualifier, op)
      | ((qualifier, _), Just ops) <- carried,
        op <- Set.toList ops,
        not (Set.member op defined)
      ]
    from qualifier op seen =
      [ found
      | (i, exported) <- seen,
        canSupply qualifier op i,
        let found = Map.filterWithKey (\(_, o) _ -> o == op) exported,
        not (Map.null found)
      ]
    fromModule m
      | m `Set.member` visiting = pure (Just Map.empty)
      | otherwise = reach m

-- | What each name a module's export list hands on carries with it.
childrenWithReexports ::
  -- | Whether @ImplicitPrelude@ is on in the module being read.
  Choice "implicitPrelude" ->
  -- | How to reach another module for what its names carry
  (Text -> IO (Map OpName (Set OpName))) ->
  -- | The name this module was looked up under
  Text ->
  -- | The module, already parsed
  HsModule GhcPs ->
  IO (Map OpName (Set OpName))
childrenWithReexports implicitPrelude reachChildren modName hsModule =
  case moduleExports hsModule of
    Nothing -> pure (moduleChildren hsModule)
    Just items -> do
      carried <- carriedNames implicitPrelude reachChildren hsModule items
      let handedOnWhole =
            wantedModules implicitPrelude modName hsModule items
      wholes <- traverse reachChildren handedOnWhole
      pure . Map.unionsWith Set.union $
        moduleChildren hsModule
          : Map.fromListWith Set.union [(parent, ops) | ((_, parent), Just ops) <- carried]
          : wholes

-- | The operators a module's export list names, following what it hands on.
--
-- 'exportedOperators' answers for a list that names everything outright.
-- Where the list hands a whole module on, or a @T(..)@ for a type declared
-- elsewhere, the answer is in another module and this goes and gets it.
--
-- 'Nothing' where any part of the list stays beyond us, since a set that
-- leaves names out would clear a module of carrying an operator it may
-- well carry. Everything or nothing: this answer is only ever used to rule
-- a module out.
exportNamesWithReexports ::
  -- | Whether @ImplicitPrelude@ is on in the module being read.
  Choice "implicitPrelude" ->
  -- | How to reach another module for what its export list names
  (Text -> IO (Maybe (Set OpName))) ->
  -- | How to reach another module for what its names carry
  (Text -> IO (Map OpName (Set OpName))) ->
  -- | The name this module was looked up under
  Text ->
  -- | The module, already parsed
  HsModule GhcPs ->
  IO (Maybe (Set OpName))
exportNamesWithReexports
  implicitPrelude
  reachNames
  reachChildren
  modName
  hsModule =
    case moduleExports hsModule of
      Nothing -> pure (Just (Set.fromList [op | (_, op) <- Map.keys (declaredFixities hsModule)]))
      Just items -> do
        carried <- carriedNames implicitPrelude reachChildren hsModule items
        let handedOnWhole =
              wantedModules implicitPrelude modName hsModule items
        wholes <- traverse reachNames handedOnWhole
        pure $ do
          fromWholes <- sequence wholes
          fromCarried <-
            traverse (\((_, parent), kids) -> Set.insert parent <$> kids) carried
          pure (Set.unions (named items : declaredHere items : fromCarried <> fromWholes))
    where
      declared = declaredChildren hsModule
      named items = Set.fromList [op | ExportName _ op <- items]
      declaredHere items =
        Set.unions
          [ Set.insert parent kids
          | ExportAll _ parent <- items,
            Just kids <- [Map.lookup parent declared]
          ]

-- | What the types a module hands on but does not declare carry with them,
-- asked of the modules they could have come from.
carriedNames ::
  -- | Whether @ImplicitPrelude@ is on in the module being read.
  Choice "implicitPrelude" ->
  -- | How to reach another module for what its export list names
  (Text -> IO (Map OpName (Set OpName))) ->
  -- | The module, already parsed
  HsModule GhcPs ->
  -- | Export items
  [ExportItem] ->
  -- | For each handed-on name, what it carries, or 'Nothing' where no
  -- module that could have supplied it had anything to say about it.
  IO [((Maybe Text, OpName), Maybe (Set OpName))]
carriedNames implicitPrelude reachChildren hsModule items =
  traverse (\(qualifier, parent) -> ((qualifier, parent),) <$> carriedBy qualifier parent) handedOn
  where
    declared = declaredChildren hsModule
    imports = moduleImports implicitPrelude hsModule
    handedOn =
      [ (qualifier, parent)
      | ExportAll qualifier parent <- items,
        not (Map.member parent declared)
      ]
    carriedBy qualifier parent = do
      answers <- traverse (reachChildren . importModule) (filter (canSupply qualifier parent) imports)
      pure $ case mapMaybe (Map.lookup parent) answers of
        [] -> Nothing
        kids -> Just (Set.unions kids)

-- | Could this import have supplied a name an export list hands on?
canSupply :: Maybe Text -> OpName -> Import -> Bool
canSupply qualifier op i =
  reaches && case importNames i of
    Nothing -> True
    Just (True, hidden) -> not (surelyNames Map.empty op hidden)
    Just (False, shown) -> mightBring Map.empty op shown
  where
    reaches = case qualifier of
      Nothing -> not (importQualified i)
      Just q -> importAlias i == q

-- | The modules a @module M@ export hands on whole, by their own names.
wantedModules ::
  Choice "implicitPrelude" ->
  Text ->
  HsModule GhcPs ->
  [ExportItem] ->
  [Text]
wantedModules implicitPrelude modName hsModule items =
  Set.toList . Set.fromList $
    concat [under m | ExportModule m <- items, not (isSelf m)]
  where
    under m = case [importModule i | i <- imports, importAlias i == m] of
      [] -> [m]
      aliased -> aliased
    imports = moduleImports implicitPrelude hsModule
    isSelf m = Just m == moduleName hsModule || m == modName

-- | What to parse a module with: what its package puts in force, and then
-- whatever its own pragmas say about that.
configFor :: [Extension] -> Text -> ParserConfig
configFor extensions source = parserConfigFor (effectiveExtensions extensions source)

-- | What a parse produced, where only having it or not matters.
whatParsed :: Either e a -> Maybe a
whatParsed = either (const Nothing) Just

-- | Every configuration the preprocessor allows of a module's text that is
-- Haskell, parsed, each with whether it has the Prelude without importing
-- it.
configurationsOf ::
  -- | What the plan settles about the questions its conditionals ask.
  Macros ->
  -- | What the module's package puts in force, or 'Nothing' where nothing
  -- is known about it. Then it is parsed under the most generous edition
  -- rather than the narrowest, and taken to have the Prelude unless it
  -- says otherwise—both being the way to be wrong that costs least.
  Maybe [Extension] ->
  -- | The module's name, for the parser to put in its errors
  Text ->
  -- | Its text
  Text ->
  Maybe (NonEmpty (Choice "implicitPrelude", HsModule GhcPs))
configurationsOf macros extensions modName text =
  NE.nonEmpty . mapMaybe parsed
    =<< whatParsed (branchLeaves (withoutRuledOut macros text))
  where
    parsed leaf =
      (,) (hasImplicitPrelude (fromMaybe [] extensions) leaf) . pmModule
        <$> whatParsed (parseModule (configOf leaf) named leaf)
    configOf leaf = maybe defaultParserConfig (`configFor` leaf) extensions
    named = T.unpack modName

-- | Does this module see the Prelude without importing it?
hasImplicitPrelude :: [Extension] -> Text -> Choice "implicitPrelude"
hasImplicitPrelude extensions source =
  fromBool (ImplicitPrelude `elem` effectiveExtensions extensions source)

-- | Find a module inside a tarball and say what was found.
--
-- Looked for under each of the endings a package may write a module with,
-- Haskell first. An @.hsc@ is reported rather than read: it is not Haskell
-- until @hsc2hs@ has been over it, and what it declares is answered out of
-- 'hscFixities' instead.
readModule :: FilePath -> Text -> IO (Maybe InArchive)
readModule tarball modName = quietly Nothing $ do
  bytes <- BL.readFile tarball
  let (cabal, candidates) = sweep Nothing [] (Tar.read (GZip.decompress bytes))
      dirs = maybe [] sourceDirs cabal
  pure (listToMaybe (mapMaybe (pick dirs candidates) moduleEndings))
  where
    suffix ending = "/" <> T.unpack (T.replace "." "/" modName) <> ending
    suffixes = map suffix moduleEndings
    sweep cabal found = \case
      Tar.Next entry rest
        | Tar.NormalFile content _ <- Tar.entryContent entry,
          cabalFileAtTop (entryPosixPath entry),
          Nothing <- cabal ->
            sweep (Just (decode content)) found rest
        | Tar.NormalFile content _ <- Tar.entryContent entry,
          any (`isSuffixOf` entryPosixPath entry) suffixes ->
            sweep cabal ((entryPosixPath entry, decode content) : found) rest
        | otherwise -> sweep cabal found rest
      _ -> (cabal, reverse found)
    pick dirs candidates ending =
      inArchive ending . snd
        <$> listToMaybe (under sfx dirs matching <> matching)
      where
        sfx = suffix ending
        matching = [c | c <- candidates, sfx `isSuffixOf` fst c]
    under sfx dirs matching = [e | d <- dirs, e <- matching, inDir sfx d (fst e)]
    inDir sfx d path
      | d == "." = takeWhile (/= '/') path <> sfx == path
      | otherwise = ("/" <> T.unpack d <> sfx) `isSuffixOf` path
    decode = T.decodeUtf8Lenient . BL.toStrict

-- | The endings a package may write a module under, in the order they are
-- tried.
--
-- Plain Haskell first: a package that ships both has generated the one from
-- the other, and the generated one is the module as it will be compiled.
moduleEndings :: [String]
moduleEndings = [".hs", ".hsc"]

-- | What an archive holds for a module.
data InArchive
  = -- | Haskell, as the package wrote it.
    Haskell Text
  | -- | A module written for @hsc2hs@. Its text is not kept: there is
    -- nothing to be done with it, and 'hscFixities' answers for it.
    ForHsc

-- | What was found under one ending amounts to.
inArchive :: String -> Text -> InArchive
inArchive ending text
  | writtenForHsc ending = ForHsc
  | otherwise = Haskell text

-- | Is this a module @hsc2hs@ writes rather than one anybody compiles?
writtenForHsc :: FilePath -> Bool
writtenForHsc = isSuffixOf ".hsc"

-- | What an @.hsc@ module declares, which is nothing unless it is named.
--
-- See 'hscFixities' for why an absence is an answer here and not a refusal
-- to give one.
hscDeclares :: Text -> Established
hscDeclares modName =
  Declares (maybe Map.empty inBothNamespaces (Map.lookup modName hscFixities))

-- | The fixities an 'Established' holds, where it holds any.
fixitiesEstablished :: Established -> Maybe (Fixities)
fixitiesEstablished = \case
  Declares fixities -> Just fixities
  Unreadable _ -> Nothing

-- | The operators an @.hsc@ module can supply, on the same reasoning.
hscSupplies :: Text -> Set OpName
hscSupplies modName =
  maybe Set.empty Map.keysSet (Map.lookup modName hscFixities)