WithProjectPlan.hs

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}

-- | This project, prepared the way the specs that read it need it.
module Tilia.WithProjectPlan
  ( withProjectPlan,
    compilerShipped,
    Dependency (..),
    dependenciesOf,
    testsFor,
  )
where

import Control.Monad (filterM, unless)
import Data.Choice (pattern Do)
import Data.Maybe (isNothing, listToMaybe, mapMaybe)
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Text (Text)
import Data.Text qualified as T
import System.Directory (doesFileExist)
import System.FilePath (takeDirectory, (</>))
import System.IO.Unsafe (unsafePerformIO)
import Test.Hspec (Spec)
import Tilia.Cabal.Project (findProjectRoot)
import Tilia.Cabal.Target
  ( Target (..),
    componentInPlan,
    componentsOfTarget,
    describeTargetProblem,
  )
import Tilia.Fixity.PackageDb
  ( Installed (..),
    InstalledPackage (..),
    readInstalledPackages,
  )
import Tilia.Fixity.Plan
  ( BuildPlan (..),
    PackageSource (..),
    PlanPackage (..),
    loadPlan,
    plannedTarballs,
  )
import Tilia.Process (readProgramOutput)

-- | Build a spec around the build plan of this very project, with the
-- package sources that spec reads alongside it already fetched.
withProjectPlan :: (BuildPlan -> Spec) -> Spec
withProjectPlan use = either refuse use prepared
  where
    refuse why = error ("this project will not prepare: " <> T.unpack why)

-- | The answer 'withProjectPlan' hands out, worked out at most once.
prepared :: Either Text BuildPlan
prepared = unsafePerformIO prepare
{-# NOINLINE prepared #-}

-- | Find the project, have @cabal@ make it ready, and fetch what the specs
-- read that being ready does not cover.
prepare :: IO (Either Text BuildPlan)
prepare =
  findProjectRoot "." >>= \case
    Nothing -> pure (Left "no cabal.project or .cabal file above this directory")
    Just root ->
      componentsOfTarget root Everything >>= \case
        Left problem -> pure (Left (describeTargetProblem problem))
        Right components ->
          loadPlan (Do #useCache) (Do #download) (mapMaybe componentInPlan components) "." >>= \case
            Left why -> pure (Left why)
            Right plan -> Right plan <$ fetchMissingSources plan

-- | Fetch the source of every planned package the specs read that is not
-- already here.
fetchMissingSources :: BuildPlan -> IO ()
fetchMissingSources plan = do
  installed <- readInstalledPackages
  let unread = shippedIn installed <> modulelessIn installed
  absent <-
    filterM (fmap not . doesFileExist . snd)
      . filter (not . (`Set.member` unread) . ppName . fst)
      =<< plannedTarballs plan
  unless (null absent) $ do
    putStrLn ("fetching the source of " <> show (length absent) <> " package(s)")
    refused <- filterM (fmap isNothing . fetch . fst) absent
    unless (null refused) $
      putStrLn ("no source on Hackage for " <> unwords (fmap (named . fst) refused))
  where
    fetch p = readProgramOutput "cabal" ["fetch", "--no-dependencies", named p]
    named p = T.unpack (ppName p <> "-" <> ppVersion p)

-- | The packages that came with the compiler rather than from a release of
-- their own, by the directory they are installed beside @ghc@ in.
compilerShipped :: IO (Set Text)
compilerShipped = shippedIn <$> readInstalledPackages

-- | The same, of packages already read.
shippedIn :: Installed -> Set Text
shippedIn installed = case compilerDir of
  Nothing -> Set.empty
  Just dir ->
    Set.fromList [ipName p | p <- installedPackages installed, beside p == Just dir]
  where
    beside p = takeDirectory <$> listToMaybe (ipImportDirs p)
    compilerDir =
      listToMaybe
        [dir | p <- installedPackages installed, ipName p == "ghc", Just dir <- [beside p]]

-- | Packages holding no modules at all, such as the runtime system.
modulelessIn :: Installed -> Set Text
modulelessIn installed =
  Set.fromList [ipName p | p <- installedPackages installed, null (ipModules p)]

-- | A package this project is built against, as the compiler holds it.
data Dependency = Dependency
  { -- | The package name
    depPackage :: Text,
    -- | Each module the package holds, with the interface file the compiler
    -- wrote for it.
    depModules :: [(Text, FilePath)]
  }

-- | The modules of every package in the plan that the compiler can also
-- see, keeping the ones the predicate wants.
dependenciesOf :: (Text -> Bool) -> BuildPlan -> Installed -> IO [Dependency]
dependenciesOf wanted plan installed =
  filter (not . null . depModules) <$> traverse ofPackage candidates
  where
    candidates =
      [ (package, dir)
      | package <- installedPackages installed,
        Set.member (ipName package) planned,
        dir <- take 1 (ipImportDirs package)
      ]
    ofPackage (package, dir) =
      Dependency (ipName package)
        <$> filterM
          (doesFileExist . snd)
          [ (m, dir </> T.unpack (T.replace "." "/" m) <> ".hi")
          | m <- ipModules package,
            wanted m
          ]
    planned = Set.fromList [ppName p | p <- bpPackages plan, not (isLocal p)]
    isLocal p = case ppSource p of
      LocalPackage _ -> True
      _ -> False

-- | One test per package, splitting the large ones up.
testsFor :: Dependency -> [(String, [(Text, FilePath)])]
testsFor dependency = case chunksOf 32 (depModules dependency) of
  [whole] -> [(name, whole)]
  pieces ->
    [ (name <> " (" <> show i <> " of " <> show (length pieces) <> ")", piece)
    | (i, piece) <- zip [1 :: Int ..] pieces
    ]
  where
    name = T.unpack (depPackage dependency)

chunksOf :: Int -> [a] -> [[a]]
chunksOf n = \case
  [] -> []
  xs -> let (chunk, rest) = splitAt n xs in chunk : chunksOf n rest